DC.hs

import Control.Monad.Cont

runC :: Cont w w -> w
runC m = runCont m id

reset :: Cont a a -> Cont w a
reset = return . runC

shift :: ((a -> w) -> Cont w w) -> Cont w a
shift f = cont (runC . f)

-- examples

product' :: [Int] -> Int
product' l = runC $ reset $ go l where
  go :: [Int] -> Cont Int Int
  go [] = return 1
  go (0:_) = shift $ \_ -> return 0
  go (x:xs) = (x*) <$> go xs

example1 :: Int -> Int
example1 n = runC $ reset $ (\x -> 3 + x - 1) <$> shift (\k -> return $ k n)

-- tree

data Tree = Empty | Node Tree Int Tree deriving (Show)
data Result a = Done | Next a (Result a) deriving (Show)

yield :: a -> Cont (Result a) ()
yield n = shift $ \k -> return $ Next n (k ())

walk :: Tree -> IO ()
walk Empty = return ()
walk (Node t1 n t2) = walk t1 >> print n >> walk t2

walk' :: Tree -> Cont (Result Int) ()
walk' Empty = return ()
walk' (Node t1 n t2) = walk' t1 >> yield n >> walk' t2

start :: Tree -> Result Int
start t = runC $ reset $ (walk' t >> return Done)

printNode :: Tree -> IO ()
printNode t = go $ start t where
  go Done = return ()
  go (Next n k) = print n >> go k

addTree :: Tree -> Int
addTree t = go $ start t where
  go Done = 0
  go (Next n k) = n + go k

sameFringe :: Tree -> Tree -> Bool
sameFringe t1 t2 = go (start t1) (start t2) where
  go Done Done = True
  go (Next n1 k1) (Next n2 k2)
    | n1 == n2 = go k1 k2
    | otherwise = False
  go _ _ = False

-- state monad

get :: () -> Cont (a -> w) a
get () = shift $ \k -> return $ \state -> k state state

put :: a -> Cont (a -> w) ()
put x = shift $ \k -> return $ \_ -> k () x

runState :: Cont (Int -> t) (Int -> t) -> t
runState k = ($ 0) $ runC $ reset $ k

tick :: () -> Cont (Int -> t) ()
tick () = shift $ \k -> return $ \state -> k () (state + 1)

example2 :: Int
example2 = runState $ do
  tick ()
  tick ()
  a <- get ()
  tick ()
  b <- get ()
  return $ const $ b - a

example3 :: (Int,Int,Int)
example3 = runState $ do
  a <- get ()
  tick ()
  tick ()
  b <- get ()
  put 20
  c <- get ()
  return $ const $ (a,b,c)

-- backtracking

either' :: (Monad m) => a -> a -> Cont (m b) a
either' a b = shift $ \k -> return $ k a >> k b

example4 :: IO ()
example4 = runC $ reset $ let x = either' 0 1 in print <$> x

-- generate and test

-- example5 :: IO ()
-- example5 = runC $ reset $ do
--   let p = either' True False
--   let q = either' True False
--   p' <- p
--   q' <- q
--   if ((p' || q') && (p' || not q') && (not p' || not q'))
--     then do
--       p' <- p
--       q' <- q
--       (putStrLn . (\_ -> "p:" ++ show p' ++ ", q:" ++ show q')) <$> p
--     else return $ return ()

main = do
  -- 10
  -- print $ runC $ reset $ (\x -> 3 + x - 1) <$> shift (\_ -> return $ 5*2)

  -- 9
  -- print $ runC $ (subtract 1) <$> (reset $ (3 +) <$> shift (\_ -> return $ 5*2))

  -- 12
  -- print $ example1 10

  -- let tree1 = Node (Node Empty 1 Empty) 2 (Node Empty 3 Empty)
  -- let tree2 = Node Empty 1 (Node Empty 2 (Node Empty 3 Empty))
  -- 1 2 3
  -- walk tree1
  -- printNode tree1

  -- 6
  -- print $ addTree tree1

  -- True
  -- print $ sameFringe tree1 tree2

  -- 1
  -- print $ example2

  -- (0,2,20)
  -- print $ example3

  -- 0 1
  -- example4

  -- example5

  return ()