Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 95 lines (70 sloc) 3.677 kb
681336e Max Bolingbroke Initial commit of katas
authored
1 {-# LANGUAGE GADTs, Rank2Types #-}
2 import Control.Applicative
3
4
5 -- data ApplicativeTree a where
6 -- Pure :: a -> ApplicativeTree a
7 -- Star :: ApplicativeTree (b -> a) -> ApplicativeTree b -> ApplicativeTree a
8 --
9 -- evaluate :: Applicative f => ApplicativeTree a -> f a
10 -- evaluate (Pure x) = pure x
11 -- evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2
12
13 data List a where
14 Nil :: List a
15 Cons :: a -> List a -> List a
16
17 data ZList a where
18 StopList :: List a -> ZList a
19 Down :: a -> ZList a -> ZList a
20
21 reverseConcatList :: List a -> List a -> List a
22 reverseConcatList Nil ys = ys
23 reverseConcatList (Cons x xs) ys = reverseConcatList xs (Cons x ys)
24
25 startList :: List a -> (List a, ZList a)
26 startList xs = (xs, StopList Nil)
27
28 rebuildList :: List a -> ZList a -> List a
29 rebuildList xs (StopList ys) = reverseConcatList ys xs
30 rebuildList xs (Down x zl) = rebuildList (Cons x xs) zl
31
32 down :: List a -> ZList a -> (List a, ZList a)
33 down (Cons x xs) zl = (xs, Down x zl)
34
35
36 data Tree a where
37 Leaf :: a -> Tree a
38 Branch :: Tree a -> Tree a -> Tree a
39
40 data ZTree a where
41 StopTree :: ZTree a
42 RightTree :: Tree a -> ZTree a -> ZTree a
43 LeftTree :: ZTree a -> Tree a -> ZTree a
44
45 startTree :: Tree a -> (Tree a, ZTree a)
46 startTree t = (t, StopTree)
47
48 rebuildTree :: Tree a -> ZTree a -> Tree a
49 rebuildTree t StopTree = t
50 rebuildTree t (RightTree tl ztr) = rebuildTree (Branch tl t) ztr
51 rebuildTree t (LeftTree ztl tr) = rebuildTree (Branch t tr) ztl
52
53 leftTree :: Tree a -> ZTree a -> (Tree a, ZTree a)
54 leftTree (Branch tl tr) zt = (tl, LeftTree zt tr)
55
56
57 -- Free algebra on the Applicative typeclass, plus an "Unexpanded" injection from the standard type
58 data ApplicativeTree f a where
59 Unexpanded :: f a -> ApplicativeTree f a
60 Pure :: a -> ApplicativeTree f a
61 Star :: ApplicativeTree f (b -> a) -> ApplicativeTree f b -> ApplicativeTree f a
62
63 evaluate :: Applicative f => ApplicativeTree f a -> f a
64 evaluate (Unexpanded fx) = fx
65 evaluate (Pure x) = pure x
66 evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2
67
68
69 -- GADT zipper. What the hell do these types mean?? I derived them by performing unification on the "rebuild" algorithm
70 -- with pencil and paper, so the definitions typechecked. But I have idea what the types really *mean*.
71 --
72 -- Perhaps:
73 -- zt :: ZApplicativeTree f a a'
74 -- If (zt) *consumes* an (ApplicativeTree f a) to produce an (ApplicativeTree f a')
75 data ZApplicativeTree f a a' where
76 StopApplicativeTree :: ZApplicativeTree f a a
77 RightApplicativeTree :: ApplicativeTree f (b -> a) -> ZApplicativeTree f a a' -> ZApplicativeTree f b a'
78 LeftApplicativeTree :: ZApplicativeTree f b a' -> ApplicativeTree f a -> ZApplicativeTree f (a -> b) a'
79
80 startApplicativeTree :: ApplicativeTree f a -> (ApplicativeTree f a, ZApplicativeTree f a a)
81 startApplicativeTree t = (t, StopApplicativeTree)
82
83 rebuildApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> ApplicativeTree f a'
84 rebuildApplicativeTree t StopApplicativeTree = t
85 rebuildApplicativeTree t (RightApplicativeTree tl ztr) = rebuildApplicativeTree (Star tl t) ztr
86 rebuildApplicativeTree t (LeftApplicativeTree ztl tr) = rebuildApplicativeTree (Star t tr) ztl
87
88 leftApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f (b -> a) -> ZApplicativeTree f (b -> a) a' -> r) -> r
89 leftApplicativeTree (Star tl tr) zt k = k tl (LeftApplicativeTree zt tr)
90
91 rightApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f b -> ZApplicativeTree f b a' -> r) -> r
92 rightApplicativeTree (Star tl tr) zt k = k tr (RightApplicativeTree tl zt)
93
94
95 main = return ()
Something went wrong with that request. Please try again.