In this question, the author has written an implementation of de Morgan's laws in Haskell. I understand the implementations of notAandnotB, and notAornotB, but I'm struggling to understand the implementation of notAorB which is:
notAorB :: (Either a b -> c) -> (a -> c, b -> c)
notAorB f = (f . Left, f . Right)
Could someone explain how the (f . Left, f . Right) part works? I've seen the . operator used before, but with three arguments, not two.
Thank you in advance.
Recall that the definition of the . operator is (f . g) x = f (g x), i.e. f . g = \x -> f (g x) (syntactically, it is a binary operator, it is just that Haskell’s syntax sugar permits the latter definition to be restated as the former). So, the definition you have can be rephrased as
notAorB f = ((\x -> f (Left x)), (\y -> f (Right y)))
(this can be done mechanically by Lambdabot on #haskell, tell him to #unpl ‹expr›), or more verbosely
notAorB f = (lt, rt)
where lt x = f (Left x)
rt y = f (Right y)
As always, try writing down the types. If (.) :: ∀ s t u. (t -> u) -> (s -> t) -> s -> u, f :: Either a b -> c, Left :: ∀ p q. p -> Either p q, then f . Left or (.) f Left :: a -> c, etc.
I ended up figuring it out. See the video and slides of a talk I gave:
slides/pdf
video
Original question:
In my effort to understand generic recursion schemes (i.e., that use Fix) I have found it useful to write list-only versions of the various schemes. It makes it much easier to understand the actual schemes (without the additional overhead of the Fix stuff).
However, I have not yet figured out how to define list-only versions of zygo and futu.
Here are my specialised definitions so far:
cataL :: (a -> b -> b) -> b -> [a] -> b
cataL f b (a : as) = f a (cataL f b as)
cataL _ b [] = b
paraL :: (a -> [a] -> b -> b) -> b -> [a] -> b
paraL f b (a : as) = f a as (paraL f b as)
paraL _ b [] = b
-- TODO: histo
-- DONE: zygo (see below)
anaL :: (b -> (a, b)) -> b -> [a]
anaL f b = let (a, b') = f b in a : anaL f b'
anaL' :: (b -> Maybe (a, b)) -> b -> [a]
anaL' f b = case f b of
Just (a, b') -> a : anaL' f b'
Nothing -> []
apoL :: ([b] -> Maybe (a, Either [b] [a])) -> [b] -> [a]
apoL f b = case f b of
Nothing -> []
Just (x, Left c) -> x : apoL f c
Just (x, Right e) -> x : e
-- DONE: futu (see below)
hyloL :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c
hyloL f z g = cataL f z . anaL' g
hyloL' :: (a -> c -> c) -> c -> (c -> Maybe (a, c)) -> c
hyloL' f z g = case g z of
Nothing -> z
Just (x,z') -> f x (hyloL' f z' g)
How do you define histo, zygo and futu for lists?
Zygomorphism is the high-falutin' mathsy name we give to folds built from two semi-mutually recursive functions. I'll give an example.
Imagine a function pm :: [Int] -> Int (for plus-minus) which intersperses + and - alternately through a list of numbers, such that pm [v,w,x,y,z] = v - (w + (x - (y + z))). You can write it out using primitive recursion:
lengthEven :: [a] -> Bool
lengthEven = even . length
pm0 [] = 0
pm0 (x:xs) = if lengthEven xs
then x - pm0 xs
else x + pm0 xs
Clearly pm0 is not compositional - you need to inspect the length of the whole list at each position to determine whether you're adding or subtracting. Paramorphism models primitive recursion of this sort, when the folding function needs to traverse the whole subtree at each iteration of the fold. So we can at least rewrite the code to conform to an established pattern.
paraL :: (a -> [a] -> b -> b) -> b -> [a] -> b
paraL f z [] = z
paraL f z (x:xs) = f x xs (paraL f z xs)
pm1 = paraL (\x xs acc -> if lengthEven xs then x - acc else x + acc) 0
But this is inefficient. lengthEven traverses the whole list at each iteration of the paramorphism resulting in an O(n2) algorithm.
We can make progress by noting that both lengthEven and para can be expressed as a catamorphism with foldr...
cataL = foldr
lengthEven' = cataL (\_ p -> not p) True
paraL' f z = snd . cataL (\x (xs, acc) -> (x:xs, f x xs acc)) ([], z)
... which suggests that we may be able to fuse the two operations into a single pass over the list.
pm2 = snd . cataL (\x (isEven, total) -> (not isEven, if isEven
then x - total
else x + total)) (True, 0)
We had a fold which depended on the result of another fold, and we were able to fuse them into one traversal of the list. Zygomorphism captures exactly this pattern.
zygoL :: (a -> b -> b) -> -- a folding function
(a -> b -> c -> c) -> -- a folding function which depends on the result of the other fold
b -> c -> -- zeroes for the two folds
[a] -> c
zygoL f g z e = snd . cataL (\x (p, q) -> (f x p, g x p q)) (z, e)
On each iteration of the fold, f sees its answer from the last iteration as in a catamorphism, but g gets to see both functions' answers. g entangles itself with f.
We'll write pm as a zygomorphism by using the first folding function to count whether the list is even or odd in length and the second one to calculate the total.
pm3 = zygoL (\_ p -> not p) (\x isEven total -> if isEven
then x - total
else x + total) True 0
This is classic functional programming style. We have a higher order function doing the heavy lifting of consuming the list; all we had to do was plug in the logic to aggregate results. The construction evidently terminates (you need only prove termination for foldr), and it's more efficient than the original hand-written version to boot.
Aside: #AlexR points out in the comments that zygomorphism has a big sister called mutumorphism, which captures mutual recursion in all
its glory. mutu generalises zygo in that both the folding
functions are allowed to inspect the other's result from the previous
iteration.
mutuL :: (a -> b -> c -> b) ->
(a -> b -> c -> c) ->
b -> c ->
[a] -> c
mutuL f g z e = snd . cataL (\x (p, q) -> (f x p q, g x p q)) (z, e)
You recover zygo from mutu simply by ignoring the extra argument.
zygoL f = mutuL (\x p q -> f x p)
Of course, all of these folding patterns generalise from lists to the fixed point of an arbitrary functor:
newtype Fix f = Fix { unFix :: f (Fix f) }
cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = f . fmap (cata f) . unFix
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f = snd . cata (\x -> (Fix $ fmap fst x, f x))
zygo :: Functor f => (f b -> b) -> (f (b, a) -> a) -> Fix f -> a
zygo f g = snd . cata (\x -> (f $ fmap fst x, g x))
mutu :: Functor f => (f (b, a) -> b) -> (f (b, a) -> a) -> Fix f -> a
mutu f g = snd . cata (\x -> (f x, g x))
Compare the definition of zygo with that of zygoL. Also note that zygo Fix = para, and that the latter three folds can be implemented in terms of cata. In foldology everything is related to everything else.
You can recover the list version from the generalised version.
data ListF a r = Nil_ | Cons_ a r deriving Functor
type List a = Fix (ListF a)
zygoL' :: (a -> b -> b) -> (a -> b -> c -> c) -> b -> c -> List a -> c
zygoL' f g z e = zygo k l
where k Nil_ = z
k (Cons_ x y) = f x y
l Nil_ = e
l (Cons_ x (y, z)) = g x y z
pm4 = zygoL' (\_ p -> not p) (\x isEven total -> if isEven
then x - total
else x + total) True 0
Histomorphism models dynamic programming, the technique of tabulating the results of previous subcomputations. (It's sometimes called course-of-value induction.) In a histomorphism, the folding function has access to a table of the results of earlier iterations of the fold. Compare this with the catamorphism, where the folding function can only see the result of the last iteration. The histomorphism has the benefit of hindsight - you can see all of history.
Here's the idea. As we consume the input list, the folding algebra will output a sequence of bs. histo will jot down each b as it emerges, attaching it to the table of results. The number of items in the history is equal to the number of list layers you've processed - by the time you've torn down the whole list, the history of your operation will have a length equal to that of the list.
This is what the history of iterating a list(ory) looks like:
data History a b = Ancient b | Age a b (History a b)
History is a list of pairs of things and results, with an extra result at the end corresponding to the []-thing. We'll pair up each layer of the input list with its corresponding result.
cataL = foldr
history :: (a -> History a b -> b) -> b -> [a] -> History a b
history f z = cataL (\x h -> Age x (f x h) h) (Ancient z)
Once you've folded up the whole list from right to left, your final result will be at the top of the stack.
headH :: History a b -> b
headH (Ancient x) = x
headH (Age _ x _) = x
histoL :: (a -> History a b -> b) -> b -> [a] -> b
histoL f z = headH . history f z
(It happens that History a is a comonad, but headH (née extract) is all we need to define histoL.)
History labels each layer of the input list with its corresponding result. The cofree comonad captures the pattern of labelling each layer of an arbitrary structure.
data Cofree f a = Cofree { headC :: a, tailC :: f (Cofree f a) }
(I came up with History by plugging ListF into Cofree and simplifying.)
Compare this with the free monad,
data Free f a = Free (f (Free f a))
| Return a
Free is a coproduct type; Cofree is a product type. Free layers up a lasagne of fs, with values a at the bottom of the lasagne. Cofree layers up the lasagne with values a at each layer. Free monads are generalised externally-labelled trees; cofree comonads are generalised internally-labelled trees.
With Cofree in hand, we can generalise from lists to the fixpoint of an arbitrary functor,
newtype Fix f = Fix { unFix :: f (Fix f) }
cata :: Functor f => (f b -> b) -> Fix f -> b
cata f = f . fmap (cata f) . unFix
histo :: Functor f => (f (Cofree f b) -> b) -> Fix f -> b
histo f = headC . cata (\x -> Cofree (f x) x)
and once more recover the list version.
data ListF a r = Nil_ | Cons_ a r deriving Functor
type List a = Fix (ListF a)
type History' a b = Cofree (ListF a) b
histoL' :: (a -> History' a b -> b) -> b -> List a -> b
histoL' f z = histo g
where g Nil_ = z
g (Cons_ x h) = f x h
Aside: histo is the dual of futu. Look at their types.
histo :: Functor f => (f (Cofree f a) -> a) -> (Fix f -> a)
futu :: Functor f => (a -> f (Free f a)) -> (a -> Fix f)
futu is histo with the arrows flipped and with Free replaced by
Cofree. Histomorphisms see the past; futumorphisms predict the future.
And much like cata f . ana g can be fused into a hylomorphism,
histo f . futu g can be fused into a
chronomorphism.
Even if you skip the mathsy parts, this paper by Hinze and Wu features a good, example-driven tutorial on histomorphisms and their usage.
Since no one else has answered for futu yet, I'll try to stumble my way through. I'm going to use ListF a b = Base [a] = ConsF a b | NilF
Taking the type in recursion-schemes: futu :: Unfoldable t => (a -> Base t (Free (Base t) a)) -> a -> t.
I'm going to ignore the Unfoldable constraint and substitute [b] in for t.
(a -> Base [b] (Free (Base [b]) a)) -> a -> [b]
(a -> ListF b (Free (ListF b) a)) -> a -> [b]
Free (ListF b) a) is a list, possibly with an a-typed hole at the end. This means that it's isomorphic to ([b], Maybe a). So now we have:
(a -> ListF b ([b], Maybe a)) -> a -> [b]
Eliminating the last ListF, noticing that ListF a b is isomorphic to Maybe (a, b):
(a -> Maybe (b, ([b], Maybe a))) -> a -> [b]
Now, I'm pretty sure that playing type-tetris leads to the only sensible implementation:
futuL f x = case f x of
Nothing -> []
Just (y, (ys, mz)) -> y : (ys ++ fz)
where fz = case mz of
Nothing -> []
Just z -> futuL f z
Summarizing the resulting function, futuL takes a seed value and a function which may produce at least one result, and possibly a new seed value if it produced a result.
At first I thought this was equivalent to
notFutuL :: (a -> ([b], Maybe a)) -> a -> [b]
notFutuL f x = case f x of
(ys, mx) -> ys ++ case mx of
Nothing -> []
Just x' -> notFutuL f x'
And in practice, perhaps it is, more or less, but the one significant difference is that the real futu guarantees productivity (i.e. if f always returns, you will never be stuck waiting forever for the next list element).
Given any container type we can form the (element-focused) Zipper and know that this structure is a Comonad. This was recently explored in wonderful detail in another Stack Overflow question for the following type:
data Bin a = Branch (Bin a) a (Bin a) | Leaf a deriving Functor
with the following zipper
data Dir = L | R
data Step a = Step a Dir (Bin a) deriving Functor
data Zip a = Zip [Step a] (Bin a) deriving Functor
instance Comonad Zip where ...
It is the case that Zip is a Comonad though the construction of its instance is a little hairy. That said, Zip can be completely mechanically derived from Tree and (I believe) any type derived this way is automatically a Comonad, so I feel it ought to be the case that we can construct these types and their comonads generically and automatically.
One method for achieving generality for zipper construction is the use the following class and type family
data Zipper t a = Zipper { diff :: D t a, here :: a }
deriving instance Diff t => Functor (Zipper t)
class (Functor t, Functor (D t)) => Diff t where
data D t :: * -> *
inTo :: t a -> t (Zipper t a)
outOf :: Zipper t a -> t a
which has (more or less) shown up in Haskell Cafe threads and on Conal Elliott's blog. This class can be instantiated for the various core algebraic types and thus provides a general framework for talking about the derivatives of ADTs.
So, ultimately, my question is whether or not we can write
instance Diff t => Comonad (Zipper t) where ...
which could be used to subsume the specific Comonad instance described above:
instance Diff Bin where
data D Bin a = DBin { context :: [Step a], descend :: Maybe (Bin a, Bin a) }
...
Unfortunately, I've had no luck writing such an instance. Is the inTo/outOf signature sufficient? Is there something else needed to constrain the types? Is this instance even possible?
Like the childcatcher in Chitty-Chitty-Bang-Bang luring kids into captivity with sweets and toys, recruiters to undergraduate Physics like to fool about with soap bubbles and boomerangs, but when the door clangs shut, it's "Right, children, time to learn about partial differentiation!". Me too. Don't say I didn't warn you.
Here's another warning: the following code needs {-# LANGUAGE KitchenSink #-}, or rather
{-# LANGUAGE TypeFamilies, FlexibleContexts, TupleSections, GADTs, DataKinds,
TypeOperators, FlexibleInstances, RankNTypes, ScopedTypeVariables,
StandaloneDeriving, UndecidableInstances #-}
in no particular order.
Differentiable functors give comonadic zippers
What is a differentiable functor, anyway?
class (Functor f, Functor (DF f)) => Diff1 f where
type DF f :: * -> *
upF :: ZF f x -> f x
downF :: f x -> f (ZF f x)
aroundF :: ZF f x -> ZF f (ZF f x)
data ZF f x = (:<-:) {cxF :: DF f x, elF :: x}
It's a functor which has a derivative, which is also a functor. The derivative represents a one-hole context for an element. The zipper type ZF f x represents the pair of a one-hole context and the element in the hole.
The operations for Diff1 describe the kinds of navigation we can do on zippers (without any notion of "leftward" and "rightward", for which see my Clowns and Jokers paper). We can go "upward", reassembling the structure by plugging the element in its hole. We can go "downward", finding every way to visit an element in a give structure: we decorate every element with its context. We can go "around",
taking an existing zipper and decorating each element with its context, so we find all the ways to refocus (and how to keep our current focus).
Now, the type of aroundF might remind some of you of
class Functor c => Comonad c where
extract :: c x -> x
duplicate :: c x -> c (c x)
and you're right to be reminded! We have, with a hop and a skip,
instance Diff1 f => Functor (ZF f) where
fmap f (df :<-: x) = fmap f df :<-: f x
instance Diff1 f => Comonad (ZF f) where
extract = elF
duplicate = aroundF
and we insist that
extract . duplicate == id
fmap extract . duplicate == id
duplicate . duplicate == fmap duplicate . duplicate
We also need that
fmap extract (downF xs) == xs -- downF decorates the element in position
fmap upF (downF xs) = fmap (const xs) xs -- downF gives the correct context
Polynomial functors are differentiable
Constant functors are differentiable.
data KF a x = KF a
instance Functor (KF a) where
fmap f (KF a) = KF a
instance Diff1 (KF a) where
type DF (KF a) = KF Void
upF (KF w :<-: _) = absurd w
downF (KF a) = KF a
aroundF (KF w :<-: _) = absurd w
There's nowhere to put an element, so it's impossible to form a context. There's nowhere to go upF or downF from, and we easily find all none of the ways to go downF.
The identity functor is differentiable.
data IF x = IF x
instance Functor IF where
fmap f (IF x) = IF (f x)
instance Diff1 IF where
type DF IF = KF ()
upF (KF () :<-: x) = IF x
downF (IF x) = IF (KF () :<-: x)
aroundF z#(KF () :<-: x) = KF () :<-: z
There's one element in a trivial context, downF finds it, upF repacks it, and aroundF can only stay put.
Sum preserves differentiability.
data (f :+: g) x = LF (f x) | RF (g x)
instance (Functor f, Functor g) => Functor (f :+: g) where
fmap h (LF f) = LF (fmap h f)
fmap h (RF g) = RF (fmap h g)
instance (Diff1 f, Diff1 g) => Diff1 (f :+: g) where
type DF (f :+: g) = DF f :+: DF g
upF (LF f' :<-: x) = LF (upF (f' :<-: x))
upF (RF g' :<-: x) = RF (upF (g' :<-: x))
The other bits and pieces are a bit more of a handful. To go downF, we must go downF inside the tagged component, then fix up the resulting zippers to show the tag in the context.
downF (LF f) = LF (fmap (\ (f' :<-: x) -> LF f' :<-: x) (downF f))
downF (RF g) = RF (fmap (\ (g' :<-: x) -> RF g' :<-: x) (downF g))
To go aroundF, we strip the tag, figure out how to go around the untagged thing, then restore the tag in all the resulting zippers. The element in focus, x, is replaced by its entire zipper, z.
aroundF z#(LF f' :<-: (x :: x)) =
LF (fmap (\ (f' :<-: x) -> LF f' :<-: x) . cxF $ aroundF (f' :<-: x :: ZF f x))
:<-: z
aroundF z#(RF g' :<-: (x :: x)) =
RF (fmap (\ (g' :<-: x) -> RF g' :<-: x) . cxF $ aroundF (g' :<-: x :: ZF g x))
:<-: z
Note that I had to use ScopedTypeVariables to disambiguate the recursive calls to aroundF. As a type function, DF is not injective, so the fact that f' :: D f x is not enough to force f' :<-: x :: Z f x.
Product preserves differentiability.
data (f :*: g) x = f x :*: g x
instance (Functor f, Functor g) => Functor (f :*: g) where
fmap h (f :*: g) = fmap h f :*: fmap h g
To focus on an element in a pair, you either focus on the left and leave the right alone, or vice versa. Leibniz's famous product rule corresponds to a simple spatial intuition!
instance (Diff1 f, Diff1 g) => Diff1 (f :*: g) where
type DF (f :*: g) = (DF f :*: g) :+: (f :*: DF g)
upF (LF (f' :*: g) :<-: x) = upF (f' :<-: x) :*: g
upF (RF (f :*: g') :<-: x) = f :*: upF (g' :<-: x)
Now, downF works similarly to the way it did for sums, except that we have to fix up the zipper context not only with a tag (to show which way we went) but also with the untouched other component.
downF (f :*: g)
= fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x) (downF f)
:*: fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x) (downF g)
But aroundF is a massive bag of laughs. Whichever side we are currently visiting, we have two choices:
Move aroundF on that side.
Move upF out of that side and downF into the other side.
Each case requires us to make use of the operations for the substructure, then fix up contexts.
aroundF z#(LF (f' :*: g) :<-: (x :: x)) =
LF (fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x)
(cxF $ aroundF (f' :<-: x :: ZF f x))
:*: fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x) (downF g))
:<-: z
where f = upF (f' :<-: x)
aroundF z#(RF (f :*: g') :<-: (x :: x)) =
RF (fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x) (downF f) :*:
fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x)
(cxF $ aroundF (g' :<-: x :: ZF g x)))
:<-: z
where g = upF (g' :<-: x)
Phew! The polynomials are all differentiable, and thus give us comonads.
Hmm. It's all a bit abstract. So I added deriving Show everywhere I could, and threw in
deriving instance (Show (DF f x), Show x) => Show (ZF f x)
which allowed the following interaction (tidied up by hand)
> downF (IF 1 :*: IF 2)
IF (LF (KF () :*: IF 2) :<-: 1) :*: IF (RF (IF 1 :*: KF ()) :<-: 2)
> fmap aroundF it
IF (LF (KF () :*: IF (RF (IF 1 :*: KF ()) :<-: 2)) :<-: (LF (KF () :*: IF 2) :<-: 1))
:*:
IF (RF (IF (LF (KF () :*: IF 2) :<-: 1) :*: KF ()) :<-: (RF (IF 1 :*: KF ()) :<-: 2))
Exercise Show that the composition of differentiable functors is differentiable, using the chain rule.
Sweet! Can we go home now? Of course not. We haven't differentiated any recursive structures yet.
Making recursive functors from bifunctors
A Bifunctor, as the existing literature on datatype generic programming (see work by Patrik Jansson and Johan Jeuring, or excellent lecture notes by Jeremy Gibbons) explains at length is a type constructor with two parameters, corresponding to two sorts of substructure. We should be able to "map" both.
class Bifunctor b where
bimap :: (x -> x') -> (y -> y') -> b x y -> b x' y'
We can use Bifunctors to give the node structure of recursive containers. Each node has subnodes and elements. These can just be the two sorts of substructure.
data Mu b y = In (b (Mu b y) y)
See? We "tie the recursive knot" in b's first argument, and keep the parameter y in its second. Accordingly, we obtain once for all
instance Bifunctor b => Functor (Mu b) where
fmap f (In b) = In (bimap (fmap f) f b)
To use this, we'll need a kit of Bifunctor instances.
The Bifunctor Kit
Constants are bifunctorial.
newtype K a x y = K a
instance Bifunctor (K a) where
bimap f g (K a) = K a
You can tell I wrote this bit first, because the identifiers are shorter, but that's good because the code is longer.
Variables are bifunctorial.
We need the bifunctors corresponding to one parameter or the other, so I made a datatype to distinguish them, then defined a suitable GADT.
data Var = X | Y
data V :: Var -> * -> * -> * where
XX :: x -> V X x y
YY :: y -> V Y x y
That makes V X x y a copy of x and V Y x y a copy of y. Accordingly
instance Bifunctor (V v) where
bimap f g (XX x) = XX (f x)
bimap f g (YY y) = YY (g y)
Sums and Products of bifunctors are bifunctors
data (:++:) f g x y = L (f x y) | R (g x y) deriving Show
instance (Bifunctor b, Bifunctor c) => Bifunctor (b :++: c) where
bimap f g (L b) = L (bimap f g b)
bimap f g (R b) = R (bimap f g b)
data (:**:) f g x y = f x y :**: g x y deriving Show
instance (Bifunctor b, Bifunctor c) => Bifunctor (b :**: c) where
bimap f g (b :**: c) = bimap f g b :**: bimap f g c
So far, so boilerplate, but now we can define things like
List = Mu (K () :++: (V Y :**: V X))
Bin = Mu (V Y :**: (K () :++: (V X :**: V X)))
If you want to use these types for actual data and not go blind in the pointilliste tradition of Georges Seurat, use pattern synonyms.
But what of zippers? How shall we show that Mu b is differentiable? We shall need to show that b is differentiable in both variables. Clang! It's time to learn about partial differentiation.
Partial derivatives of bifunctors
Because we have two variables, we shall need to be able to talk about them collectively sometimes and individually at other times. We shall need the singleton family:
data Vary :: Var -> * where
VX :: Vary X
VY :: Vary Y
Now we can say what it means for a Bifunctor to have partial derivatives at each variable, and give the corresponding notion of zipper.
class (Bifunctor b, Bifunctor (D b X), Bifunctor (D b Y)) => Diff2 b where
type D b (v :: Var) :: * -> * -> *
up :: Vary v -> Z b v x y -> b x y
down :: b x y -> b (Z b X x y) (Z b Y x y)
around :: Vary v -> Z b v x y -> Z b v (Z b X x y) (Z b Y x y)
data Z b v x y = (:<-) {cxZ :: D b v x y, elZ :: V v x y}
This D operation needs to know which variable to target. The corresponding zipper Z b v tells us which variable v must be in focus. When we "decorate with context", we have to decorate x-elements with X-contexts and y-elements with Y-contexts. But otherwise, it's the same story.
We have two remaining tasks: firstly, to show that our bifunctor kit is differentiable; secondly, to show that Diff2 b allows us to establish Diff1 (Mu b).
Differentiating the Bifunctor kit
I'm afraid this bit is fiddly rather than edifying. Feel free to skip along.
The constants are as before.
instance Diff2 (K a) where
type D (K a) v = K Void
up _ (K q :<- _) = absurd q
down (K a) = K a
around _ (K q :<- _) = absurd q
On this occasion, life is too short to develop the theory of the type level Kronecker-delta, so I just treated the variables separately.
instance Diff2 (V X) where
type D (V X) X = K ()
type D (V X) Y = K Void
up VX (K () :<- XX x) = XX x
up VY (K q :<- _) = absurd q
down (XX x) = XX (K () :<- XX x)
around VX z#(K () :<- XX x) = K () :<- XX z
around VY (K q :<- _) = absurd q
instance Diff2 (V Y) where
type D (V Y) X = K Void
type D (V Y) Y = K ()
up VX (K q :<- _) = absurd q
up VY (K () :<- YY y) = YY y
down (YY y) = YY (K () :<- YY y)
around VX (K q :<- _) = absurd q
around VY z#(K () :<- YY y) = K () :<- YY z
For the structural cases, I found it useful to introduce a helper allowing me to treat variables uniformly.
vV :: Vary v -> Z b v x y -> V v (Z b X x y) (Z b Y x y)
vV VX z = XX z
vV VY z = YY z
I then built gadgets to facilitate the kind of "retagging" we need for down and around. (Of course, I saw which gadgets I needed as I was working.)
zimap :: (Bifunctor c) => (forall v. Vary v -> D b v x y -> D b' v x y) ->
c (Z b X x y) (Z b Y x y) -> c (Z b' X x y) (Z b' Y x y)
zimap f = bimap
(\ (d :<- XX x) -> f VX d :<- XX x)
(\ (d :<- YY y) -> f VY d :<- YY y)
dzimap :: (Bifunctor (D c X), Bifunctor (D c Y)) =>
(forall v. Vary v -> D b v x y -> D b' v x y) ->
Vary v -> Z c v (Z b X x y) (Z b Y x y) -> D c v (Z b' X x y) (Z b' Y x y)
dzimap f VX (d :<- _) = bimap
(\ (d :<- XX x) -> f VX d :<- XX x)
(\ (d :<- YY y) -> f VY d :<- YY y)
d
dzimap f VY (d :<- _) = bimap
(\ (d :<- XX x) -> f VX d :<- XX x)
(\ (d :<- YY y) -> f VY d :<- YY y)
d
And with that lot ready to go, we can grind out the details. Sums are easy.
instance (Diff2 b, Diff2 c) => Diff2 (b :++: c) where
type D (b :++: c) v = D b v :++: D c v
up v (L b' :<- vv) = L (up v (b' :<- vv))
down (L b) = L (zimap (const L) (down b))
down (R c) = R (zimap (const R) (down c))
around v z#(L b' :<- vv :: Z (b :++: c) v x y)
= L (dzimap (const L) v ba) :<- vV v z
where ba = around v (b' :<- vv :: Z b v x y)
around v z#(R c' :<- vv :: Z (b :++: c) v x y)
= R (dzimap (const R) v ca) :<- vV v z
where ca = around v (c' :<- vv :: Z c v x y)
Products are hard work, which is why I'm a mathematician rather than an engineer.
instance (Diff2 b, Diff2 c) => Diff2 (b :**: c) where
type D (b :**: c) v = (D b v :**: c) :++: (b :**: D c v)
up v (L (b' :**: c) :<- vv) = up v (b' :<- vv) :**: c
up v (R (b :**: c') :<- vv) = b :**: up v (c' :<- vv)
down (b :**: c) =
zimap (const (L . (:**: c))) (down b) :**: zimap (const (R . (b :**:))) (down c)
around v z#(L (b' :**: c) :<- vv :: Z (b :**: c) v x y)
= L (dzimap (const (L . (:**: c))) v ba :**:
zimap (const (R . (b :**:))) (down c))
:<- vV v z where
b = up v (b' :<- vv :: Z b v x y)
ba = around v (b' :<- vv :: Z b v x y)
around v z#(R (b :**: c') :<- vv :: Z (b :**: c) v x y)
= R (zimap (const (L . (:**: c))) (down b):**:
dzimap (const (R . (b :**:))) v ca)
:<- vV v z where
c = up v (c' :<- vv :: Z c v x y)
ca = around v (c' :<- vv :: Z c v x y)
Conceptually, it's just as before, but with more bureaucracy. I built these using pre-type-hole technology, using undefined as a stub in places I wasn't ready to work, and introducing a deliberate type error in the one place (at any given time) where I wanted a useful hint from the typechecker. You too can have the typechecking as videogame experience, even in Haskell.
Subnode zippers for recursive containers
The partial derivative of b with respect to X tells us how to find a subnode one step inside a node, so we get the conventional notion of zipper.
data MuZpr b y = MuZpr
{ aboveMu :: [D b X (Mu b y) y]
, hereMu :: Mu b y
}
We can zoom all the way up to the root by repeated plugging in X positions.
muUp :: Diff2 b => MuZpr b y -> Mu b y
muUp (MuZpr {aboveMu = [], hereMu = t}) = t
muUp (MuZpr {aboveMu = (dX : dXs), hereMu = t}) =
muUp (MuZpr {aboveMu = dXs, hereMu = In (up VX (dX :<- XX t))})
But we need element-zippers.
Element-zippers for fixpoints of bifunctors
Each element is somewhere inside a node. That node is sitting under a stack of X-derivatives. But the position of the element in that node is given by a Y-derivative. We get
data MuCx b y = MuCx
{ aboveY :: [D b X (Mu b y) y]
, belowY :: D b Y (Mu b y) y
}
instance Diff2 b => Functor (MuCx b) where
fmap f (MuCx { aboveY = dXs, belowY = dY }) = MuCx
{ aboveY = map (bimap (fmap f) f) dXs
, belowY = bimap (fmap f) f dY
}
Boldly, I claim
instance Diff2 b => Diff1 (Mu b) where
type DF (Mu b) = MuCx b
but before I develop the operations, I'll need some bits and pieces.
I can trade data between functor-zippers and bifunctor-zippers as follows:
zAboveY :: ZF (Mu b) y -> [D b X (Mu b y) y] -- the stack of `X`-derivatives above me
zAboveY (d :<-: y) = aboveY d
zZipY :: ZF (Mu b) y -> Z b Y (Mu b y) y -- the `Y`-zipper where I am
zZipY (d :<-: y) = belowY d :<- YY y
That's enough to let me define:
upF z = muUp (MuZpr {aboveMu = zAboveY z, hereMu = In (up VY (zZipY z))})
That is, we go up by first reassembling the node where the element is, turning an element-zipper into a subnode-zipper, then zooming all the way out, as above.
Next, I say
downF = yOnDown []
to go down starting with the empty stack, and define the helper function which goes down repeatedly from below any stack:
yOnDown :: Diff2 b => [D b X (Mu b y) y] -> Mu b y -> Mu b (ZF (Mu b) y)
yOnDown dXs (In b) = In (contextualize dXs (down b))
Now, down b only takes us inside the node. The zippers we need must also carry the node's context. That's what contextualise does:
contextualize :: (Bifunctor c, Diff2 b) =>
[D b X (Mu b y) y] ->
c (Z b X (Mu b y) y) (Z b Y (Mu b y) y) ->
c (Mu b (ZF (Mu b) y)) (ZF (Mu b) y)
contextualize dXs = bimap
(\ (dX :<- XX t) -> yOnDown (dX : dXs) t)
(\ (dY :<- YY y) -> MuCx {aboveY = dXs, belowY = dY} :<-: y)
For every Y-position, we must give an element-zipper, so it is good we know the whole context dXs back to the root, as well as the dY which describes how the element sits in its node. For every X-position, there is a further subtree to explore, so we grow the stack and keep going!
That leaves only the business of shifting focus. We might stay put, or go down from where we are, or go up, or go up and then down some other path. Here goes.
aroundF z#(MuCx {aboveY = dXs, belowY = dY} :<-: _) = MuCx
{ aboveY = yOnUp dXs (In (up VY (zZipY z)))
, belowY = contextualize dXs (cxZ $ around VY (zZipY z))
} :<-: z
As ever, the existing element is replaced by its entire zipper. For the belowY part, we look where else we can go in the existing node: we will find either alternative element Y-positions or further X-subnodes to explore, so we contextualise them. For the aboveY part, we must work our way back up the stack of X-derivatives after reassembling the node we were visiting.
yOnUp :: Diff2 b => [D b X (Mu b y) y] -> Mu b y ->
[D b X (Mu b (ZF (Mu b) y)) (ZF (Mu b) y)]
yOnUp [] t = []
yOnUp (dX : dXs) (t :: Mu b y)
= contextualize dXs (cxZ $ around VX (dX :<- XX t))
: yOnUp dXs (In (up VX (dX :<- XX t)))
At each step of the way, we can either turn somewhere else that's around, or keep going up.
And that's it! I haven't given a formal proof of the laws, but it looks to me as if the operations carefully maintain the context correctly as they crawl the structure.
What have we learned?
Differentiability induces notions of thing-in-its-context, inducing a comonadic structure where extract gives you the thing and duplicate explores the context looking for other things to contextualise. If we have the appropriate differential structure for nodes, we can develop differential structure for whole trees.
Oh, and treating each individual arity of type constructor separately is blatantly horrendous. The better way is to work with functors between indexed sets
f :: (i -> *) -> (o -> *)
where we make o different sorts of structure storing i different sorts of element. These are closed under the Jacobian construction
J f :: (i -> *) -> ((o, i) -> *)
where each of the resulting (o, i)-structures is a partial derivative, telling you how to make an i-element-hole in an o-structure. But that's dependently typed fun, for another time.
The Comonad instance for zippers is not
instance (Diff t, Diff (D t)) => Comonad (Zipper t) where
extract = here
duplicate = fmap outOf . inTo
where outOf and inTo come from the Diff instance for Zipper t itself. The above instance violates the Comonad law fmap extract . duplicate == id. Instead it behaves like:
fmap extract . duplicate == \z -> fmap (const (here z)) z
Diff (Zipper t)
The Diff instance for Zipper is provided by identifying them as products and reusing the code for products (below).
-- Zippers are themselves products
toZipper :: (D t :*: Identity) a -> Zipper t a
toZipper (d :*: (Identity h)) = Zipper d h
fromZipper :: Zipper t a -> (D t :*: Identity) a
fromZipper (Zipper d h) = (d :*: (Identity h))
Given an isomorphism between data types, and an isomorphism between their derivatives, we can reuse one type's inTo and outOf for the other.
inToFor' :: (Diff r) =>
(forall a. r a -> t a) ->
(forall a. t a -> r a) ->
(forall a. D r a -> D t a) ->
(forall a. D t a -> D r a) ->
t a -> t (Zipper t a)
inToFor' to from toD fromD = to . fmap (onDiff toD) . inTo . from
outOfFor' :: (Diff r) =>
(forall a. r a -> t a) ->
(forall a. t a -> r a) ->
(forall a. D r a -> D t a) ->
(forall a. D t a -> D r a) ->
Zipper t a -> t a
outOfFor' to from toD fromD = to . outOf . onDiff fromD
For types that are just newTypes for an existing Diff instance, their derivatives are the same type. If we tell the type checker about that type equality D r ~ D t, we can take advantage of that instead of providing an isomorphism for the derivatives.
inToFor :: (Diff r, D r ~ D t) =>
(forall a. r a -> t a) ->
(forall a. t a -> r a) ->
t a -> t (Zipper t a)
inToFor to from = inToFor' to from id id
outOfFor :: (Diff r, D r ~ D t) =>
(forall a. r a -> t a) ->
(forall a. t a -> r a) ->
Zipper t a -> t a
outOfFor to from = outOfFor' to from id id
Equipped with these tools, we can reuse the Diff instance for products to implement Diff (Zipper t)
-- This requires undecidable instances, due to the need to take D (D t)
instance (Diff t, Diff (D t)) => Diff (Zipper t) where
type D (Zipper t) = D ((D t) :*: Identity)
-- inTo :: t a -> t (Zipper t a)
-- inTo :: Zipper t a -> Zipper t (Zipper (Zipper t) a)
inTo = inToFor toZipper fromZipper
-- outOf :: Zipper t a -> t a
-- outOf :: Zipper (Zipper t) a -> Zipper t a
outOf = outOfFor toZipper fromZipper
Boilerplate
In order to actually use the code presented here, we need some language extensions, imports, and a restatement of the proposed problem.
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
import Control.Monad.Identity
import Data.Proxy
import Control.Comonad
data Zipper t a = Zipper { diff :: D t a, here :: a }
onDiff :: (D t a -> D u a) -> Zipper t a -> Zipper u a
onDiff f (Zipper d a) = Zipper (f d) a
deriving instance Diff t => Functor (Zipper t)
deriving instance (Eq (D t a), Eq a) => Eq (Zipper t a)
deriving instance (Show (D t a), Show a) => Show (Zipper t a)
class (Functor t, Functor (D t)) => Diff t where
type D t :: * -> *
inTo :: t a -> t (Zipper t a)
outOf :: Zipper t a -> t a
Products, Sums, and Constants
The Diff (Zipper t) instance relies on implementations of Diff for products :*:, sums :+:, constants Identity, and zero Proxy.
data (:+:) a b x = InL (a x) | InR (b x)
deriving (Eq, Show)
data (:*:) a b x = a x :*: b x
deriving (Eq, Show)
infixl 7 :*:
infixl 6 :+:
deriving instance (Functor a, Functor b) => Functor (a :*: b)
instance (Functor a, Functor b) => Functor (a :+: b) where
fmap f (InL a) = InL . fmap f $ a
fmap f (InR b) = InR . fmap f $ b
instance (Diff a, Diff b) => Diff (a :*: b) where
type D (a :*: b) = D a :*: b :+: a :*: D b
inTo (a :*: b) =
(fmap (onDiff (InL . (:*: b))) . inTo) a :*:
(fmap (onDiff (InR . (a :*:))) . inTo) b
outOf (Zipper (InL (a :*: b)) x) = (:*: b) . outOf . Zipper a $ x
outOf (Zipper (InR (a :*: b)) x) = (a :*:) . outOf . Zipper b $ x
instance (Diff a, Diff b) => Diff (a :+: b) where
type D (a :+: b) = D a :+: D b
inTo (InL a) = InL . fmap (onDiff InL) . inTo $ a
inTo (InR b) = InR . fmap (onDiff InR) . inTo $ b
outOf (Zipper (InL a) x) = InL . outOf . Zipper a $ x
outOf (Zipper (InR a) x) = InR . outOf . Zipper a $ x
instance Diff (Identity) where
type D (Identity) = Proxy
inTo = Identity . (Zipper Proxy) . runIdentity
outOf = Identity . here
instance Diff (Proxy) where
type D (Proxy) = Proxy
inTo = const Proxy
outOf = const Proxy
Bin Example
I posed the Bin example as an isomorphism to a sum of products. We need not only its derivative but its second derivative as well
newtype Bin a = Bin {unBin :: (Bin :*: Identity :*: Bin :+: Identity) a}
deriving (Functor, Eq, Show)
newtype DBin a = DBin {unDBin :: D (Bin :*: Identity :*: Bin :+: Identity) a}
deriving (Functor, Eq, Show)
newtype DDBin a = DDBin {unDDBin :: D (D (Bin :*: Identity :*: Bin :+: Identity)) a}
deriving (Functor, Eq, Show)
instance Diff Bin where
type D Bin = DBin
inTo = inToFor' Bin unBin DBin unDBin
outOf = outOfFor' Bin unBin DBin unDBin
instance Diff DBin where
type D DBin = DDBin
inTo = inToFor' DBin unDBin DDBin unDDBin
outOf = outOfFor' DBin unDBin DDBin unDDBin
The example data from the previous answer is
aTree :: Bin Int
aTree =
(Bin . InL) (
(Bin . InL) (
(Bin . InR) (Identity 2)
:*: (Identity 1) :*:
(Bin . InR) (Identity 3)
)
:*: (Identity 0) :*:
(Bin . InR) (Identity 4)
)
Not the Comonad instance
The Bin example above provides a counter-example to fmap outOf . inTo being the correct implementation of duplicate for Zipper t. In particular, it provides a counter-example to the fmap extract . duplicate = id law:
fmap ( \z -> (fmap extract . duplicate) z == z) . inTo $ aTree
Which evaluates to (notice how it is full of Falses everywhere, any False would be enough to disprove the law)
Bin {unBin = InL ((Bin {unBin = InL ((Bin {unBin = InR (Identity False)} :*: Identity False) :*: Bin {unBin = InR (Identity False)})} :*: Identity False) :*: Bin {unBin = InR (Identity False)})}
inTo aTree is a tree with the same structure as aTree, but everywhere there was a value there is instead a zipper with the value, and the remainder of the tree with all of the original values intact. fmap (fmap extract . duplicate) . inTo $ aTree is also a tree with the same structure as aTree, but everywere there was a value there is instead a zipper with the value, and the remainder of the tree with all of the values replaced with that same value. In other words:
fmap extract . duplicate == \z -> fmap (const (here z)) z
The complete test-suite for all three Comonad laws, extract . duplicate == id, fmap extract . duplicate == id, and duplicate . duplicate == fmap duplicate . duplicate is
main = do
putStrLn "fmap (\\z -> (extract . duplicate) z == z) . inTo $ aTree"
print . fmap ( \z -> (extract . duplicate) z == z) . inTo $ aTree
putStrLn ""
putStrLn "fmap (\\z -> (fmap extract . duplicate) z == z) . inTo $ aTree"
print . fmap ( \z -> (fmap extract . duplicate) z == z) . inTo $ aTree
putStrLn ""
putStrLn "fmap (\\z -> (duplicate . duplicate) z) == (fmap duplicate . duplicate) z) . inTo $ aTree"
print . fmap ( \z -> (duplicate . duplicate) z == (fmap duplicate . duplicate) z) . inTo $ aTree
Given an infinitely differentiable Diff class:
class (Functor t, Functor (D t)) => Diff t where
type D t :: * -> *
up :: Zipper t a -> t a
down :: t a -> t (Zipper t a)
-- Require that types be infinitely differentiable
ddiff :: p t -> Dict (Diff (D t))
around can be written in terms of up and down on the Zipper's diff's derivitive, essentially as
around z#(Zipper d h) = Zipper ctx z
where
ctx = fmap (\z' -> Zipper (up z') (here z')) (down d)
The Zipper t a consists of a D t a and an a. We go down the D t a, getting a D t (Zipper (D t) a) with a zipper in every hole. Those zippers consists of a D (D t) a and the a that was in the hole. We go up each of them, getting a D t a and paring it with the a that was in the hole. A D t a and an a make a Zipper t a, giving us a D t (Zipper t a), which is the context needed for a Zipper t (Zipper t a).
The Comonad instance is then simply
instance Diff t => Comonad (Zipper t) where
extract = here
duplicate = around
Capturing the derivative's Diff dictionary requires some additional plumbing, which can be done with Data.Constraint or in terms of the method presented in a related answer
around :: Diff t => Zipper t a -> Zipper t (Zipper t a)
around z = Zipper (withDict d' (fmap (\z' -> Zipper (up z') (here z')) (down (diff z)))) z
where
d' = ddiff . p' $ z
p' :: Zipper t x -> Proxy t
p' = const Proxy
I have not seen any mention of binary numerals in lambda calculus. Church numerals are unary system.
I had asked a question of how to do this in Haskell here: How to implement Binary numbers in Haskell
But even after I saw and understood that answer, I could not understand how to do this in pure untyped lambda calculus.
So here is my question:
Are binary numerals defined in untyped lambda calculus and have the successor and predecessor functions also been defined for them?
Church encoding of a recursive data type is precisely its fold (catamorphism). Before we venture into the messy and not-very-readable world of Church encoded data types, we'll implement these two functions on the representation given in the previous answer. And because we'd like to transfer then easily to the Church encoded variants, we'll have to do both via fold.
Here's the representation from the previous answer (I picked the one which will be easier to work with) and its catamorphism:
data Bin = LSB | Zero Bin | One Bin
foldBin :: (r -> r) -- ^ Zero case.
-> (r -> r) -- ^ One case.
-> r -- ^ LSB case.
-> Bin
-> r
foldBin z o l = go
where
go LSB = l
go (Zero n) = z (go n)
go (One n) = o (go n)
The suc function adds one to the least significant bit and keeps propagating the carries we get. Once the carry is added to Zero (and we get One), we can stop propagating. If we get to the most significant bit and still have a carry to propagate, we'll add new most significant bit (this is the apLast helper function):
suc :: Bin -> Bin
suc = apLast . foldBin
(\(c, r) -> if c
then (False, One r)
else (False, Zero r))
(\(c, r) -> if c
then (True, Zero r)
else (False, One r))
(True, LSB)
where
apLast (True, r) = One r
apLast (False, r) = r
The pre function is very similar, except the Boolean now tells us when to stop propagating the -1:
pre :: Bin -> Bin
pre = removeZeros . snd . foldBin
(\(c, r) -> if c
then (True, One r)
else (False, Zero r))
(\(c, r) -> if c
then (False, Zero r)
else (False, One r))
(True, LSB)
This might produce a number with leading zero bits, we can chop them off quite easily. full is the whole number at any given time, part is full without any leading zeros.
removeZeros :: Bin -> Bin
removeZeros = snd . foldBin
(\(full, part) -> (Zero full, part))
(\(full, part) -> (One full, One full))
(LSB, LSB)
Now, we have to figure out the Church encoding. We'll need Church encoded Booleans and Pairs before we start. Note the following code needs RankNTypes extension.
newtype BoolC = BoolC { runBool :: forall r. r -> r -> r }
true :: BoolC
true = BoolC $ \t _ -> t
false :: BoolC
false = BoolC $ \_ f -> f
if' :: BoolC -> a -> a -> a
if' (BoolC f) x y = f x y
newtype PairC a b = PairC { runPair :: forall r. (a -> b -> r) -> r }
pair :: a -> b -> PairC a b
pair a b = PairC $ \f -> f a b
fst' :: PairC a b -> a
fst' (PairC f) = f $ \a _ -> a
snd' :: PairC a b -> b
snd' (PairC f) = f $ \_ b -> b
Now, at the beginning I said that Church encoding of a data type is its fold. Bin has the following fold:
foldBin :: (r -> r) -- ^ Zero case.
-> (r -> r) -- ^ One case.
-> r -- ^ LSB case.
-> Bin
-> r
Given a b :: Bin argument, once we apply foldBin to it, we get a precise representation of b in terms of a fold. Let's write a separate data type to keep things tidy:
newtype BinC = BinC { runBin :: forall r. (r -> r) -> (r -> r) -> r -> r }
Here you can clearly see it's the type of foldBin without the Bin argument. Now, few helper functions:
lsb :: BinC
lsb = BinC $ \_ _ l -> l
zero :: BinC -> BinC
zero (BinC f) = BinC $ \z o l -> z (f z o l)
one :: BinC -> BinC
one (BinC f) = BinC $ \z o l -> o (f z o l)
-- Just for convenience.
foldBinC :: (r -> r) -> (r -> r) -> r -> BinC -> r
foldBinC z o l (BinC f) = f z o l
We can now rewrite the previous definitions in terms of BinC nearly with 1:1 correspondence:
suc' :: BinC -> BinC
suc' = apLast . foldBinC
(\f -> runPair f $ \c r -> if' c
(pair false (one r))
(pair false (zero r)))
(\f -> runPair f $ \c r -> if' c
(pair true (zero r))
(pair false (one r)))
(pair true lsb)
where
apLast f = runPair f $ \c r -> if' c
(one r)
r
pre' :: BinC -> BinC
pre' = removeZeros' . snd' . foldBinC
(\f -> runPair f $ \c r -> if' c
(pair true (one r))
(pair false (zero r)))
(\f -> runPair f $ \c r -> if' c
(pair false (zero r))
(pair false (one r)))
(pair true lsb)
removeZeros' :: BinC -> BinC
removeZeros' = snd' . foldBinC
(\f -> runPair f $ \full part -> pair (zero full) part)
(\f -> runPair f $ \full part -> pair (one full) (one full))
(pair lsb lsb)
The only significant difference is that we can't pattern match on pairs, so we have to use:
runPair f $ \a b -> expr
instead of:
case f of
(a, b) -> expr
Here are the conversion functions and a few tests:
toBinC :: Bin -> BinC
toBinC = foldBin zero one lsb
toBin :: BinC -> Bin
toBin (BinC f) = f Zero One LSB
numbers :: [BinC]
numbers = take 100 $ iterate suc' lsb
-- [0 .. 99]
test1 :: [Int]
test1 = map (toInt . toBin) numbers
-- 0:[0 .. 98]
test2 :: [Int]
test2 = map (toInt . toBin . pre') numbers
-- replicate 100 0
test3 :: [Int]
test3 = map (toInt . toBin) . zipWith ($) (iterate (pre' .) id) $ numbers
Here's the code written in untyped lambda calculus:
lsb = λ _ _ l. l
zero = λ f. λ z o l. z (f z o l)
one = λ f. λ z o l. o (f z o l)
foldBinC = λ z o l f. f z o l
true = λ t _. t
false = λ _ f. f
if' = λ f x y. f x y
pair = λ a b f. f a b
fst' = λ f. f λ a _. a
snd' = λ f. f λ _ b. b
(∘) = λ f g x. f (g x)
removeZeros' = snd' ∘ foldBinC
(λ f. f λ full part. pair (zero full) part)
(λ f. f λ full part. pair (one full) (one full))
(pair lsb lsb)
apLast = λ f. f λ c r. if' c (one r) r
suc' = apLast ∘ foldBinC
(λ f. f λ c r. if' c
(pair false (one r))
(pair false (zero r)))
(λ f. f λ c r. if' c
(pair true (zero r))
(pair false (one r)))
(pair true lsb)
pre' = removeZeros' ∘ snd' ∘ foldBinC
(λ f. f λ c r. if' c
(pair true (one r))
(pair false (zero r)))
(λ f. f λ c r. if' c
(pair false (zero r))
(pair false (one r)))
(pair true lsb)
The following paper answers your question. As you can see, there have been investigated
several ways to encode binary numerals in lambda calculus.
An Investigation of Compact and Efficient Number Representations in
the Pure Lambda Calculus
Torben AE. Mogensen
http://link.springer.com/content/pdf/10.1007%2F3-540-45575-2_20
Abstract. We argue that a compact right-associated binary number
representation gives simpler operators and better efficiency than the
left-associated binary number representation proposed by den Hoed and
investigated by Goldberg. This representation is then generalised to
higher number-bases and it is argued that bases between 3 and 5 can
give higher efficiency than binary representation.