Permalink
Browse files

Initial commit of katas

  • Loading branch information...
batterseapower committed Jun 29, 2010
0 parents commit 681336e93854ff95d7d6e550cdeb9ee77fdbe9db
Showing with 926 additions and 0 deletions.
  1. +86 −0 ANormalisation.hs
  2. +69 −0 ArrayTraversal.hs
  3. +19 −0 BeautifulFolding.hs
  4. +43 −0 CodensitySet.hs
  5. +15 −0 Cont.hs
  6. +95 −0 GADTZipper.hs
  7. +103 −0 IdiomNormalisation.hs
  8. +115 −0 ListMonads.hs
  9. +265 −0 Mother.hs
  10. +97 −0 OperationalSearchApplicative.hs
  11. +19 −0 YonedaIsFunctor.coq
@@ -0,0 +1,86 @@
+{-# LANGUAGE RankNTypes #-}
+import Text.PrettyPrint.HughesPJClass
+
+import Data.Supply
+
+import System.IO.Unsafe
+
+import Control.Monad.State
+
+
+type UniqM = State (Supply Int)
+
+uniqSupply :: Supply Int
+uniqSupply = unsafePerformIO $ newSupply 0 (+1)
+
+runUniq :: UniqM a -> a
+runUniq = flip evalState uniqSupply
+
+unique :: UniqM Int
+unique = get >>= \s -> let (s1, s2) = split2 s in put s2 >> return (supplyValue s1)
+
+
+-- -- Codensity is the "mother of all monads":
+--
+-- -- return :: forall b. b -> m b
+-- -- (>>=) :: forall a. m a -> (forall b. (a -> m b) -> m b)
+-- --
+-- -- return a >>= f = f a -- Left identity
+-- -- m >>= return = m -- Right identity
+-- -- (m >>= f) >>= g = m >>= (\x -> f x >>= g) -- Associativity
+-- newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b }
+--
+-- liftCodensity :: Monad m => m a -> Codensity m a
+-- liftCodensity m = Codensity ((>>=) m)
+--
+-- lowerCodensity :: Monad m => Codensity m a -> m a
+-- lowerCodensity m = runCodensity m return
+--
+-- instance Functor (Codensity f) where
+-- fmap f m = Codensity (\k -> runCodensity m (k . f))
+--
+-- instance Applicative (Codensity f) where
+-- pure = return
+-- mf <*> mx = Codensity (\k -> runCodensity mf (\f -> runCodensity mx (\x -> k (f x))))
+--
+-- instance Monad (Codensity f) where
+-- return x = Codensity (\k -> k x)
+-- m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))
+
+
+instance Pretty MonadSyn where
+ pPrint = runUniq . pPrintMonadSyn
+
+pPrintMonadSyn (Return e) = return $ text "return" <+> text e
+pPrintMonadSyn (Bind mx fxmy) = do
+ x <- fmap (\i -> "x" ++ show i) unique
+ liftM2 (\dmx dmy -> text "let" <+> text x <+> text "=" <+> dmx $$ text "in" <+> dmy) (pPrintMonadSyn mx) (pPrintMonadSyn (fxmy x))
+pPrintMonadSyn (Foreign e) = return $ text e
+
+
+type Term = String
+
+data MonadSyn = Return Term
+ | Bind MonadSyn (String -> MonadSyn)
+ | Foreign String
+
+normalise :: MonadSyn -> MonadSyn
+normalise m = go m Return
+ where
+ go :: MonadSyn -> (String -> MonadSyn) -> MonadSyn
+ go (Return x) k = k x
+ go (Bind m k) c = go m (\a -> go (k a) c)
+
+ go (Foreign x) k = Bind (Foreign x) k
+
+
+non_normalised = Bind (Return "10") $ \x ->
+ Bind (Bind (Bind (Foreign "get") (\y -> Return y)) (\z -> Bind (Foreign ("put " ++ x)) (\_ -> Return z))) $ \w ->
+ Return w
+
+main = do
+ putStrLn "== Before"
+ print $ pPrint non_normalised
+
+ putStrLn "== After"
+ print $ pPrint $ normalise non_normalised
@@ -0,0 +1,69 @@
+{-# LANGUAGE GADTs, Rank2Types, TupleSections #-}
+import Control.Applicative
+import Control.Arrow ((&&&), (***))
+
+import Data.List
+import Data.Traversable
+
+
+class WriterMonad m where
+ tell :: Int -> m ()
+
+
+newtype DfM a = DfM { unDfM :: ([Int], a) }
+
+instance Functor DfM where
+ fmap f mx = pure f <*> mx
+
+instance Applicative DfM where
+ pure x = DfM ([], x)
+ mf <*> mx = case unDfM mf of (told1, f) -> case unDfM mx of (told2, x) -> DfM (told1 ++ told2, f x)
+
+instance Monad DfM where
+ return x = DfM ([], x)
+ mx >>= fxmy = case unDfM mx of (told1, x) -> case unDfM (fxmy x) of (told2, y) -> DfM (told1 ++ told2, y)
+
+instance WriterMonad DfM where
+ tell x = DfM ([x], ())
+
+
+-- newtype BfM a = BfM { unBfM :: [([Int], a)] }
+--
+-- instance Functor BfM where
+-- fmap f mx = pure f <*> mx
+--
+-- instance Applicative BfM where
+-- pure x = BfM [([], x)]
+-- mf <*> mx = BfM [(told1 ++ told2, f x) | (told1, f) <- unBfM mf, (told2, x) <- unBfM mx]
+--
+-- instance Monad BfM where
+-- return x = BfM [([], x)]
+-- mx >>= fxmy = join (fmap fxmy mx) -- BfM [(told1 ++ told2, y) | (told1, x) <- unBfM mx, (told2, y) <- unBfM (fxmy x)]
+-- where
+-- join :: BfM (BfM a) -> BfM a
+-- join = BfM . (\(told, ys) -> map (told,) ys) . (concat *** concat) . map unzip . map unBfM . unBfM
+--
+-- instance WriterMonad BfM where
+-- tell t = BfM [([t], ())]
+
+
+bitsToNumber :: [Bool] -> Int
+bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0
+
+tHRESHOLD :: Int
+tHRESHOLD = 4
+
+tree :: (Applicative m, Monad m, WriterMonad m) => [Bool] -> m Int
+tree n | length n > tHRESHOLD = return 1
+ | otherwise = tell (bitsToNumber n) >> traverse tree [False : n, True : n] >>= \[n1, n2] -> return (n1 + n2)
+
+
+
+main :: IO ()
+main = do
+ print $ unDfM $ tree [True]
+ --print $ ((concatMap fst &&& map snd) . unBfM) $ tree [True]
+
+-- Depth-first traversal: ([1,2,4,8,9,5,10,11,3,6,12,13,7,14,15],16)
+-- Breadth-first traversal: ([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15],16)
+
@@ -0,0 +1,19 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+-- Data type from Max Rabkin's "Beautiful Folding" (http://squing.blogspot.com/2008/11/beautiful-folding.html):
+-- Fold over list of type |[b]| with result of type |c|
+data Fold b c = forall a. F (a -> b -> a) a (a -> c)
+
+
+-- Data type after existential elimination, Oleg-style:
+data Fold' b c = F' (b -> Fold' b c) c
+
+back :: Fold' b c -> Fold b c
+back f' = F (\(F' x _) b -> x b) f' (\(F' _ y) -> y)
+
+forth :: Fold b c -> Fold' b c
+forth (F x a y) = F' (\b -> forth (F x (x a b) y)) (y a)
+
+
+main :: IO ()
+main = return ()
@@ -0,0 +1,43 @@
+{-# LANGUAGE RankNTypes #-}
+import Control.Applicative
+
+import Data.Set (Set)
+import qualified Data.Set as S
+
+
+newtype CodensityOrd m a = CodensityOrd { runCodensityOrd :: forall b. Ord b => (a -> m b) -> m b }
+
+-- liftCodensityOrd :: Monad m => m a -> CodensityOrd m a
+-- liftCodensityOrd m = CodensityOrd ((>>=) m)
+--
+-- lowerCodensityOrd :: (Ord a, Monad m) => CodensityOrd m a -> m a
+-- lowerCodensityOrd m = runCodensityOrd m return
+
+instance Functor (CodensityOrd f) where
+ fmap f m = CodensityOrd (\k -> runCodensityOrd m (k . f))
+
+instance Applicative (CodensityOrd f) where
+ pure x = CodensityOrd (\k -> k x)
+ mf <*> mx = CodensityOrd (\k -> runCodensityOrd mf (\f -> runCodensityOrd mx (\x -> k (f x))))
+
+instance Monad (CodensityOrd f) where
+ return = pure
+ m >>= k = CodensityOrd (\c -> runCodensityOrd m (\a -> runCodensityOrd (k a) c))
+
+
+liftSet :: Ord a => Set a -> CodensityOrd Set a
+liftSet m = CodensityOrd (bind m)
+ where bind :: (Ord a, Ord b) => Set a -> (a -> Set b) -> Set b
+ mx `bind` fxmy = S.fold (\x my -> fxmy x `S.union` my) S.empty mx
+
+lowerSet :: Ord a => CodensityOrd Set a -> Set a
+lowerSet m = runCodensityOrd m S.singleton
+
+
+main = print $ lowerSet $ monadicPlus (liftSet $ S.fromList [1, 2, 3]) (liftSet $ S.fromList [1, 2, 3])
+
+monadicPlus :: Monad m => m Int -> m Int -> m Int
+monadicPlus mx my = do
+ x <- mx
+ y <- my
+ return (x + y)
15 Cont.hs
@@ -0,0 +1,15 @@
+newtype Cont res a = Cont { unCont :: (a -> res) -> res }
+
+instance Functor (Cont res) where
+ fmap f m = Cont $ \c -> unCont m (c . f)
+
+instance Monad (Cont res) where
+ return a = Cont ($ a)
+ m >>= k = Cont $ \c -> unCont m $ \a -> unCont (k a) c
+
+callCC :: ((a -> Cont res b) -> Cont res a) -> Cont res a
+callCC f = Cont $ \c -> unCont (f (\a -> Cont $ \_ -> c a)) c
+
+
+main :: IO ()
+main = return ()
@@ -0,0 +1,95 @@
+{-# LANGUAGE GADTs, Rank2Types #-}
+import Control.Applicative
+
+
+-- data ApplicativeTree a where
+-- Pure :: a -> ApplicativeTree a
+-- Star :: ApplicativeTree (b -> a) -> ApplicativeTree b -> ApplicativeTree a
+--
+-- evaluate :: Applicative f => ApplicativeTree a -> f a
+-- evaluate (Pure x) = pure x
+-- evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2
+
+data List a where
+ Nil :: List a
+ Cons :: a -> List a -> List a
+
+data ZList a where
+ StopList :: List a -> ZList a
+ Down :: a -> ZList a -> ZList a
+
+reverseConcatList :: List a -> List a -> List a
+reverseConcatList Nil ys = ys
+reverseConcatList (Cons x xs) ys = reverseConcatList xs (Cons x ys)
+
+startList :: List a -> (List a, ZList a)
+startList xs = (xs, StopList Nil)
+
+rebuildList :: List a -> ZList a -> List a
+rebuildList xs (StopList ys) = reverseConcatList ys xs
+rebuildList xs (Down x zl) = rebuildList (Cons x xs) zl
+
+down :: List a -> ZList a -> (List a, ZList a)
+down (Cons x xs) zl = (xs, Down x zl)
+
+
+data Tree a where
+ Leaf :: a -> Tree a
+ Branch :: Tree a -> Tree a -> Tree a
+
+data ZTree a where
+ StopTree :: ZTree a
+ RightTree :: Tree a -> ZTree a -> ZTree a
+ LeftTree :: ZTree a -> Tree a -> ZTree a
+
+startTree :: Tree a -> (Tree a, ZTree a)
+startTree t = (t, StopTree)
+
+rebuildTree :: Tree a -> ZTree a -> Tree a
+rebuildTree t StopTree = t
+rebuildTree t (RightTree tl ztr) = rebuildTree (Branch tl t) ztr
+rebuildTree t (LeftTree ztl tr) = rebuildTree (Branch t tr) ztl
+
+leftTree :: Tree a -> ZTree a -> (Tree a, ZTree a)
+leftTree (Branch tl tr) zt = (tl, LeftTree zt tr)
+
+
+-- Free algebra on the Applicative typeclass, plus an "Unexpanded" injection from the standard type
+data ApplicativeTree f a where
+ Unexpanded :: f a -> ApplicativeTree f a
+ Pure :: a -> ApplicativeTree f a
+ Star :: ApplicativeTree f (b -> a) -> ApplicativeTree f b -> ApplicativeTree f a
+
+evaluate :: Applicative f => ApplicativeTree f a -> f a
+evaluate (Unexpanded fx) = fx
+evaluate (Pure x) = pure x
+evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2
+
+
+-- GADT zipper. What the hell do these types mean?? I derived them by performing unification on the "rebuild" algorithm
+-- with pencil and paper, so the definitions typechecked. But I have idea what the types really *mean*.
+--
+-- Perhaps:
+-- zt :: ZApplicativeTree f a a'
+-- If (zt) *consumes* an (ApplicativeTree f a) to produce an (ApplicativeTree f a')
+data ZApplicativeTree f a a' where
+ StopApplicativeTree :: ZApplicativeTree f a a
+ RightApplicativeTree :: ApplicativeTree f (b -> a) -> ZApplicativeTree f a a' -> ZApplicativeTree f b a'
+ LeftApplicativeTree :: ZApplicativeTree f b a' -> ApplicativeTree f a -> ZApplicativeTree f (a -> b) a'
+
+startApplicativeTree :: ApplicativeTree f a -> (ApplicativeTree f a, ZApplicativeTree f a a)
+startApplicativeTree t = (t, StopApplicativeTree)
+
+rebuildApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> ApplicativeTree f a'
+rebuildApplicativeTree t StopApplicativeTree = t
+rebuildApplicativeTree t (RightApplicativeTree tl ztr) = rebuildApplicativeTree (Star tl t) ztr
+rebuildApplicativeTree t (LeftApplicativeTree ztl tr) = rebuildApplicativeTree (Star t tr) ztl
+
+leftApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f (b -> a) -> ZApplicativeTree f (b -> a) a' -> r) -> r
+leftApplicativeTree (Star tl tr) zt k = k tl (LeftApplicativeTree zt tr)
+
+rightApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f b -> ZApplicativeTree f b a' -> r) -> r
+rightApplicativeTree (Star tl tr) zt k = k tr (RightApplicativeTree tl zt)
+
+
+main = return ()
Oops, something went wrong.

0 comments on commit 681336e

Please sign in to comment.