I coded the simplest examples from

• Defunctionalization at work. O Danvy, LR Nielsen. PPDP 2001.

in literate Haskell for the audience, and also showed off QuickCheck a little to make sure the translation was correct (finding one error, if I recall).

This blog post is a merging of my talk outline and new stuff that came up live. Try loading it up in GHCi or Haskell-mode and running the examples and QuickCheck properties.

> {-# LANGUAGE RankNTypes #-}

> import Prelude hiding (reverse)
> import Control.Monad
> import Control.Monad.Cont
> import Test.QuickCheck

Broadly, defunctionalization is transforming a program to eliminate higher-order functions. Rather than focus on its use for compilation (see this H Cejtin, S Jagannathan, S Weeks paper on MLTon) or analyses (see Firstify from N Mitchell and C Runciman). I wanted to emphasize its use in understanding your own program, along the lines of Wand’s Continuation-Based Program Transformation Strategies (JACM 1980).

Here is the first example from Danvy.

> aux1 :: (Int -> Int) -> Int
> aux1 f = f 1 + f 10
>
> main1 x y b = (aux1 (\z -> x + z)) * 
>               (aux1 (\z -> if b then y + z else y - z))

Defunctionalization replaces all the first-class functions with an explicit data structure Lam1 and a global apply1 function, essentially embedding a mini-interpreter for just those lambda terms occurring in the program.

> data Lam1 = Lam1A Int      -- (Lam1A x)   ~ (\z -> x + z)
>           | Lam1B Int Bool -- (Lam1B y b) ~ (\z -> if b then y + z else y - z)
>
> apply1 :: Lam1 -> Int -> Int
> apply1 (Lam1A x)   z = x + z
> apply1 (Lam1B y b) z = if b then y + z else y - z
>
> aux1defun :: Lam1 -> Int
> aux1defun f = (apply1 f 1) + (apply1 f 10)
>
> main1defun x y b = (aux1defun (Lam1A x)) *
>                    (aux1defun (Lam1B y b))

Is it correct? Ask quickcheck:

> prop1 x y b = (main1 x y b == main1defun x y b)

*Main> quickCheck prop1
+++ OK, passed 100 tests.

Next example: flattening a binary tree

> data BinaryTree a = Leaf a
>                   | Node (BinaryTree a) (BinaryTree a)

First, there is the straightforward, inefficient version of flatten

> flatten (Leaf x) = [x]
> flatten (Node t1 t2) = (flatten t1) ++ (flatten t2)

We can represent our output with difference lists offering O(1) append.

> flatten' t = walk t []
>   where walk (Leaf x)     = (x:)
>         walk (Node t1 t2) = (walk t1) . (walk t2)

And now that we’ve introduced a bunch of first-class functions, let’s see what happens when we defunctionalize them.

> data LamBTree a = LamBTreeA a -- (x:)
>                 | LamBTreeB (LamBTree a) (LamBTree a) -- (u . v)
>
> applyBTree (LamBTreeA x)   l = x:l
> applyBTree (LamBTreeB u v) l = applyBTree u (applyBTree v l)
>
> flatten_defun t = applyBTree (walk t) []
>   where walk (Leaf x)     = LamBTreeA x
>         walk (Node t1 t2) = LamBTreeB (walk t1) (walk t2)

Note how LamBTree looks just like the definition of BinaryTree, because it is a catamorphism, hence a hylomorphism, i.e. a recursive function with a call tree that looks like a BinaryTree or whatever structure you are hylo’ing over. (See Sorting morphisms for a beautiful examples of using this to understand your program (L Augusteijn. AFP 1998)). So walk is pretty much the identity function on trees, and then applyBTree is a flatten function with an accumulating parameter. Ignoring the intermediate structure, then we see defunctionalization as a way to derive accumulating parameters.

> prop_flatten :: BinaryTree Int -> Bool
> prop_flatten t = (flatten_defun t == flatten t)

*Main> quickCheck prop_flatten
OK, passed 100 tests

Defunctionalization as an inverse to church encoding

This was possibly my favorite part of Danvy’s paper, but I unfortunately had to elide it from my talk as being slightly too esoteric for the mixed crowd.

Let us suppose that tuples were not built in to Haskell but we needed to make them ourselves. The data type and destructors would look like this:

> data MyPair a b = P a b 
>                 deriving (Eq,Show)
>
> myPair x y    = P x y
> myFst (P x y) = x
> mySnd (P x y) = y

And we can ask Quickcheck to test extensionality.

> prop_pair :: MyPair Int Int -> Bool
> prop_pair p = (p == myPair (myFst p) (mySnd p))

*Main> quickCheck prop_pair
+++ OK, passed 100 tests.

So, if you recall whatever lambda-calculus course you may have taken, we can represent them with only functions. I like having rank-N type available for this.

> type ChurchPair a b = (forall c . a -> b -> (a -> b -> c) -> c)

> churchPair x y = (\operation -> operation x y)
> churchFst  p   = p (\x y -> x)
> churchSnd  p   = p (\x y -> y)

Rather than make an Arbitrary instance, I’ll settle for reduction rules in this case.

> prop_churchPair :: Int -> Int -> Bool
> prop_churchPair x y = (x == churchFst (churchPair x y)) &&
>                       (y == churchSnd (churchPair x y))

*Main> quickCheck prop_churchPair
+++ OK, passed 100 tests.

But now I’ve introduced a bunch of higher-order functions, so we just have to see how they defunctionalize!

> data LamSelector = LamFst | LamSnd
> applySelector (LamFst) x y = x
> applySelector (LamSnd) x y = y
>
> data LamPair a b = LamPair a b
> applyPair (LamPair x y) operation = applySelector operation x y
>
> defunPair x y = (LamPair x y)
> defunFst  p   = applyPair p LamFst
> defunSnd  p   = applyPair p LamSnd

You can see that this just reproduces the original, modulo inlining!

Now let’s church-encode BinaryTree as its own fold (or catamorphism, if you like). So we have something to defunctionalize, let’s write churchDepth to calculate the depth of the tree.

> type ChurchTree a = forall c. (a -> c) -> (c -> c -> c) -> c

> churchLeaf x     = \onLeaf onNode -> onLeaf x
> churchNode t1 t2 = \onLeaf onNode -> onNode (t1 onLeaf onNode) (t2 onLeaf onNode)
>
> churchFold onLeaf onNode t = t onLeaf onNode

> churchDepth t = t (\x -> 0) (\d1 d2 -> 1 + (d1 `max` d2))

Acknowledging that the church encoding is just the fold, we can defunctionalize the fold over any functor to recover the data type. Anyhow…

> data LamLeaf = LamLeaf -- onLeaf
> applyLeaf LamLeaf x = 0
>
> data LamNode = LamNode -- onNode
> applyNode LamNode d1 d2 = 1 + (d1 `max` d2)
>
> data LamTree a = LamTreeLeaf a   -- churchLeaf
>                | LamTreeNode (LamTree a) (LamTree a) -- churchNode
>
> applyTree (LamTreeLeaf x)     onLeaf onNode = applyLeaf onLeaf x
> applyTree (LamTreeNode t1 t2) onLeaf onNode = 
>   applyNode onNode (applyTree t1 onLeaf onNode)
>                    (applyTree t2 onLeaf onNode)
> depth_defun t = applyTree t LamLeaf LamNode

applyTree is just fold over a tree, as promised, and we’ve recovered the tree data structure.

Defunctionalize your continuation

Suppose you have a first-order (boring!) program. You can’t have any fun until you find a way to introduce some first-class functions. A classic way to introduce a gratuitous number is to convert your code into continuation-passing style. Let’s try it.

This is Danvy’s ‘s example of a parser to recognize the language . It is written with an auxiliary function in the Maybe monad to simulate throwing an exception as soon as we can reject the string.

> recognize :: [Int] -> Bool
> recognize xs = case walk xs of Just [] -> True
>                                _       -> False 
>   where 
>     walk :: [Int] -> Maybe [Int]
>     walk (0:xs') = do remaining <- walk xs'
>                       case remaining of (1:ys) -> Just ys
>                                         _      -> Nothing
>     walk xs = Just xs -- otherwise

The audience insisted that I test this, because it is a bit of a weird way to write a trivial function.

> prop_recognize1 n = recognize (take n (repeat 0) ++ take n (repeat 1))
> prop_recognize2 m n = (m >= 0 && n >= 1 && m /= n) 
>    ==> (not (recognize (take m (repeat 0) ++ take n (repeat 1))))

*Main> quickCheck prop_recognize1
+++ OK, passed 100 tests.
*Main> quickCheck prop_recognize2
+++ OK, passed 100 tests.

Now if we CPS it, we no longer need the Maybe because we can just discard the continuation and return False.

> recognize' :: [Int] -> Bool
> recognize' xs = walk xs (\xs' -> [] == xs')
>   where
>     walk :: [Int] -> ([Int] -> Bool) -> Bool
>     walk (0:xs') k = walk xs' (\rem -> case rem of (1:ys) -> k ys
>                                                    _      -> False)
>     walk xs      k = k xs -- otherwise

And defunctionalizing it

> data Continuation = ContToplevel     -- (\xs' -> null xs')
>                   | ContRecurse Continuation -- (\remaining -> ... )
>
> applyCont ContToplevel    l = (l==[])
> applyCont (ContRecurse k) l = case l of (1:ys) -> applyCont k ys
>                                         _      -> False
>
> recognize'' xs = walk xs ContToplevel
>   where
>     walk (0:xs') k = walk xs' (ContRecurse k)
>     walk xs      k = applyCont k xs

But now we can look and see that the continuation data structure is just implementing natural numbers, so we replace it by an Int.

> applyNumCont 0 []     = True
> applyNumCont k (1:xs) = applyNumCont (k-1) xs
> applyNumCont _ _      = False

> recognize_final xs = walk xs 0
>   where walk (0:xs') k = walk xs' (k+1)
>         walk xs      k = k xs

We get the program we should have written in the first place.

I didn’t get to the rest of this in my talk, and anyhow it is most interesting to people who play with operational semantics a lot. This last bit is from Danvy’s paper On Evaluation Contexts, Continuations, and The Rest of Computation from the continuation workshop in 2004.

We have a simple arithmetic language, and two ways of giving it a semantics: We can either reduce the expression a single small step, using reduceAllTheWay to normalize it, or we can eval the expression directly to a result.

> data Exp = Value Int
>          | Add Exp Exp
>
> reduce :: Exp -> Exp
> reduce (Add (Value v1) (Value v2)) = Value (v1 + v2)
> reduce (Add (Value v1) e2        ) = Add (Value v1) (reduce e2)
> reduce (Add e1         e2        ) = Add (reduce e1) e2
>
> reduceAllTheWay :: Exp -> Int
> reduceAllTheWay (Value v) = v
> reduceAllTheWay e = reduceAllTheWay (reduce e)
>
> eval :: Exp -> Int
> eval (Value v)   = v
> eval (Add e1 e2) = (eval e1) + (eval e2)

Now we CPS both of them

> reduceCPS :: Exp -> (Exp -> a) -> a
> reduceCPS (Add (Value v1) (Value v2)) k = k (Value (v1 + v2))
> reduceCPS (Add (Value v1) e2        ) k = reduceCPS e2 (\e -> k (Add (Value v1) e))
> reduceCPS (Add e1         e2        ) k = reduceCPS e1 (\e -> k (Add e e2))
>
> reduceAllTheWayCPS :: Exp -> (Int -> a) -> a
> reduceAllTheWayCPS (Value v) k = k v
> reduceAllTheWayCPS e         k = reduceCPS e (flip reduceAllTheWayCPS k)

> evalCPS :: Exp -> (Int -> a) -> a
> evalCPS (Value v)   k = k v
> evalCPS (Add e1 e2) k = evalCPS e1 (\v1 -> evalCPS e2 (\v2 -> k (v1 + v2)))

CPS code is easier to read when I write it like this

> evalCPS' :: Exp -> (Int -> a) -> a
> evalCPS' (Value v)   k = k v
> evalCPS' (Add e1 e2) k = evalCPS e1 (\v1 ->
>                          evalCPS e2 (\v2 ->
>                          k (v1+v2)  ))

and I might as well admit that Haskell already has this in the bag

> evalCPS'' :: Exp -> Cont a Int
> evalCPS'' (Value v)   = return v
> evalCPS'' (Add e1 e2) = do v1 <- evalCPS'' e1
>                            v2 <- evalCPS'' e2
>                            return (v1 + v2)

Now we defunctionalize both semantics

> data ContReduce = ContReduce  -- (flip reduceAllTheWay)
>                 | ContAddV1 Exp ContReduce -- (\e -> Add (Value v1) e)
>                 | ContAddE2 ContReduce Exp -- (\e -> Add e e2)
>
> applyContReduce :: ContReduce -> Exp -> Exp
> applyContReduce ContReduce e = e
> applyContReduce (ContAddV1 v1 k) e = applyContReduce k (Add v1 e)
> applyContReduce (ContAddE2 k e2) e = applyContReduce k (Add e e2)
>
> reduceCPSdefun :: Exp -> ContReduce -> Exp
> reduceCPSdefun (Add (Value v1) (Value v2)) k = applyContReduce k (Value (v1 + v2))
> reduceCPSdefun (Add (Value v1) e2        ) k = reduceCPSdefun e2 (ContAddV1 (Value v1) k)
> reduceCPSdefun (Add e1         e2        ) k = reduceCPSdefun e1 (ContAddE2 k e2)

The data type ContReduce is the now-common notion of an “evaluation context” which some researchers prefer because it separates the important rules about how terms are reduced from the rules that just tell you where in a term reduction happens.

Next…

> data ContEval = ContEval -- toplevel
>               | ContE1 ContEval Exp
>               | ContE2 Int ContEval
>
> applyContEval :: ContEval -> Int -> Int
> applyContEval (ContEval) v = v
> applyContEval (ContE1 k e2) v1 = evalCPSdefun e2 (ContE2 v1 k) 
> applyContEval (ContE2 v1 k) v2 = applyContEval k (v1 + v2)
>
> evalCPSdefun (Value v)   k = applyContEval k v
> evalCPSdefun (Add e1 e2) k = evalCPSdefun e1 (ContE1 k e2)

Hey it looks like almost the same thing! The difference is in how we interpret the data structure. In the previous case, applyContReduce just used it for navigation. In this case, applyContEval calls back into evalCPSdefun to keep the evaluation rolling.

If, like myself, you liked this because you feel there is important and interesting structure underlying operational semantics that is hidden by its many superficial forms, then you’ll probably like this additional reading:

• Modularity and implementation of mathematical operational semantics. M Jaskelioff, N Ghani, G Hutton. MSFP 2008.
• Fold and unfold for program semantics. G Hutton. ICFP 1998.

And I leave you with my hidden instances of arbitrary…

> instance Arbitrary a => Arbitrary (BinaryTree a) where
>   arbitrary = oneof [liftM Leaf arbitrary, liftM2 Node arbitrary arbitrary]

> instance (Arbitrary a, Arbitrary b) => Arbitrary (MyPair a b) where
>   arbitrary = liftM2 myPair arbitrary arbitrary

But having just finished a post using open recursion, it immediately cried out to me that open-recursive functions already have some debugging hooks for tracing/breakpoints/etc. Naturally, some complications arose, and I got to try out some other cool ideas from the literature.

To combine the State in which I store the memoization table with the IO I use for debugging, I use

• Composing monads using coproducts. C Lüth, N Ghani. ICFP 2002.

And then to reduce the plumbing overhead I use

• Data Types a la Carte. W Swierstra. Accepted to JFP.

This post is, as usual, a literate Haskell file so load it up in GHCi or Emacs Haskell-mode and see what happens.

> {-# LANGUAGE TypeOperators,ScopedTypeVariables,PatternSignatures,RankNTypes,FlexibleInstances,UndecidableInstances,OverlappingInstances,IncoherentInstances,MultiParamTypeClasses,FlexibleContexts #-}

> import qualified Data.Map as M
> import Control.Monad.State hiding (fix)

Here’s the previous example of a monadified, open-recursion fibonacci,

> type Gen a = (a -> a)
>
> fix :: Gen a -> a
> fix f = f (fix f)
>
> gmFib :: Monad m => Gen (Int -> m Int)
> gmFib recurse 0     = return 0
> gmFib recurse 1     = return 1
> gmFib recurse n = do a <- recurse (n-1)
>                      b <- recurse (n-2)
>                      return (a + b)

… and the memoization mixin

> type Memoized a b = State (M.Map a b)
>
> memoize :: (Ord a) => Gen (a -> Memoized a b b)
> memoize self x = do memo <- check x
>                     case memo of
>                               Just y  -> return y
>                               Nothing -> do y <- self x
>                                             store x y
>                                             return y
>
> check :: Ord a => a -> Memoized a b (Maybe b)
> check x = do memotable <- get
>              return (M.lookup x memotable)
>
> store :: Ord a => a -> b -> Memoized a b ()
> store x y = do memotable <- get
>                put (M.insert x y memotable)
>
> runMemo :: Ord a => Memoized a b c -> c
> runMemo m = evalState m M.empty
>
> fibMemo n = runMemo $ fix (gmFib . memoize) n

So let us begin debugging. The first thing that comes to mind is viewing the results of each recursive call.

> inspect :: (Show a, Show b) => String -> Gen (a -> IO b)
> inspect name self arg = do result <- self arg
>                            putStrLn $ name ++ " " ++ show arg 
>                                       ++ " = " ++ show result
>                            return result

> fibInspect n = fix (gmFib . inspect "fib") n

Trying it out…

*Main> fibInspect 5
fib 1 = 1
fib 0 = 0
fib 1 = 1
fib 2 = 1
fib 3 = 2
fib 0 = 0
fib 1 = 1
fib 2 = 1
fib 1 = 1
fib 0 = 0
fib 1 = 1
fib 2 = 1
fib 3 = 2
fib 4 = 3
5

That was easy! Now when I also mix in the memoization I should see a lot of those recursive calls drop away. But I cannot simply write fix (gmFib . inspect "fib" . memoize) because mixing in inspect fixes the underlying monad to IO, while mixing in memoize fixes it to Memoized Int Int. I need to run this computation in a monad that supports the operations of both IO and State. Well, in category theory terms, the smallest “thing” that contains two other “things” is their coproduct, so this is exactly what the Luth-Ghani paper mentioned above is for!

I’ll be inlining and de-generalizing a bunch of the (beautiful) code from the paper to get the point across quickly. The linked papers and other references are highly recommended for a deeper understanding.

> data Plus m1 m2 a = T1 (m1 (Plus m1 m2 a))
>                   | T2 (m2 (Plus m1 m2 a))
>                   | Var a

This data type is not exactly the coproduct, but rather a data type that can represent it, like using a list to represent a set – there are multiple lists that represent the same set, but if you respect the abstraction you are OK. Most of the ways of processing this data structure can be written in Haskell using only Functor instances for the underlying structure, but to make sure we only use it in the appropriate places I’ve just made the stronger requirement that m1 and m2 be Monads everywhere. But I still want fmap so I turn on undecidable instances and add the following.

> instance Monad m => Functor m where
>     fmap f m = m >>= (return . f)

Now you might ask why I’m not using monad transformers. Four reasons come to mind:

1. I wanted to try out the contents of this paper.
2. The coproduct is defined for two arbitrary monads, without writing a special version of either that “holds” another inside.
3. The coproduct can have the two “layers” interleaved in more arbitrary ways
4. The coproduct is theoretically simpler and more fundamental.

This is now one of those structures that is so abstract that you can figure out how to process it just by writing the only function of the proper type.

> fold :: (Monad f1, Monad f2) => -- fold by cases over Plus
>             (a -> b)     -> -- variables
>             (f1 b -> b)  -> -- bits from f1 
>             (f2 b -> b)  -> -- bits from f2
>             Plus f1 f2 a -> -- the input
>             b -- Yay!

> fold e f1 f2 (Var x) = e x
> fold e f1 f2 (T1 t) = f1 (fmap (fold e f1 f2) t)
> fold e f1 f2 (T2 t) = f2 (fmap (fold e f1 f2) t)

> instance (Monad m1, Monad m2) => Monad (Plus m1 m2) where
>     return x = Var x
>     m >>= f = fold f T1 T2 m

The functor instance induced by the monad would look like this

 instance (Monad m1, Monad m2) => Functor (Plus m1 m2) where
     fmap f = fold (Var . f) T1 T2

Here fmap traverse the shapes of m1 and m2 and applies f where it finds a Var constructor. To get a better picture, try combining the bodies of fold and fmap:

 fmap f (Var x) = Var (f x)
 fmap f (T1 t) = T1 (fmap (fmap f) t)
 fmap f (T2 t) = T2 (fmap (fmap f) t)

And then we want to be able to inject things from m1 and m2 into the coproduct.

> inl :: Monad m1 => m1 a -> Plus m1 m2 a
> inl = T1 . fmap Var

> inr :: Monad m2 => m2 a -> Plus m1 m2 a
> inr = T2 . fmap Var

> liftL :: Monad m1 => (a -> m1 b) -> (a -> Plus m1 m2 b)
> liftL f = inl . f 

> liftR :: Monad m2 => (a -> m2 b) -> (a -> Plus m1 m2 b)
> liftR f = inr . f 

At this point I’ve got the machinery to combine the IO and Memoized monads as desired, but my code would be full of inr, inl, liftL and liftR. This is where we bring in the Swierstra pearl (used and discussed all over place: See Modularity and implementation of mathematical operational semantics, Phil Wadler’s blog, a thread on haskell-cafe, and of course Lambda the Ultimate)

Again, I’m specializing all the types to Monad but they were presented for more general functors.

> class (Monad smaller, Monad larger) => Included smaller larger where
>     inject :: smaller a -> larger a

> instance Monad f => Included f f where
>     inject = id

> instance (Monad f, Monad g) => Included f (Plus f g) where
>     inject = inl

> instance (Monad f, Monad g) => Included g (Plus f g) where
>     inject = inr

Also, since for this example I don’t use nested coproducts I’m leaving out this instance, which opens up a can of worms:

 instance (Monad f, Monad g, Monad h, Included f h) => Included f (Plus g h) where
    inject = inr . inject

Definitely see the links above if you are curious about how this plays out.

Back to the debugging story. Here is how we modify inspect and memoize.

> inspectM :: (Show a, Show b, Monad m, Included IO m) => String -> Gen (a -> m b)
> inspectM name self arg = do result <- self arg
>                             inject $ putStrLn $ name ++ " " ++ show arg 
>                                                 ++ " = " ++ show result
>                             return result

> memoizeM :: (Ord a, Monad m, Included (Memoized a b) m) => Gen (a -> m b)
> memoizeM self x = do memo <- inject $ check x
>                      case memo of
>                               Just y  -> return y
>                               Nothing -> do y <- self x
>                                             inject $ store x y
>                                             return y

> mFibTraceMemo :: Int -> Plus (Memoized Int Int) IO Int
> mFibTraceMemo = fix (gmFib . memoizeM . inspectM "fib")

But wait, how do I run this thing? It has IO and Memoized layers all mixed up! Intuitively, I’m sure you believe that if I start with an empty memo table and start running an IO that has some memoized bits in it, I can thread the memo table throughout.

In classic Haskell style, we can separate the “threading” concern from the “running” by writing an untangling function of type Plus m1 m2 a -> m1 (m2 a). But in fact, we don’t even need to do that much work. Discussed in the Luth-Ghani paper is the idea of a distributivity law, which in hacking terms means a function that just does one bit of the untangling, specifically a single “untwist” of type forall a. m2 (m1 a) -> (m1 (m2 a)). If we can write an untwist function, then a fold over the monad coproduct does the rest of the untangling.

Let us make this concrete for IO and State.

> ioState :: IO (State s c) -> State s (IO c)
> ioState io = State $ \s -> ((do st <- io
>                                 return (evalState st s)), s)

This function essentially corresponds to the MonadIO instance of the StateT monad transformer. More generally, Luth-Ghani show that when you can write one of these distributivity laws, then using the coproduct is isomorphic to using monad transformers, so I already knew this part would work out

Here is how we fold an “untwist” into an “untangle”

> distribL :: (Monad m1, Monad m2) => 
>               (forall b. m2 (m1 b) -> m1 (m2 b)) -> -- A flick of the wrist
>               Plus m1 m2 a ->                       -- A tangled skein
>               m1 (m2 a)                             -- A silken thread
> distribL untwist = fold (return . return) join (fmap join . untwist)

It may be easier to see it written out in pointful style.

distribL untwist (Var x) = return (return x)
distribL untwist (T1 t)  = join (fmap (distribL untwist) t)
distribL untwist (T2 t)  = fmap join (untwist (fmap (distribL untwist) t))

Another way to convince yourself that your function is correct is to think… how many functions even have the necessary type? Not very many, since you need the higher-rank type for the parameter for this guy to even type check! When dealing with very abstract functions, you often gain enough via parametericity to make up for the loss in intuitive clarity. (Sounds like a Grothendieck quote that I can’t Google up at the moment – something about piling layers and layers of abstraction on a problem until it unravels itself before your eyes)

> runMemoIO :: Plus (Memoized a b) IO b -> IO b
> runMemoIO result = evalState (distribL ioState result) M.empty

> fibTraceMemo = runMemoIO . mFibTraceMemo

Now we can visually confirm that it is not repeating any computation:

*Main> fibTraceMemo 10
fib 1 = 1
fib 0 = 0
fib 2 = 1
fib 3 = 2
fib 4 = 3
fib 5 = 5
fib 6 = 8
fib 7 = 13
fib 8 = 21
fib 9 = 34
55

Note that this is a little sensitive to explicit type signatures again. When I inlined the body of mFibTraceMemo I needed to ascribe a type to memoizeM like so:

 memoizeM' :: Gen (Int -> Plus (Memoized Int Int) IO Int) = memoizeM

Now that the vamp is playing, let’s riff on it. How about catching calls to negative numbers?

> guardedBail :: forall a b m. (Monad m, Included (Memoized a b) m) => 
>                              (a -> Bool) -> Gen (a -> m b)
> guardedBail pred self arg = if pred arg then error "Forbidden!" else self arg

Or suppose we have memory consumption concerns, and we want to watch the size of the memo table?

> printSize :: forall a b m. 
>              (Monad m, Included (Memoized a b) m, Included IO m) => 
>              Gen (a -> m b)
> printSize self arg = do result <- self arg
>                         size <- inject $ getSize
>                         inject $ putStrLn $ "Memo table size: " ++ show size
>                         return result
>     where getSize :: Memoized a b Int = do memotable <- get
>                                            return $ M.size memotable

When I try to separate getSize as an independent function I get type class error message pain, so I left it in the where clause.

> mFibSizeTrace :: Int -> Plus (Memoized Int Int) IO Int
> mFibSizeTrace = fix (gmFib . memoizeM . printSize 
>                      . inspectM "fib" . guardedBail (<0)) 

> fibSizeTrace n = runMemoIO $ mFibSizeTrace n

And running it…

*Main> fibSizeTrace 10
fib 1 = 1
Memo table size: 0
fib 0 = 0
Memo table size: 1
fib 2 = 1
Memo table size: 2
fib 3 = 2
Memo table size: 3
fib 4 = 3
Memo table size: 4
fib 5 = 5
Memo table size: 5
fib 6 = 8
Memo table size: 6
fib 7 = 13
Memo table size: 7
fib 8 = 21
Memo table size: 8
fib 9 = 34
Memo table size: 9
55
*Main> fibSizeTrace (-1)
*** Exception: Forbidden!

Of course, we are storing all these past results that don’t matter anymore. I can certainly delete the entry that is three less than the current argument.

> clearPrev :: forall b m. 
>              (Monad m, Included (Memoized Int b) m) => Gen (Int -> m b)
> clearPrev self arg = do inject $ clear (arg - 3)
>                         self arg
>     where clear :: Int -> Memoized Int b ()
>           clear key = do memotable <- get
>                          put (M.delete key memotable)

> mFibFinal :: Int -> Plus (Memoized Int Int) IO Int
> mFibFinal = fix (gmFib . clearPrev . memoizeM . inspectM "fib" 
>                  . guardedBail (<0) . printSize)

> fibFinal n = runMemoIO $ mFibFinal n

Running it…

*Main> fibFinal 15
Memo table size: 0
fib 1 = 1
Memo table size: 1
fib 0 = 0
Memo table size: 2
fib 2 = 1
Memo table size: 3
fib 3 = 2
Memo table size: 4
fib 4 = 3
Memo table size: 4
fib 5 = 5
Memo table size: 4
fib 6 = 8
Memo table size: 4
fib 7 = 13
Memo table size: 4
fib 8 = 21
Memo table size: 4
fib 9 = 34
Memo table size: 4
fib 10 = 55
Memo table size: 4
fib 11 = 89
Memo table size: 4
fib 12 = 144
Memo table size: 4
fib 13 = 233
Memo table size: 4
fib 14 = 377
610

I have a vague feeling that a real debugging package could be made from this approach, but if not at least today was some fun.

• Automatic Verification of Concurrent Systems Using Temporal Logic Specifications by EM Clarke, EM Emerson, AP Sistla.

The “efficient algorithm” presented in the paper is, upon reflection, merely a memoized traversal of the state machine, so I combined it with a modified version of

• Monadic Memoization Mixins by D Brown, WR Cook

which actually eliminated an auxilliary function from the algorithm, yielding an efficiently-executable 20-line Haskell specification of the meaning of CTL (which is probably clearer than my English prose explanation, and certainly more fun to play with).

This post is, as usual, literate Haskell. Load it up in GHCi, Haskell-mode, or compile it with ghc --make and try it out. Maybe you can convince my state space exploration not to terminate

> {-# LANGUAGE TypeOperators,ScopedTypeVariables,PatternSignatures #-}

> import qualified Data.Map as M
> import qualified Data.Set as S
> import Data.List
> import Control.Monad 
> import Control.Monad.State hiding (fix)

Memoization Mixins

Here is the easy example from the Brown-Cook paper, before getting on to model checking.

To enable functional mixins, we write our functions using open recursion. Instead of a function of type a -> b we write one of type Gen (a -> b) and then later “tie the knot” with fix (reproduced here for reference)

> type Gen a = (a -> a)

> fix :: Gen a -> a
> fix f = f (fix f)

The classic example they start with is calculating the nth fibonacci number, but don’t stop reading just because this example is simple! It is just to illustrate the technique.

> fib :: Int -> Int
> fib 0     = 0
> fib 1     = 1
> fib (n+2) = fib n + fib (n+1)

By the time you get to fib 30 it takes a dozen or seconds to return on my poor old computer. Rewrittin in open recursion as

> gFib :: Gen (Int -> Int)
> gFib recurse 0     = 0
> gFib recurse 1     = 1
> gFib recurse (n+2) = recurse n + recurse (n+1)

> fib' = fix gFib

This fib' has essentially the same performance, up to constant factors: slow.

To enable us to store the memoization table in something like a State, we parameterize over an underlying monad. A beautiful technique in its own right, if you ask me. I agree with the authors that open recursion and monadification are important and powerful enough to deserve language support; you probably will think gmFib below looks a bit crufty.

> gmFib :: Monad m => Gen (Int -> m Int)
> gmFib recurse 0     = return 0
> gmFib recurse 1     = return 1
> gmFib recurse (n+2) = do a <- recurse n
>                          b <- recurse (n+1)
>                          return (a + b)

And now we can mix in memoize

> type Memoized a b = State (M.Map a b)

> memoize :: Ord a => Gen (a -> Memoized a b b)
> memoize self x = do memo <- check x
>                     case memo of
>                       Just y  -> return y
>                       Nothing -> do y <- self x
>                                     store x y
>                                     return y

> check :: Ord a => a -> Memoized a b (Maybe b)
> check x = do memotable <- get
>              return (M.lookup x memotable)

> store :: Ord a => a -> b -> Memoized a b ()
> store x y = do memotable <- get
>                put (M.insert x y memotable)

Here’s the final fib, which returns instantly up to at least 10000.

> fib'' n = evalState (fix (gmFib . memoize) n) M.empty

Computation Tree Logic (CTL)

The language for which Clarke et al give a graph-based algorithm is called CTL; nowadays people are interested in a bunch of variants like CTL* and ACTL. I’m not a model-checking researcher so I don’t really know the subtleties of their differences. CTL is a logic for specifying certain restricted kinds of predicates over the possible traces of a state machine, for today a finite state machine.

Let’s just look at the Haskell definition:

> data CTL p = TT | FF
>            | Atomic p
>            | Not (CTL p)
>            | And (CTL p) (CTL p)
>            | AllSucc  (CTL p)
>            | ExSucc   (CTL p)
>            | AllUntil (CTL p) (CTL p)
>            | ExUntil  (CTL p) (CTL p)
>              deriving (Eq,Ord)

Some of these are simply your usual logic

• TT holds of any state
• FF never holds
• Atomic p is some atomic proposition over a state, like inequality over program variables, etc.
• Not and And have their expected meanings

The successor constructions let you talk about “the next” state:

• AllSucc f (respectively ExSucc) holds of a state s when the formula f holds for all (respectively some) successor states.

The interesting ones though, are “Always Until” and “Exists Until”:

• AllUntil f1 f2 holds of a state s when for all prefixes of any trace starting at s you eventually reach a state satisfying f2, and everywhere along the way f1 holds.
• ExUntil is the existential version of that.

We can then define some more predicates like “forever in the future” and “eventually”

> allFuture f = AllUntil TT f
> existsFuture f = ExUntil TT f

> allGlobal f = Not(existsFuture(Not f))
> existsGlobal f = Not(allFuture(Not f))

Now, to apply a formula to a state machine, first I need the state machine. I’ll just represent it by its successor function.

> type Succ st = st -> [st]

And we need some interpretation of atomic formulas as predicates over states

> type Interp p st = p -> st -> Bool

And since I’m using a monadified form of computation, I will lift a bunch of operations into monads to make everything readable.

> andThen,orElse :: Monad m => m Bool -> m Bool -> m Bool
> andThen = liftM2 (&&) 
> orElse  =  liftM2 (||) 

> notM :: Monad m => m Bool -> m Bool
> notM = liftM not

> anyM,allM :: Monad m => (s -> m Bool) -> [s] -> m Bool
> allM f = liftM and . mapM f
> anyM f = liftM or  . mapM f

The Model-Checking Algorithm

In the Clarke et al paper, the algorithm is expressed by induction on the formula f you want to check: First, label your state-space graph with all the atomic formula that hold at each state. Then, label with each the compound formula of height two that holds. Etc, etc, you are guaranteed that the graph is already labeled with each subformula by the time it becomes necessary.

Like dynamic programming, this is simply a complicated way of expressing memoization. In fact, they even use a depth-first search helper function that is completely eliminated by expressing it as a memoized function. This code is considerably shorter and, I think, clearer than the pseudocode in the paper, modulo the overhead of “mixing in” and “tying the knot”.

Today we have fancy algorithms involving BDDs and abstraction, so I’m not claiming anything useful except pedagogically. I do wonder, though, if this code gains something through laziness. It certainly traverses the state space fewer times (but I’m sure an implementation of their algorithm would do similar optimizations).

> checkCTL :: forall p st . (Ord p, Ord st) => 
>                           Interp p st -> Succ st -> st -> CTL p -> Bool
> checkCTL interp succ init f = 
>    evalState (fix (gCheckCTL . cyclicMemoize2 False) f init) M.empty
>  where 
>    gCheckCTL :: Monad m => Gen (CTL p -> st -> m Bool)
>    gCheckCTL recurse f s = checkFormula f
>      where checkFormula TT           = return True
>            checkFormula FF           = return False
>            checkFormula (Atomic p)   = return (interp p s)
>            checkFormula (Not f1)     = notM (recurse f1 s)
>            checkFormula (And f1 f2)  = recurse f1 s `andThen` recurse f2 s
>            checkFormula (AllSucc f1) = allM (recurse f1) (succ s)
>            checkFormula (ExSucc f1)  = anyM (recurse f1) (succ s)

>            checkFormula (AllUntil f1 f2) = recurse f2 s `orElse` 
>                            (recurse f1 s `andThen` allM (recurse f) (succ s))

>            checkFormula (ExUntil f1 f2)  = recurse f2 s `orElse` 
>                            (recurse f1 s `andThen` anyM (recurse f) (succ s))

You may also notice that I cheated a little, perhaps. I have used cyclicMemoize2 instead of memoize:

> cyclicMemoize2 :: (Ord a, Ord b) => c -> Gen (a -> b -> Memoized (a,b) c c)
> cyclicMemoize2 backEdge self x y = do memo <- check (x,y)
>                                       case memo of
>                                          Just z  -> return z
>                                          Nothing -> do store (x,y) backEdge
>                                                        z <- self x y
>                                                        store (x,y) z
>                                                        return z

One reason is simply that I need a curry/uncurry wrapper for my two argument monadified function. The deeper thing is that cyclicMemoize2 False inserts a fake memoization entry while a computation is progressing. If there is ever a “back edge” in the search, it will return this dummy entry. For CTL, the auxilliary depth-first search used in the paper for AllUntil returns False in these cases, so I seed the memo table accordingly. This is because by the time you have recursed around a cycle, that means that the f2 you are searching for did not occur on the cycle, so it never will.

To play with it, I’ve only made a couple of examples involving stop lights (of occasionally curious colors). I’d love more, and you’ll undoubtedly find bugs if you actually run something significant.

> ex1interp p s = (p == s)

> ex1succ "Red"    = ["Green"]
> ex1succ "Green"  = ["Yellow"]
> ex1succ "Yellow" = ["Red"]

> ex2succ "Red"    = ["Green"]
> ex2succ "Green"  = ["Yellow", "Orange"]
> ex2succ "Orange" = ["Red"]
> ex2succ "Yellow" = ["Red"]

But it looks kind of OK,

*Main> let ch2 = checkCTL ex1interp ex2succ
*Main> let ch1 = checkCTL ex1interp ex1succ
*Main> ch1 "Red" (existsFuture (Atomic "Red"))
True
*Main> ch1 "Red" (existsFuture (Atomic "Blue"))
False
*Main> ch2 "Green" (ExUntil TT (Atomic "Red"))
True
*Main> ch2 "Green" (ExUntil (Atomic "Green") (Atomic "Orange"))
True
*Main> ch1 "Green" (Not (AllUntil (Not (Atomic "Yellow")) (Atomic "Red")))
True
*Main> ch1 "Green" (Not (ExUntil (Not (Atomic "Yellow")) (Atomic "Red")))
True
*Main> ch2 "Green" (Not (ExUntil (Not (Atomic "Yellow")) (Atomic "Red")))
False

Quite fun!

As usual, this post is a literate Haskell file, so you can try it out by saving it to Inkscape.lhs, compiling with ghc --make Inkscape, grabbing the source file for the images above, and running ./Inkscape < demo.svg. The output will appear in Slides.pdf (and your directory will be polluted with temp files, so be aware).

For the record, multi-page documents have been on the Inkscape feature request tracker for many versions, so I presume it is a significant change. I do grok C and C++, thanks to the legacy-oriented education system, but take little enough pleasure from them that I would rather hack around the issue in Haskell.

> import Text.XML.HaXml
> import Text.XML.HaXml.Pretty
> import Text.XML.HaXml.Posn
> import Text.PrettyPrint.HughesPJ
> import Text.Printf
> import Data.List
> import System.IO
> import System.Cmd

HaXml is based on a combinator library for CFilters to filter, search, output, etc XML content. It is a little crufty in some ways — many datatypes are transpararent, and you have to do a lot of your own set up and tear down. The expected way to use it seems to be via processXmlWith :: CFilter -> IO () which is not sufficient for today’s task. The Hackage documentation pointed to an old version of the API, so I used the current version of the source code for documentation. I’d love any criticism like “you didn’t have to do X” or “here is an easier, safer way to do Y”.

I couldn’t think of a better way to narrate this code, so I’ll start with main for a high-level read, and then later fill in all the helper functions. Naturally we start with a call to xmlParse; the "-" is a required filename for error reporting.

> main = do input <- getContents
>           let xml = xmlParse "-" input

Then I grab the names of all the layer objects in the order they appear in the file, except for the special layer “Background” which I’ll include behind every slide. The call to verbatim spits them out as Strings instead of XML Content, and the "-" is yet another required filename for error reporting.

>           let names = delete "Background" 
>                       $ map verbatim 
>                       $ filterElem "-" getLayerNames
>                       $ xmlElem 
>                       $ xml
>           putStrLn $ "Making slides from layers:" 
>                        ++ concatMap ("\n\t"++) names ++ "\n"

Then for each layer, make a new version of the file with just that layer visible.

>           let outXmls = map (flip selectLayer xml) names
>               usedSlides = take (length names) slideNames
>           mapM_ (uncurry writeFile) 
>                 (zip (map (++".svg") slideNames) 
>                      (map (renderStyle xmlStyle . document) outXmls))

And some shell scripting done in Haskell. I didn’t even try to find a scripting library or anything to e.g. prevent me from building a malformed command.

>           mapM_ (\slide -> do 
>                    system $ "inkscape --export-text-to-path --export-pdf='" 
>                             ++ slide ++ ".pdf' '" ++ slide ++ ".svg'")
>                 usedSlides
>           
>           system $ "pdftk " 
>                      ++ concat (intersperse " " (map (++".pdf") usedSlides)) 
>                      ++ " cat output Slides.pdf"

So now to the little details:

Grabbing the layer names

Here is the first helper I wrote, wrapping HaXml’s attrval for a common case. This filter returns every tag whose attr attribute has the string value val.

> matchAttrString :: String -> String -> CFilter i
> matchAttrString attr val = attrval (attr, AttValue [Left val])

The next helper is one that maps a tag to its attribute value, otherwise discards anything else it sees. The HaXml function iffind will pass the attr attribute value of a tag to literal which just returns it. If the attribute isn’t found, or the XML data isn’t a tag, then none will discard it.

> showAttr :: String -> CFilter i
> showAttr attr = iffind attr literal none

The Inkscape layers are contained in <g inkscape:groupmode='layer' ...> tags. The name of the layer is in the inkscape:label attribute. I imagine this will change as Inkscape evolves. The o is the composition operator for CFilters.

> isLayer = matchAttrString "inkscape:groupmode" "layer"
> getLayerNames = showAttr "inkscape:label" `o` isLayer `o` children

Isolating the layers

Again proceeding from the outside of my program inwards, a layer is isolated with this helper, using iffind to match either the layer name or the layer “Background” which I’m going to leave in all the output files. The final keep argument to iffind says to keep parts of the XML that don’t have the "inkscape:label" attribute.

> selectLayer :: String -> Document Posn -> Document Posn
> selectLayer layer doc = onContent "-" (chip (visible `o` onlyLayer)) doc
>     where onlyLayer = iffind "inkscape:label" layerOrBG keep
>           layerOrBG l = if l == layer || l == "Background" then keep else none

In writing visible I was surprised that there was a combinator to set all attributes for a tag, but none to set a single attribute.

> visible = setAttr "style" "display:inline"
> setAttr key val (CElem (Elem tag attrs cs) i) = [CElem (Elem tag newattrs cs) i]
>     where newattrs = (key, AttValue [Left val]) : filter ((/= key) . fst) attrs
> setAttr key val other = [other] -- Hackish?

As I mentioned before, there is no way that I see to directly apply this filter to an XML file using HaXml. The type CFilter = Content -> [Content] needs wrapping to apply to an XML Element directly. Notice how I have to pass in a file for error reporting; it feels like I’m doing things I’m not supposed to.

> filterElem :: FilePath -> CFilter Posn -> Element Posn -> [Content Posn]
> filterElem file f e = f (CElem e (posInNewCxt file Nothing))

> xmlElem (Document _ _ e _) = e

And now the function to actually apply a filter to an XML document. This is straight from the body of processXmlWith in the HaXml source, with filterElem pulled out.

> onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn
> onContent file filter (Document p s e m) =
>     case filterElem file filter e of
>              [CElem e' _] -> Document p s e' m
>              []           -> error "produced no output"
>              _            -> error "produced more than one output"

Bits and pieces

I also used a modified style for the HughesPJ pretty printer

> xmlStyle = style { mode = LeftMode }

And a big list of slide names with three digits, for this one-off job. Better would be to use an API for generating fresh temporary files.

> slideNumbers = map (printf "%03d") ([1..999] :: [Int])
> slideNames = map ("Slide"++) slideNumbers

As usual, you can save this post to Fractals.lhs and compile it with ghc --make Fractals

It seems that a couple of people have gone before me making actually useful fractal packages (the packages are more specifically for “Iterated Function Systems” and “L-systems”, respectively) or prettier pictures in their blog posts.

• IFS (and related blog entry)
• Nymphaea
• Fractal-hs

But I didn’t let that stop me from doing a little hacking. This article is hopefully more entertaining to read than a library API. So let’s get started!

> import Data.IORef
> import Data.List
> import Graphics.Rendering.OpenGL as GL
> import Graphics.UI.Gtk as Gtk
> import Graphics.UI.Gtk.OpenGL
> import Control.Monad.Writer
> import Control.Monad.State as S

The state of the cursor is a position, direction, and whether the ink is activated (so I can move it about without drawing lines everywhere). The neutral state is at the origin, pointed due east, with the ink on.

> type Point2 = Vertex2 GLfloat
>
> data CursorState = TS { pos :: Point2
>                       , dir :: Float
>                       , ink :: Bool }
>
> neutral = TS { pos = Vertex2 0 0
>              , dir = 0
>              , ink = True }

Now rather than define the syntax of cursor commands and make functions for creating and consuming it, I want to embed the commands into Haskell. This is quite easy, of course.

> type Instruction = CursorState -> CursorState
>
> leftI    angle s = s { dir = dir s + angle }
> rightI   angle s = s { dir = dir s - angle }
> penI     b     s = s { ink = b }
> forwardI dist  s = s { pos = move (pos s) dist (dir s) }
>     where move (Vertex2 x y) dist dir = Vertex2 (x + dist * cos dir) 
>                                                 (y + dist * sin dir)

A first approach to the semantics is that sequence of commands should have the state threaded through it. The type of a program would be State CursorState () (the unit is because there is no return value). I would then get the final state of prog starting from the neutral state with execState program neutral.

But I don’t actually care about the final state; I want to evaluate this program only for its side effects: Whenever I run a forward command, it should leave a line segment if ink was enabled. This situation is just what the Writer monad is for. When I move from s1 to s2, I call tell [(s1,s2)] in order to “log” this line segment.

I actually need to carry the state and the log around, so how do I combine these monads? Well, there’s a huge trail of literature to follow on that! If you are interested, Composing Monads Using Coproducts by C Lüth, N Ghani has a canonical way, and lots of references. But for today, the officially sanctioned approach is to use a monad transformer; in many practical cases this coincides with the coproduct.

So a first attempt at the type of a cursor program would be:

type CursorProgram = StateT CursorState (Writer [(Point2,Point2)]) ()

What is all this? Well, CursorState is the state I want to pass around, and Writer [(Point2, Point2)] is the internal monad. The type is large, but it says a lot! The only thing I have to watch for is to use lift . tell instead of tell because I need to apply it to the inner Writer.

But you shouldn’t use list append for a log in real life. In the above hypothetical definition, the log is accumulated via the (++) monoid, so every time computations are combined with >>= the writer monad will invoke a potentially-costly list append operation. The log will always grow from its tail, so I could build the list backwards and it would be efficient, but there is a cooler trick (Kefer points out in the comments that the dlist package provides a usable library for this representation, also called “difference lists”), from this paper:

• A novel representation of lists and its application to the function “reverse”. RJM Hughes. Information Processing Letters. 1986

In a nutshell: lists and partial applications of (++) are in bijection, so I can swap them. Here’s the definition, the bijection, and the monoid instance. “List” concatenation is now function composition, and the empty list is the identity function. What a pretty monoid morphism!

> newtype List a = L ([a] -> [a])
> instance Monoid (List a) where
>     mappend (L x) (L y) = L (x . y)
>     mempty = L id

> inject :: [a] -> List a
> inject l = L (l++)

> recover :: List a -> [a]
> recover (L list) = list []

> singleton :: a -> List a
> singleton x = L (x:)

Notice how if I append a bunch of singletons, it is the same number of applications of : as if I had built the list backwards. Then when I recover the list it costs O(n), the same as efficient reversal, so the two are equally good strategies in this case. It would be best to make a newtype for backwards lists with its own monoid instance anyhow, so the programming overhead is also the same.

Now I just wrap all the instructions to operate on this more-complicated state, adding logging to forward.

> type CursorProgram = StateT CursorState (Writer (List (Point2,Point2))) ()
>
> liftI :: (CursorState -> CursorState) -> CursorProgram
> liftI instr = S.put . instr =<< S.get

> forward, left, right :: Float -> CursorProgram
> left    angle = liftI (leftI angle)
> right   angle = liftI (rightI angle)
> forward dist  = do s <- S.get
>                    liftI (forwardI dist)
>                    s' <- S.get
>                    when (ink s) $ lift $ tell $ singleton (pos s, pos s')

> pen :: Bool -> CursorProgram
> pen b = liftI (penI b)

> run :: CursorProgram -> CursorState -> [(Point2,Point2)]
> run prog state = recover $ execWriter $ execStateT prog state

That’s not so bad, is it? So now let’s get on to some drawing.

Possibly the simplest fractal that already can blow your mind is the Cantor Set.

> cantor :: Int -> CursorProgram
> cantor depth = cantor' depth 1.0
>   where cantor' 0 size = forward size
>         cantor' n size = do cantor' (n-1) (size/3)
>                             pen False
>                             forward (size/3)
>                             pen True
>                             cantor' (n-1) (size/3)

Viewing that won’t be very interesting; it is just an excuse to talk about it. But Wikipedia has a nice image:

Take the segment and remove the center third of it, keeping the endpoints intact. Now remove the center third of each of those segments, and again, and again. Taking the intersection of all of these sets (i.e. the limit) gives the Cantor Set.

So what does it look like? Well, it isn’t empty, since every point that is ever an endpoint sticks around forever. But those aren’t the only points: Convince yourself that is in the set. I’m pretty sure this can be phrased as a coinductive proof but for now the next paragraph will give you another approach.

The classic way of understanding the Cantor Set is to use ternary digits. See if you can convince yourself that the cantor set contains every real number that doesn’t require a 1 in its ternary expansion (hint: 0.0222222… = 0.1 so 0.1 doesn’t require a 1 in its ternary expansion)

So any number made of a possibly-infinite string of 0s and 2s is in there. Sound familiar? Well, if we use “1″ instead of “2″ then we are talking about all possibly-infinite binary strings, which a programmer should intuitively see is all real numbers in (…Cauchy sequences, mumble, mumble…). So the Cantor Set is, in fact, uncountable!

Next, how about the Koch curve?

> koch :: Int -> CursorProgram
> koch depth = koch' depth 1.0
>   where koch' 0 size = forward size
>         koch' n size = do koch' (n-1) (size/3)
>                           left (pi/3)
>                           koch' (n-1) (size/3)
>                           right (pi * 2/3)
>                           koch' (n-1) (size/3)
>                           left (pi/3)
>                           koch' (n-1) (size/3)

This curve (in the limit) is continuous everywhere but differentiable nowhere.

But what is more fun is when you stick three of them end-to-end, for Koch’s Snowflake.

> kochFlake :: Int -> CursorProgram
> kochFlake depth = do -- lining up
>                      pen False
>                      forward 1.0
>                      right (pi/2)
>                      forward (1 / (2*sqrt(3)))
>                      right (pi/2)
>                      pen True
>                      -- draw in a triangle shape
>                      koch depth
>                      right (2*pi/3)
>                      koch depth
>                      right (2*pi/3)
>                      koch depth

Here, the area is finite, and yet the boundary is infinite, which is normal for fractal-boundaried regions.

Finally, there’s Heighwey’s dragon.

> heighway :: Int -> CursorProgram
> heighway depth = heighway' depth 1.0 1.0
>   where heighway' 0 size parity = forward size
>         heighway' n size parity = do left (parity * pi / 4)
>                                      heighway' (n-1) (size / sqrt 2) 1
>                                      right (parity * pi / 2)
>                                      heighway' (n-1) (size / sqrt 2) (-1)
>                                      left (parity * pi / 4)

This is what you get if you just keep folding a piece of paper in half in the same direction, then unfold it and set every fold to a right angle. Rather than recite facts from Wikipedia, I’ll highly recommend the original article, as it is of rare quality. In fact, all of the articles about these curves were so unexpectedly satisfying that I ended up not feeling the need to write much.

What all of the above fractal curves except the Koch Snowflake have in common is self-similarity. The cantor set is essentially identical to each of its left and right hand sides, i.e. it is identical to the union of two scaled-down copies of itself, as the cursor-graphics code makes obvious. I said I wouldn’t talk about it, so I’ll just mention that if you write this as then and are the functions in “iterated function systems. I highly recommend a googling, or better yet, the book which prompted this post.

Below is the actual nitty-gritty OpenGL, Gtk, and IO code that plugs it together.

> render :: CursorProgram -> IO ()
> render fractal = do
>   clear [ColorBuffer]
>   loadIdentity
>   color3f (Color3 1 1 1)
>   translate3f $ Vector3 (-0.5) 0 0
>   renderPrimitive Lines $ mapM_ vertex $ combine $ run fractal neutral
>   where color3f = color :: Color3 GLfloat -> IO ()
>         translate3f = translate :: Vector3 GLfloat -> IO ()
>         scale3f = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
>         combine = concatMap (\(start,end) -> [start,end])

> draw :: GLDrawingArea -> IO () -> IO ()
> draw canvas render = do
>   -- This is all Gtk code, managing the internal structures
>   glContext <- glDrawingAreaGetGLContext canvas
>   glWin <- glDrawingAreaGetGLWindow canvas
>   (w,h) <- glDrawableGetSize glWin
>
>   glDrawableGLBegin glWin glContext
>   -- Scale up and use the whole canvas
>   (pos, _) <- GL.get viewport
>   viewport $= (pos, Size (fromIntegral w) (fromIntegral h))
>   render
>   GL.flush -- except this
>   glDrawableSwapBuffers glWin
>   glDrawableGLEnd glWin

> main = do
>   initGUI
>   glConfig <- glConfigNew [GLModeRGBA, GLModeDouble]
>   initGL
>
>   depthRef <- newIORef 0
>   fractalRef <- newIORef cantor
>
>   canvas  <- glDrawingAreaNew glConfig
>   let redraw = do depth <- readIORef depthRef
>                   fractal <- readIORef fractalRef
>                   draw canvas (render (fractal depth))
>
>   onExpose canvas (\_ -> do { redraw; return True } )
>
>   buttonBox <- vBoxNew False 0
>
>   incrButton <- buttonNew
>   Gtk.set incrButton [ buttonLabel := "More iterations." ]
>   onClicked incrButton (do oldval <- readIORef depthRef
>                            putStrLn $ show (oldval + 1) ++ " iterations!"
>                            writeIORef depthRef (oldval + 1)
>                            redraw)
>
>   decrButton <- buttonNew
>   Gtk.set decrButton [ buttonLabel := "Less iterations." ]
>   onClicked decrButton (do oldval <- readIORef depthRef
>                            putStrLn $ show (max 0 (oldval - 1)) ++ " iterations!"
>                            writeIORef depthRef (max 0 (oldval - 1))
>                            redraw)
>
>   boxPackStart buttonBox incrButton PackNatural 0
>   boxPackStart buttonBox decrButton PackNatural 0
>
>   dummy <- radioButtonNew -- All buttons join this group
>   mapM_ (\(fun,label) -> do button <- radioButtonNewWithLabelFromWidget dummy label
>                             onToggled button (do me <- toggleButtonGetActive button
>                                                  when me $ do writeIORef fractalRef fun
>                                                  redraw)
>                             boxPackStart buttonBox button PackNatural 0)
>             [ (cantor, "Cantor Set")
>             , (koch, "Koch Curve")
>             , (kochFlake, "Koch Flake")
>             , (heighway, "Heighway Dragon") ]
>
>   canvasBox <- hBoxNew False 0
>   boxPackStart canvasBox buttonBox PackNatural 0
>   boxPackStart canvasBox canvas PackGrow 0
>
>   window <- windowNew
>   Gtk.set window [ containerBorderWidth := 10,
>                    containerChild := canvasBox ]
>   onDestroy window mainQuit
>
>   widgetShowAll window
>   mainGUI

This post is literate Haskell that will output that image, so save it to something like Congestion.lhs and run ghc --make Congestion.lhs. I started with the code from an old post and cut out the bits I didn’t need. The libraries used can be found here:

• Haskell OpenGL
• Gtk2hs

First, there is the usual administrivia.

> import Data.IORef
> import Data.List
> import Graphics.Rendering.OpenGL as GL hiding (map2)
> import Graphics.UI.Gtk as Gtk hiding (drawSegments, Color)
> import Graphics.UI.Gtk.OpenGL
> import System.Random

Any proper Haskell programmer will of course want to create an infinite list of random segments,

> type Point3 = Vertex3 GLfloat
>
> randomPoints :: IO [Point3]
> randomPoints = do
>   xgen <- newStdGen
>   ygen <- newStdGen
>   let xs = randomRs (-0.9,0.9) xgen
>   let ys = randomRs (-0.9,0.9) ygen
>   return $ map2 (\x y -> Vertex3 x y 0) xs ys
>     where  map2 f first second = map (uncurry f) (zip first second)

Then renderSegments is straightforward. I draw them very faint gray so that only in locations of congestion do we see brighter white.

> renderSegments :: [(Point3,Point3)] -> IO ()
> renderSegments segments = do
>   clear [ColorBuffer]
>   color3f (Color3 0.05 0.05 0.05)
>   mapM_ renderSegment segments
>     where
>     color3f = color :: Color3 GLfloat -> IO ()
>     renderSegment (start, end) = renderPrimitive LineStrip $ do vertex start
>                                                                 vertex end

There are a bunch of Gtk and OpenGL calls to add, yielding drawSegments below. The only thing to note is the setting of blendFunc and blendAdd which tell OpenGL to add the color that is already on a pixel to the color I’m trying to draw. It is really a cheap trick to get OpenGL to intersect my line segments and add up the totals for me. One gotcha that held me up is that these settings have to be within the glDrawableGLBegin and glDrawableGLEnd calls.

> drawSegments :: GLDrawingArea -> [(Point3,Point3)] -> IO Bool
> drawSegments canvas segments = do
>
>   -- This is all Gtk code, managing the internal structures
>   glContext <- glDrawingAreaGetGLContext canvas
>   glWin <- glDrawingAreaGetGLWindow canvas
>   (w,h) <- glDrawableGetSize glWin
>
>   -- These are OpenGL calls to scale up and use the whole canvas
>   (pos, _) <- GL.get viewport
>   viewport $= (pos, Size (fromIntegral w) (fromIntegral h))
>
>   -- This is again Gtk code
>   glDrawableGLBegin glWin glContext
>   blend $= Enabled
>   blendFunc $= (One, One)
>   blendEquation $= FuncAdd
>   renderSegments segments
>   GL.flush -- except this
>   glDrawableSwapBuffers glWin
>   glDrawableGLEnd glWin
>   return True

And finally we just plug it all together with even more initialization code.

> main = do
>   initGUI
>   glConfig <- glConfigNew [GLModeRGBA, GLModeDouble]
>   initGL
>   startPoints <- randomPoints
>   endPoints <- randomPoints
>   let segments = take 10000 $ zip startPoints endPoints
>
>   canvas  <- glDrawingAreaNew glConfig
>   onExpose canvas (\_ -> drawSegments canvas segments)
>
>   window <- windowNew
>   Gtk.set window [ containerBorderWidth := 10,
>                    containerChild := canvas ]
>   onDestroy window mainQuit
>
>   widgetShowAll window
>   mainGUI

> module Main where
> import Control.Monad
> import Data.List
> import Test.QuickCheck hiding (trivial)

To give a little background, something I realize I’ve neglected in the past, Knuth-Bendix completion is a technique in universal algebra, which is essentially the study of unityped syntax trees for operator/variable/constant expression languages, like these:

> data Term op a = Operator op [Term op a]
>                | Variable String
>                | Constant a

Your usual algebraic structures are for the most part special cases in universal algebra – anything that has an ambient set with some bunch of operators and equational axioms qualifies, and universal algebra supplies the variables to represent unspecified quantities.

For example, a monoid is a set with an operator and a special constant obeying these axioms, where are variables that can be replaced by any term.

Aside: Consider the obvious way to axiomatize a group in this framework. I think it is a nice example of the interaction of constructive logic and computation.

But anyhow today I’m not going to use this structure because I can explain and explore Knuth-Bendix more quickly by sticking to monoids. The full completion procedure, and its modern enhancements, works on terms with variables and uses unification where I use equality, and superposition where I use string matching. In the case of a monoid, the associative law lets me simplify the term structure from a tree to just a list, and since I’m not including variables, I deal just with words over my alphabet a:

> type Word a = [a]

A presentation is just a formalism as above, specifying the ambient set (here, the type parameter a), and some equalities called relations, written in mathematical notation as

and in Haskell

> type Relation a = (Word a, Word a) 
> type Presentation a = [Relation a]

For an easy example of a monoid and its presentation, Bool forms a monoid using the && operator which has identity True. Here is a presentation for the monoid in each notation (in general, presentations are not unique, and there’s a whole theory of messing about with them, which is exactly what we are about to do!)

> boolAnd = [ ([True,True], [True])
>           , ([True, False], [False])
>           , ([False, True], [False])
>           , ([False, False], [False]) ]

In this case, the equations are just the definition for &&. Another monoid you’ve certainly seen as a programmer is the free monoid over X, which looks like this:

> freeMonoid = []

In other words, it is just lists of elements of X since there are no rules for manipulating the words. The List monad is intimately related to this monoid.

Another good example is the following – see if you can figure out what it represents before going on.

Yes, it is a presentation for the monoid (in fact, group) , the integers mod . You are intended to interpret the group operation as addition modulo , as 1, and as the identity 0, hence is really mod . Of course, the abstractness of the presentation meshes well with this group’s other name, the “cyclic group of order “.

So, formalism is great fun and all, but sane folk prefer for computers to deal with it if possible. Our goal is to decide whether two words are equal according to the identities in the presentation. In general, this is undecidable, see

• http://en.wikipedia.org/wiki/Word_problem_for_groups

Here are some more example presentations for groups in Haskell, so I can use them. They are mostly harvested from http://en.wikipedia.org/wiki/Group_presentation and http://en.wikipedia.org/wiki/Knuth-Bendix_completion_algorithm

The cyclic group of order n, as above:

> cyclic n = [ (take n (repeat 'x'),"") ]

The dihedral group of order 2n:

> dihedral n = [ (take n (repeat 'r'),"")
>              , ("ff", "")
>              , ("rfrf", "") ]

The basic thing we are going to do is interpret equalities as rewriting rules. Everywhere the left-hand side appears, we insert the right-hand side. This function rewrites just once, if it finds an opportunity. I’m not going to even try for efficiency, since I get such a kick out of writing these pithy little Haskell functions.

> rewrite :: Eq a => Relation a -> Word a -> Word a
> rewrite _ [] = []
> rewrite rel@(lhs,rhs) word@(x:rest) = maybe (x:rewrite rel rest) ((rhs ++) . snd)
>                                             maybeRewritten
>   where maybeRewritten = find ((lhs ==) . fst) (zip (inits word) (tails word))

A natural way to check if two words are equal is to reduce them until they can reduce no further, and see if these normal forms are equal.

> reduce :: Eq a => Presentation a -> Word a -> Word a
> reduce pres word = if word' == word then word else reduce pres word'
>   where word' = foldr rewrite word pres

This function fully reduces a word, assuming the presentation has “good” properties like always making words smaller according to a well-founded ordering. To make sure of this, we can orient any relation according to such an ordering.

> shortlex :: Ord a => Word a -> Word a -> Ordering
> shortlex l1 l2 = if length l1 < length l2 then LT
>                  else if length l1 > length l2 then GT
>                       else lexical l1 l2
>     where lexical [] [] = EQ
>           lexical (x:xs) (y:ys) = case compare x y of
>                                     EQ -> lexical xs ys
>                                     other -> other
>
> orient :: Ord a => Relation a -> Relation a
> orient (lhs,rhs) = case shortlex lhs rhs of
>                      LT -> (rhs, lhs)
>                      _  -> (lhs, rhs)

But the results may be provably equal even though their normal forms are not, for example if I have this monoid

> xyzExample = [ ("yx", "z")
>              , ("xy", "z") ]

I know that "xz" == "zx" but I cannot obviously prove it

 *Main> reduce xyzExample "xz"
 "xz"
 *Main> reduce xyzExample "zx"
 "zx"

because the proof goes through "xz" == "xyx" == "zx". Knuth calls these “critical pairs” and they, in some sense, represent the point in a proof where someone had to be more clever than just cranking on the rules. But just to preview how completion works,

 *Main> reduce (complete xyzExample) "xz"
 "xz"
 *Main> reduce (complete xyzExample) "zx"
 "xz"

Voila!

We’ll also want to reduce relations and presentations. For relations, this is just reducing both sides, and orienting for good measure.

> reduceRel :: Ord a => Presentation a -> Relation a -> Relation a
> reduceRel pres (lhs,rhs) = orient (reduce pres lhs, reduce pres rhs)

To reduce a presentation, we reduce each relation with all the other relations. If the two sides reduce to the same word, then the relation was redundant and we can delete it.

> trivial :: Eq a => Relation a -> Bool
> trivial (x,y) = x == y  -- Otherwise known as `uncurry (==)`
>
> redundant :: Ord a => Presentation a -> Relation a -> Bool
> redundant pres = trivial . reduceRel pres
>
> reducePres :: Ord a => Presentation a -> Presentation a
> reducePres pres = filter (not . trivial) (reduceP [] pres) 
>     where reduceP prior [] = prior
>           reduceP prior (r:future) = let r' = reduceRel (prior++future) r 
>                                      in reduceP (r':prior) future

Now on to the Knuth-Bendix procedure. The primary idea is to find all the possible critical pairs as described above, and to make new rewrite rules so they aren’t critical anymore. In other terminology, we look for exceptions to local confluence, and patch them up.

First, partitions is a list of ways to split a word into two nonempty parts.

> partitions :: Word a -> [(Word a, Word a)]
> partitions x = reverse . tail . reverse . tail $ zip (inits x) (tails x)

Results looks like this:

 *Main> partitions "abcde"
 [("a","bcde"),("ab","cde"),("abc","de"),("abcd","e")]

Next, superpositions takes two words, and returns all the ways that the back of the first word could be the front of the second word.

> superpositions :: Eq a => Word a -> Word a -> [(Word a, Word a, Word a)]
> superpositions x y = map merge $ filter critical $ allPairs
>     where critical ((a,b),(c,d)) = (b == c)
>           merge ((a,b),(c,d)) = (a,b,d)
>           allPairs = [(p1, p2) | p1 <- partitions x, p2 <- partitions y]

 *Main> superpositions "abb" "bbc"
 [("a","bb","c"),("ab","b","bc")]

Then criticalPairs takes all the superpositions (x,y,z) where xy is reducible by one relation, and yz is reducible by the second, and returns the result of the aforementioned reductions. The last function, allCriticalPairs just filters these for inequivalent pairs.

> criticalPairs :: Eq a => Relation a -> Relation a -> [(Word a, Word a)]
> criticalPairs (l1,r1) (l2,r2) = map reduceSides (superpositions l1 l2)
>     where reduceSides (x,y,z) = (r1 ++ z, x ++ r2)
>
> allCriticalPairs :: Ord a => Presentation a -> [(Word a, Word a)]
> allCriticalPairs pres = filter (not . redundant pres) 
>                         $ concatMap (uncurry criticalPairs) rels
>     where rels = [(r1,r2) | r1 <- pres, r2 <- pres]

Just to save some redundant modification, we’ll assume the input presentation is reduced and oriented, and maintain that invariant ourselves. Then completion is pretty simple – just add the first non-reducible critical pair until there are no more.

> complete :: Ord a => Presentation a -> Presentation a
> complete pres = augment critPairs
>     where augment []    = pres
>           augment (x:_) = complete $ reducePres (x : pres)
>           critPairs = map orient (allCriticalPairs pres)

But this version of completion simplifies the presentation at every step, as per the descriptions of the algorithm I’ve seen – I obviously can’t do that if the result is infinite. The best I can think of is to track the finite number of relations I’ve already processed, and reduce each relation as I consider it according to those. And since I bet the order that generated rewrite rules are visited matters, I use the interleave function to make sure that all rewrite rules are eventually hit.

> quasicomplete :: Ord a => Presentation a -> Presentation a
> quasicomplete pres = augment [] pres
>     where augment prior []     = []
>           augment prior (x:xs) | redundant prior x = augment prior xs
>                                | otherwise  = x':augment prior' rest
>               where x' = reduceRel prior x
>                     prior' = reducePres (x:prior)
>                     rest = map (reduceRel prior') (interleave critPairs xs)
>                     critPairs = allCriticalPairs prior'

> interleave :: [a] -> [a] -> [a]
> interleave [] ys = ys
> interleave xs [] = xs
> interleave (x:xs) ys = x:(interleave ys xs)

And I need to directly test equality rather than reducing a relation and checking for triviality, since I don’t know when reduction is done.

> equiv :: Ord a => Presentation a -> Word a -> Word a -> Bool
> equiv pres w1 w2 = or (map equivPrefix (inits pres))
>     where equivPrefix prefix = reduce prefix w1 == reduce prefix w2

The above function does not give the same completions as the finite version, but it does seem to work. Here is a quickcheck property to test it. Since interesting presentations are probably hard to autogenerate, I just specialize it to the xyzExample.

> prop_quasiXYZ :: [XYZ] -> [XYZ] -> Bool
> prop_quasiXYZ xyz1 xyz2 = 
>     trivial (reduceRel (complete xyzExample) (w1,w2)) == 
>     trivial (reduceRel (quasicomplete xyzExample) (w1,w2))
>         where w1 = map unXYZ xyz1
>               w2 = map unXYZ xyz2
>
> newtype XYZ = XYZ { unXYZ :: Char } 
> instance Arbitrary XYZ where
>     arbitrary = liftM XYZ $ oneof [return 'x', return 'y', return 'z']
> instance Show XYZ where
>     show = show . unXYZ

All seems well! Now here’s the example wikipedia uses for Knuth-Bendix:

> wikipediaExample = [ ("xxx", "")
>                    , ("yyy", "")
>                    , ("xyxyxy", "") ]

Indeed, the finite completion algorithm agrees with what Wikipedia says, and the following property passes lots of tests:

> prop_quasiWiki :: [XY] -> [XY] -> Bool
> prop_quasiWiki xy1 xy2 = 
>     trivial (reduceRel (complete wikipediaExample) (w1,w2)) == 
>     trivial (reduceRel (quasicomplete wikipediaExample) (w1,w2))
>         where w1 = map unXY xy1
>               w2 = map unXY xy2
>
> newtype XY = XY { unXY :: Char } 
> instance Arbitrary XY where
>     arbitrary = liftM XY $ oneof [return 'x', return 'y']
> instance Show XY where
>     show = show . unXY

And the major test: Infinitude! I accidentally found out that my procedures don’t terminate for the dihedral n for n >= 3, so let’s make some tests of hand-checked equalities.

> d3 = quasicomplete (dihedral 3)

> prop_d3 :: Bool
> prop_d3 = all (uncurry $ equiv d3) [ ("rrf", "fr")
>                                    , ("frf", "rr")
>                                    , ("frr", "rf")
>                                    , ("f", "rfr")
>                                    , ("rfrff", "rrfrr") ]

It seems to work. If I were really fancy I’d take random walks on the rewrite rules and then see if completion could retrace those steps. But I’m not that fancy today!

Here’s my little pseudo-quickcheck main

> main = do mycheck ("prop_quasiXYZ", prop_quasiXYZ)
>           mycheck ("prop_quasiWiki", prop_quasiWiki)
>           mycheck ("prop_d3", prop_d3)
>   where mycheck (name,prop) = do 
>           putStr (name ++ ": ")
>           quickCheck prop

Two aspects of this post are given about equal weight:

1. The mathematical content is elementary and can be understood by anyone familiar with basic trigonometry, as you might learn in high school. It is inspired by the book Symmetries by DL Johnson, one of the very excellent Springer Undergraduate Mathematics Series.
2. The tool QuickCheck is a fairly brilliant and easy-to-use automatic testing library for Haskell. I use it to verify each step of the post. All but the first of my QuickCheck properties found real errors!

> module Main where
> import Test.QuickCheck

Now, the reflect-rotate-translate normal form is defined relative to a point (the center of rotation) and a line (of reflection). Concisely: where is a translation, is a rotation about , and is a reflection about (allowing the identity to be considered a reflection).

I will choose and the X axis since they are simple.

> newtype Translation = Translate (Double, Double) deriving Show
> newtype Rotation    = Rotate Double deriving Show
> newtype Reflection  = Reflect Bool deriving Show
>
> translate (Translate (dx,dy)) (x,y) = (x+dx,y+dy)
> rotate (Rotate angle) (x,y) = (x * cos angle - y * sin angle,
>                                x * sin angle + y * cos angle)
> reflect (Reflect b) (x,y) = if b then (x,-y) else (x,y)
>
> type IsometryNF = (Translation, Rotation, Reflection) 
> apply (t, s, r) (x,y) = (translate t . rotate s . reflect r) (x,y)

Aside from preserving distances, the other key aspect of an isometry is that it is invertible, so let’s express the invertibility of these basic isometries with a Haskell type class.

> class Invertible a where
>   inverse :: a -> a
>
> instance Invertible Translation where
>   inverse (Translate (dx,dy)) = (Translate (-dx,-dy))
>
> instance Invertible Rotation where
>   inverse (Rotate angle) = Rotate (-angle)
>
> instance Invertible Reflection where
>   inverse (Reflect b) = Reflect b

We can now express the normalForm function. As input, it takes an arbitrary “black-box” isometry as a Haskell function (the type doesn’t enforce that the function is actually an isometry, of course). As each component of the normal form is computed, the inverse of that component is applied before calculating the next component.

> type Point2D = (Double,Double)
> type Map2D = Point2D -> Point2D
> data Isometry = Isometry Map2D
>
> normalForm :: Isometry -> IsometryNF
> normalForm (Isometry f) = (t, s, r)
>   where t = translation f
>         s = rotation (translate (inverse t) . f)
>         r = reflection (rotate (inverse s) . translate (inverse t) . f)

The rest of this post is writing and specifying the translation, rotation, and reflection helper functions. As an example, I’ve created this isometry using GeoGebra. I will maintain the convention that the source objects are blue and the output of a transformation is red.

Since reflections and rotations fix the origin, the translation is just wherever the origin gets sent.

> translation :: Map2D -> Translation
> translation f = Translate (f (0,0))

On translations, this should be the identity, and we express that fact with the first of these QuickCheck properties. The second indicates that for an arbitrary isometry , composing with the translation’s inverse should fix the origin, because and leave the origin where it is: Or in pictures:

The operator =~= is an “approximate” equality operator for floating point numbers.

> prop_translation :: Translation -> Point2D -> Bool
> prop_translation trans (x,y) = translate trans (x,y) =~=
>                                translate (translation (translate trans)) (x,y)
>
> prop_tInv :: Isometry -> Point2D -> Bool
> prop_tInv (Isometry f) (x,y)  =  (tInv . f) (0,0) =~= (0,0)
>   where tInv = (translate . inverse . translation) f

To find the rotation, we pick any point on the X axis and see where it is sent after inverting the translation. A simple choice is (1,0) which will be rotated somewhere else on the unit circle.

> rotation :: Map2D -> Rotation
> rotation f = Rotate angle
>   where (x,y) = f (1,0)
>         yAngle = asin y
>         xAngle = acos x
>         angle  = if yAngle > 0 then xAngle else 2*pi - xAngle

To test this function, we use extensional equality on rotation functions rather than intensional equality on the angle since rotations do not have a unique representation (our function returns a canonical representation between 0 and ). As inverting the translation component of an isometry fixes the origin, inverting this rotation should fix the point (1,0) and by implication the entire X axis. In pictures:

> prop_rotation :: Rotation -> Point2D -> Bool
> prop_rotation rot (x,y) = rotate rot (x,y) =~= 
>                            rotate (rotation (rotate rot)) (x,y)
>

> prop_sInv :: Isometry -> Point2D -> Bool
> prop_sInv (Isometry f) (x,y)  =  (sInv . tInv . f) (1,0) =~= (1,0)
>   where tInv = (translate . inverse . translation) f
>         sInv = (rotate . inverse . rotation) (tInv . f)

We have calculated and and now we have in hand:

Now we just figure out the reflection by choosing any point not on the X axis and seeing if it was reflected or not. An obvious choice is (0,1)

> reflection :: Map2D -> Reflection
> reflection f = Reflect (not (f (0,1) =~= (0,1)))

The correctness properties should be familiar by now:

> prop_reflection :: Reflection -> Point2D -> Bool
> prop_reflection refl (x,y)  =  reflect refl (x,y) =~=
>                                reflect (reflection (reflect refl)) (x,y)
>
> prop_rInv :: Isometry -> Point2D -> Bool
> prop_rInv (Isometry f) (x,y)  =  (rInv . sInv . tInv . f) (1,0) =~= (1,0)
>   where tInv = (translate . inverse . translation) f
>         sInv = (rotate . inverse . rotation) (tInv . f)
>         rInv = (reflect . inverse . reflection) (sInv . tInv . f)

And we are done! To test, though, we need to tell QuickCheck how to generate isometries. I could reuse the basic isometries, but code duplication is desirable for consistency checking, so I’ll use another mathematical property to generate random isometries: they are all the composition of three reflections, which may each be the identity, of course.

Reflecting about an arbitrary line is pretty easy: translate so the line passes through the origin, rotate the line onto the horizontal axis, then reflect (sound familiar?). You can read more at Planet Math if you like, or figure out the formulae yourself with some high school trigonometry, or just let the computer compose the functions for you. Because I want to decouple my specifications and implementation, I worked out the formulae directly.

> instance Arbitrary Isometry where
>   arbitrary = do refl1 <- newRefl
>                  refl2 <- newRefl
>                  refl3 <- newRefl
>                  return (Isometry (refl3 . refl2 . refl1))
>       where newRefl = do angle <- arbitrary
>                          yOffset <- arbitrary
>                          return (reflectAbout yOffset angle)
>
> reflectAbout :: Double -> Double -> Map2D
> reflectAbout yOffset angle =
>   translateY yOffset . reflectRotate angle . translateY (-yOffset)
>     where translateY dy (x,y) = (x,y+dy)
>           reflectRotate angle (x,y) = (x * cos (2*angle) + y * sin (2*angle),
>                                        x * sin (2*angle) - y * cos (2*angle))

And we can use QuickCheck to test our generator. (This caught a typo in reflectAbout)

> prop_Isometry :: Isometry -> Point2D -> Point2D -> Bool
> prop_Isometry (Isometry f) p1 p2 =  distsq p1 p2 =~= distsq (f p1) (f p2)
>   where distsq (x,y) (x',y') = (x-x')**2 + (y-y')**2

Then the statement of correctness for the entire algorithm is:

> prop_NF :: Isometry -> Point2D -> Bool
> prop_NF f'@(Isometry f) (x,y)  =  f (x,y) =~= apply (normalForm f') (x,y)

And normalForm should also be the identity on normal forms, to check that I’ve written apply correctly. A lot of these properties overlap so they fail together, but it doesn’t hurt to have a lot of properties.

> prop_NFNF nf (x,y)  =  apply nf (x,y) =~= 
>                        apply (normalForm $ Isometry $ apply nf) (x,y)

The QuickCheck page has a script to run your tests in hugs, but I had to edit it somewhat to run it on my machine. In case you don’t want to do that, this file can just be compiled and run. Either way you run the checks, then you should see something like this:

*Main> prop_translation: OK, passed 100 tests.
*Main> prop_tInv: OK, passed 100 tests.
*Main> prop_rotation: OK, passed 100 tests.
*Main> prop_sInv: OK, passed 100 tests.
*Main> prop_reflection: OK, passed 100 tests.
*Main> prop_rInv: OK, passed 100 tests.
*Main> prop_Isometry: OK, passed 100 tests.
*Main> prop_NF: OK, passed 100 tests.
*Main> prop_NFNF: OK, passed 100 tests.

Below here is just boilerplate — end of commentary.

> main = do check ("prop_translation", prop_translation)
>           check ("prop_tInv", prop_tInv)
>           check ("prop_rotation", prop_rotation)
>           check ("prop_sInv", prop_sInv)
>           check ("prop_reflection", prop_reflection)
>           check ("prop_rInv", prop_rInv)
>           check ("prop_Isometry", prop_Isometry)
>           check ("prop_NF", prop_NF)
>           check ("prop_NFNF", prop_NFNF)
>           
>   where check (name,prop) = do putStr (name ++ ": ")
>                                quickCheck prop
>
> instance Arbitrary Translation where 
>   arbitrary = do dx <- arbitrary
>                  dy <- arbitrary
>                  return (Translate (dx,dy))
>
> instance Arbitrary Rotation where
>   arbitrary = do angle <- arbitrary
>                  return (Rotate angle)
>
> instance Arbitrary Reflection where
>   arbitrary = do refl <- arbitrary 
>                  return (Reflect refl)
>
> instance ApproxEq Rotation where
>   (Rotate a) =~= (Rotate a')  =  a =~= a'
>
> instance Show Isometry where
>   show = show . normalForm -- cheating!
>
> class ApproxEq a where
>   (=~=) :: a -> a -> Bool
>
> instance (ApproxEq a, ApproxEq b) => ApproxEq (a,b) where
>   (x,y) =~= (x',y')  =  (x =~= x') && (y =~= y') 
>     where epsilon = 0.001
>
> instance ApproxEq Double where
>   x =~= x'  =  (abs (x-x') < epsilon)
>     where epsilon = 0.001

This post is a valid literate Haskell file so save it to something like ConvexHull.lhs and compile with ghc --make ConvexHull. What you see above is what you’ll get when you run ./ConvexHull

The best OpenGL tutorial for Haskell that I’ve found is this one from Michi’s blog, using GLUT to interface with X. For this tutorial we are going to use the Gtk GLDrawingArea widget, to illustrate the differences, which can be rather hard to find in the documentation.

The libraries used can be found here:

• Haskell OpenGL
• Gtk2hs

> import Data.IORef
> import Data.List
> import Graphics.Rendering.OpenGL as GL
> import Graphics.UI.Gtk as Gtk
> import Graphics.UI.Gtk.OpenGL
> import System.Random

I’ll show main first. If you are just looking for the outline of how to initialize everything and make it go, here it is:

> main = do
>   initGUI
>   glConfig <- glConfigNew [GLModeRGBA, GLModeDouble]
>   initGL
>   
>   pointRef <- (randomPoints 15 >>= newIORef)
>
>   canvas  <- glDrawingAreaNew glConfig
>   onExpose canvas (\_ -> readIORef pointRef >>= drawWithHull canvas)
>
>
>   button <- buttonNew
>   Gtk.set button [ buttonLabel := "Generate new points." ]
>   onClicked button (do newPoints <- randomPoints 15
>                        writeIORef pointRef newPoints
>                        drawWithHull canvas newPoints
>                        return ())
>
>   vbox <- vBoxNew False 0
>   boxPackStart vbox button PackNatural 0
>   boxPackStart vbox canvas PackGrow 0
>
>   window <- windowNew
>   Gtk.set window [ containerBorderWidth := 10,
>                    containerChild := vbox ]
>   onDestroy window mainQuit
>
>   widgetShowAll window
>   mainGUI              

Now, Haskell’s OpenGL binding has some quirks with regards to numeric overloading, so it helps to define some type aliases. Since I want to take cross products I’ll work in three dimensions, and define some basic operations on my points. The OpenGL binding has separate types for points and vectors, but I’m going to abuse the point type to represent both.

> type Point3 = Vertex3 GLfloat

> cross :: Point3 -> Point3 -> Point3
> cross (Vertex3 x0 y0 z0) (Vertex3 x1 y1 z1) = 
>    Vertex3 (y0*z1 - z0*y1) (z1*x0 - x0*z1) (x0*y1 - x1*y0)

> dot :: Point3 -> Point3 -> GLfloat
> dot (Vertex3 x0 y0 z0) (Vertex3 x1 y1 z1) = x0*x1 + y0*y1 + z0*z1

> randomPoints :: Int -> IO [Point3]
> randomPoints 0 = return []
> randomPoints n = do 
>   x <- randomRIO (-0.9,0.9) -- chosen to fit in the OpenGL window
>   y <- randomRIO (-0.9,0.9)
>   rest <- randomPoints (n - 1)
>   return $ Vertex3 x y 0 : rest

Now for the quirks with using Gtk for OpenGL – there are many more setup calls to make. First, you need to explicitly grab a graphics context (glContext) and GL drawing window (glWin). Then, we manage the viewport manually to scale our rendering up to fill the window. Finally, there are Gtk calls to start and end OpenGL rendering calls. It took me a while to discover them.

> drawWithHull :: GLDrawingArea -> [Point3] -> IO Bool
> drawWithHull canvas points = do
>
>   -- This is all Gtk code, managing the internal structures
>   glContext <- glDrawingAreaGetGLContext canvas
>   glWin <- glDrawingAreaGetGLWindow canvas
>   (w,h) <- glDrawableGetSize glWin
>
>   -- This is again Gtk code
>   glDrawableGLBegin glWin glContext
>
>   -- These are OpenGL calls to scale up and use the whole canvas
>   (pos, _) <- GL.get viewport
>   viewport $= (pos, Size (fromIntegral w) (fromIntegral h))
>
>   renderWithHull points
>   GL.flush -- except this
>   glDrawableSwapBuffers glWin
>   glDrawableGLEnd glWin
>   return True

I use the terminology “draw” to refer to Gtk drawing code, which tends to be bookkeeping, while I use “render” to refer to sequences of OpenGL calls. Here is the code to actually render the points and their convex hull. Note the color3f specialization, to help the type inferencer.

> renderWithHull :: [Point3] -> IO ()
> renderWithHull points = do
>   clear [ColorBuffer]
>   color3f (Color3 1 1 1)
>   renderPrimitive Quads $ mapM_ fatPoint $ points
>   color3f (Color3 1 0 0)
>   renderPrimitive LineStrip $ mapM_ vertex $ hull
>     where hull = convexHull points
>           color3f = color :: Color3 GLfloat -> IO ()

> fatPoint (Vertex3 x y z) = do 
>   vertex $ Vertex3 (x+0.005) (y+0.005) z
>   vertex $ Vertex3 (x-0.005) (y+0.005) z
>   vertex $ Vertex3 (x-0.005) (y-0.005) z
>   vertex $ Vertex3 (x+0.005) (y-0.005) z

From here on, I’m just implementing the convex hull algorithm.

This is an iterative algorithm that computes the upper half-hull by travelling left-to-right across the plane making sure to always make right turns; if ever a left turn occurs, it backtracks as far as necessary, patching up the hull. I defer the obvious helper isLeftOf to the end of the file.

> upperHalfHull points = upperHalfHull' (sort points) []
>    where upperHalfHull' [] hull = hull
>          upperHalfHull' (v:vs) [] = upperHalfHull' vs [v]
>          upperHalfHull' (v:vs) [y] = upperHalfHull' vs [v,y]
>          upperHalfHull' (v:vs) (y:x:zs) = if v `isLeftOf` (x,y)
>                                           then upperHalfHull' (v:vs) (x:zs)
>                                           else upperHalfHull' vs (v:y:x:zs)

Then the lower half of the hull does the same thing right-to-left, and I rather naively combine them into convexHull (I traverse the points maybe three times unneccessarily)

> lowerHalfHull points = map rotate180 $ upperHalfHull $ map rotate180 $ points
> rotate180 (Vertex3 x y z) = Vertex3 (-x) (-y) z

> convexHull :: [Point3] -> [Point3]
> convexHull points = upperHalfHull points ++ lowerHalfHull points

There is a divide-and-conquer algorithm which is probably more idiomatic, and has the same asymptotic complexity (different pathological cases) but this is the one I was trying out.

This last helper function only makes sense when points are all on the z=0 plane. It takes a point and a directed line segment, and indicates whether the point lies to the left of the line defined by that segment.

> isLeftOf :: Point3 -> (Point3, Point3) -> Bool
> isLeftOf (Vertex3 x2 y2 _) (Vertex3 x0 y0 _, Vertex3 x1 y1 _) =
>   let Vertex3 _ _ z = (Vertex3 (x1-x0) (y1-y0) 0) 
>                       `cross` 
>                       (Vertex3 (x2-x0) (y2-y0) 0) 
>   in z > 0