<div><span style="font-family:arial,helvetica,sans-serif">Here is a considerably longer worked example using the analogy to J, borrowing heavily from Wadler:</span></div><div><font face="courier new, monospace"><br></font></div>
<div><div class="gmail_quote">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.</div></div><div class="gmail_quote">
<br></div><div><font face="courier new, monospace">-- Used for Hilbert</font></div><div><font face="courier new, monospace">{-# LANGUAGE DefaultSignatures, TypeOperators #-}</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">-- Used for Representable</font></div><div><font face="courier new, monospace">{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, </font><span style="font-family:'courier new',monospace">FlexibleContexts, FlexibleInstances #-}</span></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">module Search where</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">import Control.Applicative</font></div>
<div><font face="courier new, monospace">import Data.Function (on)</font></div><div><font face="courier new, monospace">import Data.Functor.Contravariant</font></div><div><font face="courier new, monospace">import GHC.Generics -- for Hilbert</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">newtype Search f a = Search { optimum :: f a -> a }</font></div><div><font face="courier new, monospace"><br></font></div>
<div><font face="courier new, monospace">instance Contravariant f => Functor (Search f) where</font></div><div><font face="courier new, monospace"> fmap f (Search g) = Search $ f . g . contramap f</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">instance Contravariant f => Applicative (Search f) where</font></div><div><font face="courier new, monospace"> pure a = Search $ \_ -> a</font></div><div><font face="courier new, monospace"> Search fs <*> Search as = Search $ \k -> </font></div>
<div><font face="courier new, monospace"> let </font><span style="font-family:'courier new',monospace">go f = f (as (contramap f k)) </span></div><div><font face="courier new, monospace"> in </font><span style="font-family:'courier new',monospace">go (fs (contramap go k))</span></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Contravariant f => Monad (Search f) where</font></div><div><font face="courier new, monospace"> return a = Search $ \_ -> a</font></div>
<div><font face="courier new, monospace"> Search ma >>= f = Search $ \k -> </font></div><div><font face="courier new, monospace"> optimum (f (ma (contramap (\a -> optimum (f a) k) k))) k</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">class Contravariant f => Union f where</font></div><div><font face="courier new, monospace"> union :: Search f a -> Search f a -> Search f a</font></div><div>
<font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Union Predicate where</font></div><div><font face="courier new, monospace"> union (Search ma) (Search mb) = Search $ \ p -> case ma p of</font></div>
<div><font face="courier new, monospace"> a | getPredicate p a -> a</font></div><div><font face="courier new, monospace"> | otherwise -> mb p</font></div><div><font face="courier new, monospace"><br></font></div>
<div><font face="courier new, monospace">instance Ord r => Union (Op r) where</font></div><div><font face="courier new, monospace"> union (Search ma) (Search mb) = Search $ \ f -> let</font></div><div><font face="courier new, monospace"> a = ma f</font></div>
<div><font face="courier new, monospace"> b = mb f</font></div><div><font face="courier new, monospace"> in if getOp f a >= getOp f b then a else b</font></div><div><font face="courier new, monospace"><br></font></div>
<div><font face="courier new, monospace">both :: Union f => a -> a -> Search f a</font></div><div><font face="courier new, monospace">both = on union pure</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">fromList :: Union f => [a] -> Search f a</font></div><div><font face="courier new, monospace">fromList = foldr1 union . map return</font></div><div><font face="courier new, monospace"><br>
</font></div><div><div><font face="courier new, monospace">class Contravariant f => Neg f where</font></div><div><font face="courier new, monospace"> neg :: f a -> f a</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">instance Neg Predicate where</font></div><div><font face="courier new, monospace"> neg (Predicate p) = Predicate (not . p)</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">instance Num r => Neg (Op r) where</font></div><div><font face="courier new, monospace"> neg (Op f) = Op (negate . f)</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">pessimum :: Neg f => Search f a -> f a -> a</font></div><div><font face="courier new, monospace">pessimum m p = optimum m (neg p)</font></div></div><div><font face="courier new, monospace"><br>
</font></div><div><div><div><font face="courier new, monospace">forsome :: Search Predicate a -> (a -> Bool) -> Bool</font></div><div><font face="courier new, monospace">forsome m p = p (optimum m (Predicate p))</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">forevery :: Search Predicate a -> (a -> Bool) -> Bool</font></div><div><font face="courier new, monospace">forevery m p = p (pessimum m (Predicate p))</font></div>
<div><font face="courier new, monospace"><br></font></div></div></div><div><div><font face="courier new, monospace">member :: Eq a => a -> Search Predicate a -> Bool</font></div><div><font face="courier new, monospace">member a x = forsome x (== a)</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">each :: (Union f, Bounded a, Enum a) => Search f a</font></div><div><font face="courier new, monospace">each = fromList [minBound..maxBound]</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">bit :: Union f => Search f Bool</font></div><div><font face="courier new, monospace">bit = fromList [False,True]</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">cantor :: Union f => Search f [Bool]</font></div><div><font face="courier new, monospace">cantor = sequence (repeat bit)</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">least :: (Int -> Bool) -> Int</font></div><div><font face="courier new, monospace">least p = head [ i | i <- [0..], p i ]</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">infixl 4 --></font></div><div><font face="courier new, monospace">(-->) :: Bool -> Bool -> Bool</font></div><div>
<font face="courier new, monospace">p --> q = not p || q</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">fan :: Eq r => ([Bool] -> r) -> Int</font></div>
<div><font face="courier new, monospace">fan f = least $ \ n -></font></div><div><font face="courier new, monospace"> forevery cantor $ \x -></font></div><div><font face="courier new, monospace"> forevery cantor $ \y -></font></div>
<div><font face="courier new, monospace"> (take n x == take n y) --> (f x == f y)</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">-- a length check that can handle infinite lists</font></div>
<div><font face="courier new, monospace">compareLength :: [a] -> Int -> Ordering</font></div><div><font face="courier new, monospace">compareLength xs n = case drop (n - 1) xs of</font></div><div><font face="courier new, monospace"> [] -> LT</font></div>
<div><font face="courier new, monospace"> [_] -> EQ</font></div><div><font face="courier new, monospace"> _ -> GT</font></div><div class="gmail_quote"></div></div><div><font face="courier new, monospace"><br></font></div>
<div><font face="courier new, monospace">-- Now, lets leave Haskell 98 behind</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">-- Using the new GHC generics to derive versions of Hilbert's epsilon</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">class GHilbert t where</font></div><div><font face="courier new, monospace"> gepsilon :: Union f => Search f (t a)</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">class Hilbert a where</font></div><div><font face="courier new, monospace"> -- <a href="http://en.wikipedia.org/wiki/Epsilon_calculus">http://en.wikipedia.org/wiki/Epsilon_calculus</a></font></div>
<div><font face="courier new, monospace"> epsilon :: Union f => Search f a</font></div><div><font face="courier new, monospace"> default epsilon :: (Union f, GHilbert (Rep a), Generic a) => Search f a</font></div>
<div><font face="courier new, monospace"> epsilon = fmap to gepsilon</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance GHilbert U1 where</font></div><div>
<font face="courier new, monospace"> gepsilon = return U1</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance (GHilbert f, GHilbert g) => GHilbert (f :*: g) where</font></div>
<div><font face="courier new, monospace"> gepsilon = liftA2 (:*:) gepsilon gepsilon</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance (GHilbert f, GHilbert g) => GHilbert (f :+: g) where</font></div>
<div><font face="courier new, monospace"> gepsilon = fmap L1 gepsilon `union` fmap R1 gepsilon</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance GHilbert a => GHilbert (M1 i c a) where</font></div>
<div><font face="courier new, monospace"> gepsilon = fmap M1 gepsilon</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Hilbert a => GHilbert (K1 i a) where</font></div>
<div><font face="courier new, monospace"> gepsilon = fmap K1 epsilon</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Hilbert ()</font></div><div><font face="courier new, monospace">instance (Hilbert a, Hilbert b) => Hilbert (a, b)</font></div>
<div><font face="courier new, monospace">instance (Hilbert a, Hilbert b, Hilbert c) => Hilbert (a, b, c)</font></div><div><font face="courier new, monospace">instance (Hilbert a, Hilbert b, Hilbert c, Hilbert d) => </font></div>
<div><font face="courier new, monospace"> Hilbert (a, b, c, d)</font></div><div><font face="courier new, monospace">instance (Hilbert a, Hilbert b, Hilbert c, Hilbert d, Hilbert e) =></font></div><div><font face="courier new, monospace"> Hilbert (a, b, c, d, e)</font></div>
<div><font face="courier new, monospace">instance Hilbert Bool</font></div><div><font face="courier new, monospace">instance Hilbert Ordering</font></div><div><span style="font-family:'courier new',monospace">instance Hilbert a => Hilbert [a]</span></div>
<div><font face="courier new, monospace">instance Hilbert a => Hilbert (Maybe a)</font></div><div><font face="courier new, monospace">instance (Hilbert a, Hilbert b) => Hilbert (Either a b)</font></div><div><font face="courier new, monospace">instance Hilbert Char where </font></div>
<div><font face="courier new, monospace"> epsilon = each</font></div><div><font face="courier new, monospace">instance (Union f, Hilbert a) => Hilbert (Search f a) where</font></div><div><font face="courier new, monospace"> epsilon = fmap fromList epsilon</font></div>
<div><div><font face="courier new, monospace"><br></font></div></div><div><div><span style="font-family:'courier new',monospace">search :: (Union f, Hilbert a) => f a -> a</span></div><div><font face="courier new, monospace">search = optimum epsilon</font></div>
</div><div><font face="courier new, monospace"><br></font></div><div><div><font face="courier new, monospace">find :: Hilbert a => (a -> Bool) -> a</font></div><div><font face="courier new, monospace">find = optimum epsilon . Predicate</font></div>
<div><font face="courier new, monospace"><br></font></div><div><span style="font-family:'courier new',monospace">every :: Hilbert a => (a -> Bool) -> Bool</span></div><div><font face="courier new, monospace">every = forevery epsilon</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">exists :: Hilbert a => (a -> Bool) -> Bool</font></div><div><font face="courier new, monospace">exists = forsome epsilon</font></div>
</div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">-- and MPTCs/Fundeps to define representable contravariant functors:</font></div><div><font face="courier new, monospace"><br>
</font></div><div><font face="courier new, monospace">class Contravariant f => Representable f r | f -> r where</font></div><div><font face="courier new, monospace"> represent :: f a -> a -> r</font></div><div>
<font face="courier new, monospace"> tally :: (a -> r) -> f a</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Representable (Op r) r where</font></div>
<div><font face="courier new, monospace"> represent (Op f) = f</font></div><div><font face="courier new, monospace"> tally = Op</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">instance Representable Predicate Bool where</font></div>
<div><font face="courier new, monospace"> represent (Predicate p) = p</font></div><div><font face="courier new, monospace"> tally = Predicate</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">supremum :: Representable f r => Search f a -> (a -> r) -> r</font></div>
<div><font face="courier new, monospace">supremum m p = p (optimum m (tally p))</font></div><div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace">infimum :: (Representable f r, Neg f) => Search f a -> (a -> r) -> r</font></div>
<div><font face="courier new, monospace">infimum m p = p (pessimum m (tally p))</font></div><div><font face="courier new, monospace"><br></font></div><div class="gmail_quote"><div class="gmail_quote">A few toy examples: </div>
<div class="gmail_quote"><font face="courier new, monospace"><br></font></div><div class="gmail_quote"><font face="courier new, monospace">ghci> supremum (fromList [1..10] :: Search (Op Int) Int) id</font></div><div class="gmail_quote">
<font face="courier new, monospace">10</font></div><div class="gmail_quote"><font face="courier new, monospace">ghci> find (=='a')</font></div><div class="gmail_quote"><font face="courier new, monospace">'a'</font></div>
<div class="gmail_quote"><font face="courier new, monospace">ghci> fan (!!4)</font></div><div class="gmail_quote"><font face="courier new, monospace">5</font></div></div><div class="gmail_quote"><font face="courier new, monospace">ghci> find (\xs -> compareLength xs 10 == EQ && (xs !! 4) == 'a') </font></div>
<div class="gmail_quote"><div class="gmail_quote"><font face="courier new, monospace">"\NUL\NUL\NUL\NULa\NUL\NUL\NUL\NUL\NUL"</font></div></div><div class="gmail_quote"><br></div><div class="gmail_quote">-Edward</div>