blob: 63ad3a395aab9970fe44c9f19b2ed777ea9b26f2 (
plain)
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
|
(.module:
lux
(lux [io]
(control [monad #+ do])
(data [bit "bit/" Eq<Bit>]
[number]
(coll [list "list/" Functor<List> Fold<List>]
(set ["set" unordered]))
text/format)
(macro [code])
["r" math/random "r/" Monad<Random>]
test)
(luxc (lang ["la" analysis]
["ls" synthesis]
(synthesis [".S" expression]
[".S" loop])
[".L" extension]))
(// common))
(def: (does-recursion? arity exprS)
(-> ls.Arity ls.Synthesis Bit)
(loop [exprS exprS]
(case exprS
(^ [_ (#.Form (list [_ (#.Text "lux case")] inputS pathS))])
(loop [pathS pathS]
(case pathS
(^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftS rightS))])
(or (recur leftS)
(recur rightS))
(^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftS rightS))])
(recur rightS)
(^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
(does-recursion? arity bodyS)
_
#0))
(^ [_ (#.Form (list& [_ (#.Text "lux recur")] argsS))])
(n/= arity (list.size argsS))
(^ [_ (#.Form (list [_ (#.Text "lux let")] register inputS bodyS))])
(recur bodyS)
(^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))])
(or (recur thenS)
(recur elseS))
_
#0
)))
(def: (gen-body arity output)
(-> Nat la.Analysis (r.Random la.Analysis))
(r.either (r.either (r/wrap output)
(do r.Monad<Random>
[inputA (|> r.nat (:: @ map code.nat))
num-cases (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
tests (|> (r.set number.Hash<Nat> num-cases r.nat)
(:: @ map (|>> set.to-list (list/map code.nat))))
#let [bad-bodies (list.repeat num-cases (' []))]
good-body (gen-body arity output)
where-to-set (|> r.nat (:: @ map (n/% num-cases)))
#let [bodies (list.joined (list (list.first where-to-set bad-bodies)
(list good-body)
(list.after (n/inc where-to-set) bad-bodies)))]]
(wrap (` ("lux case" (~ inputA)
(~ (code.record (list.zip2 tests bodies))))))))
(r.either (do r.Monad<Random>
[valueS r.bit
output' (gen-body (n/inc arity) output)]
(wrap (` ("lux case" (~ (code.bit valueS))
{("lux case bind" (~ (code.nat arity))) (~ output')}))))
(do r.Monad<Random>
[valueS r.bit
then|else r.bit
output' (gen-body arity output)
#let [thenA (if then|else output' (' []))
elseA (if (not then|else) output' (' []))]]
(wrap (` ("lux case" (~ (code.bit valueS))
{(~ (code.bit then|else)) (~ thenA)
(~ (code.bit (not then|else))) (~ elseA)})))))
))
(def: (make-function arity body)
(-> ls.Arity la.Analysis la.Analysis)
(case arity
+0 body
_ (` ("lux function" [] (~ (make-function (n/dec arity) body))))))
(def: gen-recursion
(r.Random [Bit Nat la.Analysis])
(do r.Monad<Random>
[arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
recur? r.bit
outputS (if recur?
(wrap (la.apply (list.repeat arity (' [])) (la.var 0)))
(do @
[plus-or-minus? r.bit
how-much (|> r.nat (:: @ map (|>> (n/% arity) (n/max +1))))
#let [shift (if plus-or-minus? n/+ n/-)]]
(wrap (la.apply (list.repeat (shift how-much arity) (' [])) (la.var 0)))))
bodyS (gen-body arity outputS)]
(wrap [recur? arity (make-function arity bodyS)])))
(def: gen-loop
(r.Random [Bit Nat la.Analysis])
(do r.Monad<Random>
[arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
recur? r.bit
self-ref? r.bit
#let [selfA (la.var 0)
argA (if self-ref? selfA (' []))]
outputS (if recur?
(wrap (la.apply (list.repeat arity argA) selfA))
(do @
[plus-or-minus? r.bit
how-much (|> r.nat (:: @ map (|>> (n/% arity) (n/max +1))))
#let [shift (if plus-or-minus? n/+ n/-)]]
(wrap (la.apply (list.repeat (shift how-much arity) (' [])) selfA))))
bodyS (gen-body arity outputS)]
(wrap [(and recur? (not self-ref?))
arity
(make-function arity bodyS)])))
(context: "Recursion."
(<| (times +100)
(do @
[[prediction arity analysis] gen-recursion]
($_ seq
(test "Can accurately identify (and then reify) tail recursion."
(case (expressionS.synthesize extensionL.no-syntheses
analysis)
(^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat _arity)] [_ (#.Tuple _env)] _body))])
(|> _body
(does-recursion? arity)
(bit/= prediction)
(and (n/= arity _arity)))
_
#0))))))
(context: "Loop."
(<| (times +100)
(do @
[[prediction arity analysis] gen-recursion]
($_ seq
(test "Can reify loops."
(case (expressionS.synthesize extensionL.no-syntheses
(la.apply (list.repeat arity (' [])) analysis))
(^ [_ (#.Form (list [_ (#.Text "lux loop")] [_ (#.Nat in_register)] [_ (#.Tuple _inits)] _body))])
(and (n/= arity (list.size _inits))
(not (loopS.contains-self-reference? _body)))
(^ [_ (#.Form (list& [_ (#.Text "lux call")]
[_ (#.Form (list [_ (#.Text "lux function")] _arity _env _bodyS))]
argsS))])
(loopS.contains-self-reference? _bodyS)
_
#0))))))
|
