Collapser

collapser.hs

import Control.Monad (ap, forM_)

-- A bit-string
data Bin
  = O Bin
  | I Bin
  | E

-- A simple DSL with superpositions
data Term
  = Val Int
  | Con Term Term
  | Sup Term Term

data Tree a = Node (Tree a) (Tree a) | Leaf a
data Coll a = Coll { runColl :: Bin -> Tree a }

showTerm :: Term -> String
showTerm (Val x)   = show x
showTerm (Con l r) = "[" ++ showTerm l ++ " " ++ showTerm r ++ "]"
showTerm (Sup a b) = "{" ++ showTerm a ++ " " ++ showTerm b ++ "}"

bind :: Coll a -> (a -> Coll b) -> Coll b
bind (Coll a) f = Coll (\p -> fork (a p) p) where
  fork (Node x y) p = Node (fork x (O p)) (fork y (I p))
  fork (Leaf v)   p = let Coll fv = f v in fv p

instance Functor Tree where
  fmap f (Leaf x)          = Leaf (f x)
  fmap f (Node left right) = Node (fmap f left) (fmap f right)

instance Functor Coll where
  fmap f (Coll g) = Coll (\p -> fmap f (g p))

instance Applicative Coll where
  pure x = Coll (\_ -> Leaf x)
  (<*>)  = ap

instance Monad Coll where
  (>>=) = bind

collapse :: Term -> Coll Term
collapse (Val x) = do
  return $ Val x
collapse (Con l r) = do
  l <- collapse l
  r <- collapse r
  return $ Con l r
collapse (Sup a b) = Coll $ \ p -> case p of
  (O p) -> let (Coll k) = collapse a in k p
  (I p) -> let (Coll k) = collapse b in k p
  E     -> let (Coll l) = collapse a in
           let (Coll r) = collapse b in
           Node (l (O p)) (r (O p))

-- TODO: implement a doCollapse :: Term -> [Term] function

doCollapse :: Term -> [Term]
doCollapse term = flatten $ runColl (collapse term) E where
  flatten :: Tree Term -> [Term]
  flatten (Leaf x)          = [x]
  flatten (Node left right) = flatten left ++ flatten right

main :: IO ()
main = do
  let term = Con (Sup (Val 1) (Val 2)) (Sup (Val 3) (Val 4))
  let coll = doCollapse term
  forM_ coll $ \ term ->
    putStrLn $ showTerm term