[Haskell-cafe] Have you seen this functor/contrafunctor combo?

[Edward Kmett]

As an aside, the Union constraint on epsilon/gepsilon is only needed for
the :+: case, you can search products just fine with any old contravariant
functor, as you'd expect given the existence of the Applicative.

-Edward

On Sat, Jun 9, 2012 at 6:28 PM, Edward Kmett <ekmett at gmail.com> wrote:

> Here is a considerably longer worked example using the analogy to J,
> borrowing heavily from Wadler:
>
> As J, this doesn't really add any power, but perhaps when used with
> non-representable functors like Equivalence/Comparison you can do something
> more interesting.
>
> -- Used for Hilbert
> {-# LANGUAGE DefaultSignatures, TypeOperators #-}
>
> -- Used for Representable
> {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,
> FlexibleInstances #-}
>
> module Search where
>
> import Control.Applicative
> import Data.Function (on)
> import Data.Functor.Contravariant
> import GHC.Generics -- for Hilbert
>
> newtype Search f a = Search { optimum :: f a -> a }
>
> instance Contravariant f => Functor (Search f) where
>   fmap f (Search g) = Search $ f . g . contramap f
>
> instance Contravariant f => Applicative (Search f) where
>  pure a = Search $ \_ -> a
>  Search fs <*> Search as = Search $ \k ->
>    let go f = f (as (contramap f k))
>    in  go (fs (contramap go k))
>
> instance Contravariant f => Monad (Search f) where
>   return a = Search $ \_ -> a
>   Search ma >>= f = Search $ \k ->
>     optimum (f (ma (contramap (\a -> optimum (f a) k) k))) k
>
> class Contravariant f => Union f where
>   union :: Search f a -> Search f a -> Search f a
>
> instance Union Predicate where
>   union (Search ma) (Search mb) = Search $ \ p -> case ma p of
>     a | getPredicate p a -> a
>       | otherwise        -> mb p
>
> instance Ord r => Union (Op r) where
>   union (Search ma) (Search mb) = Search $ \ f -> let
>       a = ma f
>       b = mb f
>     in if getOp f a >= getOp f b then a else b
>
> both :: Union f => a -> a -> Search f a
> both = on union pure
>
> fromList :: Union f => [a] -> Search f a
> fromList = foldr1 union . map return
>
> class Contravariant f => Neg f where
>   neg :: f a -> f a
>
> instance Neg Predicate where
>   neg (Predicate p) = Predicate (not . p)
>
> instance Num r => Neg (Op r) where
>   neg (Op f) = Op (negate . f)
>
> pessimum :: Neg f => Search f a -> f a -> a
> pessimum m p = optimum m (neg p)
>
> forsome :: Search Predicate a -> (a -> Bool) -> Bool
> forsome m p = p (optimum m (Predicate p))
>
> forevery :: Search Predicate a -> (a -> Bool) -> Bool
> forevery m p = p (pessimum m (Predicate p))
>
> member :: Eq a => a -> Search Predicate a -> Bool
> member a x = forsome x (== a)
>
> each :: (Union f, Bounded a, Enum a) => Search f a
> each = fromList [minBound..maxBound]
>
> bit :: Union f => Search f Bool
> bit = fromList [False,True]
>
> cantor :: Union f => Search f [Bool]
> cantor = sequence (repeat bit)
>
> least :: (Int -> Bool) -> Int
> least p = head [ i | i <- [0..], p i ]
>
> infixl 4 -->
> (-->) :: Bool -> Bool -> Bool
> p --> q = not p || q
>
> fan :: Eq r => ([Bool] -> r) -> Int
> fan f = least $ \ n ->
>           forevery cantor $ \x ->
>             forevery cantor $ \y ->
>               (take n x == take n y) --> (f x == f y)
>
> -- a length check that can handle infinite lists
> compareLength :: [a] -> Int -> Ordering
> compareLength xs n = case drop (n - 1) xs of
>    []  -> LT
>    [_] -> EQ
>    _   -> GT
>
> -- Now, lets leave Haskell 98 behind
>
> -- Using the new GHC generics to derive versions of Hilbert's epsilon
>
> class GHilbert t where
>   gepsilon :: Union f => Search f (t a)
>
> class Hilbert a where
>   -- http://en.wikipedia.org/wiki/Epsilon_calculus
>   epsilon :: Union f => Search f a
>   default epsilon :: (Union f, GHilbert (Rep a), Generic a) => Search f a
>   epsilon = fmap to gepsilon
>
> instance GHilbert U1 where
>   gepsilon = return U1
>
> instance (GHilbert f, GHilbert g) => GHilbert (f :*: g) where
>   gepsilon = liftA2 (:*:) gepsilon gepsilon
>
> instance (GHilbert f, GHilbert g) => GHilbert (f :+: g) where
>   gepsilon = fmap L1 gepsilon `union` fmap R1 gepsilon
>
> instance GHilbert a => GHilbert (M1 i c a) where
>   gepsilon = fmap M1 gepsilon
>
> instance Hilbert a => GHilbert (K1 i a) where
>   gepsilon = fmap K1 epsilon
>
> instance Hilbert ()
> instance (Hilbert a, Hilbert b) => Hilbert (a, b)
> instance (Hilbert a, Hilbert b, Hilbert c) => Hilbert (a, b, c)
> instance (Hilbert a, Hilbert b, Hilbert c, Hilbert d) =>
>   Hilbert (a, b, c, d)
> instance (Hilbert a, Hilbert b, Hilbert c, Hilbert d, Hilbert e) =>
>   Hilbert (a, b, c, d, e)
> instance Hilbert Bool
> instance Hilbert Ordering
> instance Hilbert a => Hilbert [a]
> instance Hilbert a => Hilbert (Maybe a)
> instance (Hilbert a, Hilbert b) => Hilbert (Either a b)
> instance Hilbert Char where
>   epsilon = each
> instance (Union f, Hilbert a) => Hilbert (Search f a) where
>   epsilon = fmap fromList epsilon
>
> search :: (Union f, Hilbert a) => f a -> a
> search = optimum epsilon
>
> find :: Hilbert a => (a -> Bool) -> a
> find = optimum epsilon . Predicate
>
> every :: Hilbert a => (a -> Bool) -> Bool
> every = forevery epsilon
>
> exists :: Hilbert a => (a -> Bool) -> Bool
> exists = forsome epsilon
>
> -- and MPTCs/Fundeps to define representable contravariant functors:
>
> class Contravariant f => Representable f r | f -> r where
>   represent :: f a -> a -> r
>   tally     :: (a -> r) -> f a
>
> instance Representable (Op r) r where
>   represent (Op f) = f
>   tally = Op
>
> instance Representable Predicate Bool where
>   represent (Predicate p) = p
>   tally = Predicate
>
> supremum :: Representable f r => Search f a -> (a -> r) -> r
> supremum m p = p (optimum m (tally p))
>
> infimum :: (Representable f r, Neg f) => Search f a -> (a -> r) -> r
> infimum m p = p (pessimum m (tally p))
>
> A few toy examples:
>
> ghci> supremum (fromList [1..10] :: Search (Op Int) Int) id
> 10
> ghci> find (=='a')
> 'a'
> ghci> fan (!!4)
> 5
> ghci> find (\xs -> compareLength xs 10 == EQ && (xs !! 4) == 'a')
> "\NUL\NUL\NUL\NULa\NUL\NUL\NUL\NUL\NUL"
>
> -Edward
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/haskell-cafe/attachments/20120609/73b0be93/attachment.htm>