-
Notifications
You must be signed in to change notification settings - Fork 0
/
toy-combos.hs
183 lines (151 loc) · 7.51 KB
/
toy-combos.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
import Prelude hiding (succ)
import Control.Applicative
import Control.Monad.State
data Exp = Zero
| Succ Exp
| Dbl Exp
| Var String
| Lam String Exp
| App Exp Exp
shownum :: Exp -> Maybe Int
shownum Zero = Just 0
shownum (Succ e) = (+1) <$> shownum e
shownum (Dbl e) = (*2) <$> shownum e
shownum _ = Nothing
instance Show Exp where
show e = case shownum e of Just n -> show n; Nothing -> show' e
where show' (Zero) = "0"
show' (Succ e) =
let count :: Exp -> (Maybe Exp, Int)
count (Succ e) =
let (b,n) = count e in (b, n+1)
count (Zero) = (Nothing, 0)
count e = (Just e, 0)
(b, n) = count (Succ e)
in show n ++ case b of Nothing -> ""; Just e -> " + " ++ show e
show' (Dbl e) =
let count :: Exp -> (Maybe Exp, Int)
count (Dbl e) =
let (b,n) = count e in (b, n*2)
count (Zero) = (Nothing, 0)
count e = (Just e, 1)
(b, n) = count (Dbl e)
in show n ++ case b of Nothing -> ""; Just e -> " * " ++ show e
show' (Var s) = s
show' (Lam s e) = "(\\" ++ s ++ "." ++ show e ++ ")"
show' (App e1 (App e2 e3)) = show e1 ++ " (" ++ show e2 ++ " " ++ show e3 ++ ")"
show' (App e1 e2) = show e1 ++ " " ++ show e2
-- left-associative infix app
a $$ b = App a b
-- [e1/x]e2
subst :: Exp -> String -> Exp -> Exp
subst e1 x Zero = Zero
subst e1 x (Succ e) = Succ $ subst e1 x e
subst e1 x (Dbl e) = Dbl $ subst e1 x e
subst e1 x e2@(Var y) = if x == y then e1 else e2
subst e1 x e2@(Lam y e3) = if x == y then e2 else Lam y $ subst e1 x e3
subst e1 x e2@(App e3 e4) = App (subst e1 x e3) (subst e1 x e4)
type Counter a = State Int a
-- eval
eval :: Exp -> Counter Exp
eval (Succ e) = Succ <$> eval e
eval (Dbl e) = Dbl <$> eval e
eval (App e1 e2) =
do e1' <- eval e1
case e1' of
Lam x e1'' ->
do modify (+1)
e2' <- eval e2
eval $ subst e2' x e1''
_ -> error $ "tried to eval " ++ show e1
eval e = return e
-- basic combinators/etc
s = Lam "a" $ Lam "b" $ Lam "c" $ Var "a" $$ Var "c" $$ (Var "b" $$ Var "c")
i = Lam "x" $ Var "x"
t = Lam "x" $ Lam "y" $ Var "x"
f = Lam "x" $ Lam "y" $ Var "y"
-- Interesting combinators below
-- maps [T, I, F, S] to lambdas: \x -> x + [0, 1, 2, 3]
basefour =
let ---- \fx -> succ(fx) // "plus one"
-- a = Lam "f" $ Lam "x" $ Succ $ Var "f" $$ Var "x"
a = s $$ (t $$ (Lam "x" $ Succ $ Var "x")) -- jcreed's version, card-friendly
---- \fx -> succ(succ(fx)) // "plus two"
-- b = Lam "f" $ Lam "x" $ Succ $ Succ $ Var "f" $$ Var "x"
b = s $$ (t $$ (Lam "x" $ Succ $ Succ $ Var "x")) -- .. card-friendly
in Lam "x" $ Var "x" $$ f $$ i $$ (Var "x" $$ (t $$ a) $$ b $$ i)
-- \x y z w -> get 0 w $ quad $ get 0 z $ quad $ get 0 y $ quad $ get 0 x
timecube =
let quad = Dbl . Dbl
in Lam "x" $ Lam "y" $ Lam "z" $ Lam "w" $
App (basefour $$ Var "x") $ quad $
App (basefour $$ Var "y") $ quad $
App (basefour $$ Var "z") $ quad $
App (basefour $$ Var "w") Zero
nums = [
[t, t, t, t], [i, t, t, t], [f, t, t, t], [s, t, t, t], -- 0-15
[t, i, t, t], [i, i, t, t], [f, i, t, t], [s, i, t, t],
[t, f, t, t], [i, f, t, t], [f, f, t, t], [s, f, t, t],
[t, s, t, t], [i, s, t, t], [f, s, t, t], [s, s, t, t],
[t, t, i, t], [i, t, i, t], [f, t, i, t], [s, t, i, t], -- 16-31
[t, i, i, t], [i, i, i, t], [f, i, i, t], [s, i, i, t],
[t, f, i, t], [i, f, i, t], [f, f, i, t], [s, f, i, t],
[t, s, i, t], [i, s, i, t], [f, s, i, t], [s, s, i, t],
[t, t, f, t], [i, t, f, t], [f, t, f, t], [s, t, f, t], -- 32-47
[t, i, f, t], [i, i, f, t], [f, i, f, t], [s, i, f, t],
[t, f, f, t], [i, f, f, t], [f, f, f, t], [s, f, f, t],
[t, s, f, t], [i, s, f, t], [f, s, f, t], [s, s, f, t],
[t, t, s, t], [i, t, s, t], [f, t, s, t], [s, t, s, t], -- 48-63
[t, i, s, t], [i, i, s, t], [f, i, s, t], [s, i, s, t],
[t, f, s, t], [i, f, s, t], [f, f, s, t], [s, f, s, t],
[t, s, s, t], [i, s, s, t], [f, s, s, t], [s, s, s, t],
[t, t, t, i], [i, t, t, i], [f, t, t, i], [s, t, t, i], -- 64-127
[t, i, t, i], [i, i, t, i], [f, i, t, i], [s, i, t, i],
[t, f, t, i], [i, f, t, i], [f, f, t, i], [s, f, t, i],
[t, s, t, i], [i, s, t, i], [f, s, t, i], [s, s, t, i],
[t, t, i, i], [i, t, i, i], [f, t, i, i], [s, t, i, i],
[t, i, i, i], [i, i, i, i], [f, i, i, i], [s, i, i, i],
[t, f, i, i], [i, f, i, i], [f, f, i, i], [s, f, i, i],
[t, s, i, i], [i, s, i, i], [f, s, i, i], [s, s, i, i],
[t, t, f, i], [i, t, f, i], [f, t, f, i], [s, t, f, i],
[t, i, f, i], [i, i, f, i], [f, i, f, i], [s, i, f, i],
[t, f, f, i], [i, f, f, i], [f, f, f, i], [s, f, f, i],
[t, s, f, i], [i, s, f, i], [f, s, f, i], [s, s, f, i],
[t, t, s, i], [i, t, s, i], [f, t, s, i], [s, t, s, i],
[t, i, s, i], [i, i, s, i], [f, i, s, i], [s, i, s, i],
[t, f, s, i], [i, f, s, i], [f, f, s, i], [s, f, s, i],
[t, s, s, i], [i, s, s, i], [f, s, s, i], [s, s, s, i],
[t, t, t, f], [i, t, t, f], [f, t, t, f], [s, t, t, f], -- 128-255
[t, i, t, f], [i, i, t, f], [f, i, t, f], [s, i, t, f],
[t, f, t, f], [i, f, t, f], [f, f, t, f], [s, f, t, f],
[t, s, t, f], [i, s, t, f], [f, s, t, f], [s, s, t, f],
[t, t, i, f], [i, t, i, f], [f, t, i, f], [s, t, i, f],
[t, i, i, f], [i, i, i, f], [f, i, i, f], [s, i, i, f],
[t, f, i, f], [i, f, i, f], [f, f, i, f], [s, f, i, f],
[t, s, i, f], [i, s, i, f], [f, s, i, f], [s, s, i, f],
[t, t, f, f], [i, t, f, f], [f, t, f, f], [s, t, f, f],
[t, i, f, f], [i, i, f, f], [f, i, f, f], [s, i, f, f],
[t, f, f, f], [i, f, f, f], [f, f, f, f], [s, f, f, f],
[t, s, f, f], [i, s, f, f], [f, s, f, f], [s, s, f, f],
[t, t, s, f], [i, t, s, f], [f, t, s, f], [s, t, s, f],
[t, i, s, f], [i, i, s, f], [f, i, s, f], [s, i, s, f],
[t, f, s, f], [i, f, s, f], [f, f, s, f], [s, f, s, f],
[t, s, s, f], [i, s, s, f], [f, s, s, f], [s, s, s, f],
[t, t, t, s], [i, t, t, s], [f, t, t, s], [s, t, t, s],
[t, i, t, s], [i, i, t, s], [f, i, t, s], [s, i, t, s],
[t, f, t, s], [i, f, t, s], [f, f, t, s], [s, f, t, s],
[t, s, t, s], [i, s, t, s], [f, s, t, s], [s, s, t, s],
[t, t, i, s], [i, t, i, s], [f, t, i, s], [s, t, i, s],
[t, i, i, s], [i, i, i, s], [f, i, i, s], [s, i, i, s],
[t, f, i, s], [i, f, i, s], [f, f, i, s], [s, f, i, s],
[t, s, i, s], [i, s, i, s], [f, s, i, s], [s, s, i, s],
[t, t, f, s], [i, t, f, s], [f, t, f, s], [s, t, f, s],
[t, i, f, s], [i, i, f, s], [f, i, f, s], [s, i, f, s],
[t, f, f, s], [i, f, f, s], [f, f, f, s], [s, f, f, s],
[t, s, f, s], [i, s, f, s], [f, s, f, s], [s, s, f, s],
[t, t, s, s], [i, t, s, s], [f, t, s, s], [s, t, s, s],
[t, i, s, s], [i, i, s, s], [f, i, s, s], [s, i, s, s],
[t, f, s, s], [i, f, s, s], [f, f, s, s], [s, f, s, s],
[t, s, s, s], [i, s, s, s], [f, s, s, s], [s, s, s, s]
]
nums' = map (\[x,y,z,w] -> runState (eval $ timecube $$ x $$ y $$ z $$ w) 0) nums