- Added loop synthesis.

- Some refactoring.

3 files changed, 167 insertions, 3 deletions

diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux
index 7c4776727..6ad7ed634 100644
--- a/new-luxc/test/test/luxc/synthesizer/function.lux
+++ b/new-luxc/test/test/luxc/synthesizer/function.lux
@@ -13,14 +13,13 @@
        test)
   (luxc (lang ["la" analysis]
               ["ls" synthesis])
-        (analyser [";A" structure])
         [synthesizer]
         (synthesizer ["&&;" function]))
   (.. common))
 
 (def: (reference var)
   (-> ls;Variable Ref)
-  (if (&&function;captured-var? var)
+  (if (&&function;captured? var)
     (#;Captured (|> var (i.* -1) int-to-nat n.dec))
     (#;Local (int-to-nat var))))
 
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
new file mode 100644
index 000000000..b89e09659
--- /dev/null
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -0,0 +1,164 @@
+(;module:
+  lux
+  (lux [io]
+       (control monad)
+       (data [bool "B/" Eq<Bool>]
+             [number]
+             (coll [list "L/" Functor<List> Fold<List>]
+                   ["s" set])
+             text/format)
+       ["r" math/random "r/" Monad<Random>]
+       test)
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])
+        [synthesizer]
+        (synthesizer ["&&;" loop]))
+  (.. common))
+
+(def: (does-recursion? arity exprS)
+  (-> ls;Arity ls;Synthesis Bool)
+  (loop [exprS exprS]
+    (case exprS
+      (#ls;Case inputS pathS)
+      (loop [pathS pathS]
+        (case pathS
+          (#ls;AltP leftS rightS)
+          (or (recur leftS)
+              (recur rightS))
+
+          (#ls;SeqP leftS rightS)
+          (recur rightS)
+          
+          (#ls;ExecP bodyS)
+          (does-recursion? arity bodyS)
+          
+          _
+          false))
+
+      (#ls;Recur argsS)
+      (n.= arity (list;size argsS))
+
+      (#ls;Let register inputS bodyS)
+      (recur bodyS)
+
+      (#ls;If inputS thenS elseS)
+      (or (recur thenS)
+          (recur elseS))
+
+      _
+      false
+      )))
+
+(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 (|>. #la;Nat)))
+                         num-cases (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+                         tests (|> (r;set number;Hash<Nat> num-cases r;nat)
+                                   (:: @ map (|>. s;to-list (L/map (|>. #la;NatP)))))
+                         #let [bad-bodies (list;repeat num-cases #la;Unit)]
+                         good-body (gen-body arity output)
+                         where-to-set (|> r;nat (:: @ map (n.% num-cases)))
+                         #let [bodies (list;concat (list (list;take where-to-set bad-bodies)
+                                                         (list good-body)
+                                                         (list;drop (n.inc where-to-set) bad-bodies)))]]
+                        (wrap (#ls;Case inputA
+                                        (list;zip2 tests bodies)))))
+            (r;either (do r;Monad<Random>
+                        [valueS r;bool
+                         output' (gen-body (n.inc arity) output)]
+                        (wrap (#la;Case (#la;Bool valueS) (list [(#la;BindP arity) output']))))
+                      (do r;Monad<Random>
+                        [valueS r;bool
+                         then|else r;bool
+                         output' (gen-body arity output)
+                         #let [thenA (if then|else output' #ls;Unit)
+                               elseA (if (not then|else) output' #ls;Unit)]]
+                        (wrap (#la;Case (#la;Bool valueS)
+                                        (list [(#la;BoolP then|else) thenA]
+                                              [(#la;BoolP (not then|else)) elseA])))))
+            ))
+
+(def: (make-apply func args)
+  (-> la;Analysis (List la;Analysis) la;Analysis)
+  (L/fold (function [arg' func']
+            (#la;Apply arg' func'))
+          func
+          args))
+
+(def: (make-function arity body)
+  (-> ls;Arity la;Analysis la;Analysis)
+  (case arity
+    +0 body
+    _ (#la;Function {#;name     (list)
+                     #;inner    +0
+                     #;locals   {#;counter +0 #;mappings (list)}
+                     #;captured {#;counter +0 #;mappings (list)}}
+                    (make-function (n.dec arity) body))))
+
+(def: gen-recursion
+  (r;Random [Bool Nat la;Analysis])
+  (do r;Monad<Random>
+    [arity (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+     recur? r;bool
+     outputS (if recur?
+               (wrap (make-apply (#la;Relative (#;Local +0))
+                                 (list;repeat arity #la;Unit)))
+               (do @
+                 [plus-or-minus? r;bool
+                  how-much (|> r;nat (:: @ map (|>. (n.% arity) (n.max +1))))
+                  #let [shift (if plus-or-minus? n.+ n.-)]]
+                 (wrap (make-apply (#la;Relative (#;Local +0))
+                                   (list;repeat (shift how-much arity) #la;Unit)))))
+     bodyS (gen-body arity outputS)]
+    (wrap [recur? arity (make-function arity bodyS)])))
+
+(def: gen-loop
+  (r;Random [Bool Nat la;Analysis])
+  (do r;Monad<Random>
+    [arity (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+     recur? r;bool
+     self-ref? r;bool
+     #let [selfA (#la;Relative (#;Local +0))
+           argA (if self-ref? selfA #la;Unit)]
+     outputS (if recur?
+               (wrap (make-apply selfA (list;repeat arity argA)))
+               (do @
+                 [plus-or-minus? r;bool
+                  how-much (|> r;nat (:: @ map (|>. (n.% arity) (n.max +1))))
+                  #let [shift (if plus-or-minus? n.+ n.-)]]
+                 (wrap (make-apply selfA (list;repeat (shift how-much arity) argA)))))
+     bodyS (gen-body arity outputS)]
+    (wrap [(and recur? (not self-ref?))
+           arity
+           (make-function arity bodyS)])))
+
+(test: "Recursion."
+  [[prediction arity analysis] gen-recursion]
+  ($_ seq
+      (assert "Can accurately identify (and then reify) tail recursion."
+              (case (synthesizer;synthesize analysis)
+                (#ls;Function _arity _env _body)
+                (|> _body
+                    (does-recursion? arity)
+                    (B/= prediction)
+                    (and (n.= arity _arity)))
+
+                _
+                false))))
+
+(test: "Loop."
+  [[prediction arity analysis] gen-recursion]
+  ($_ seq
+      (assert "Can reify loops."
+              (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit)))
+                (#ls;Loop _register _inits _body)
+                (and (n.= arity (list;size _inits))
+                     (not (&&loop;contains-self-reference? _body)))
+
+                (#ls;Call (#ls;Function _arity _env _bodyS) argsS)
+                (&&loop;contains-self-reference? _bodyS)
+
+                _
+                false))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 114768c2d..30a8ec522 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -15,7 +15,8 @@
               (synthesizer ["_;S" primitive]
                            ["_;S" structure]
                            ["_;S" function]
-                           ["_;S" procedure]))))
+                           ["_;S" procedure]
+                           ["_;S" loop]))))
 
 ## [Program]
 (program: args