- Adjusted compiler to the new lack of Char type.

- WIP: PM/case synthesis.

4 files changed, 229 insertions, 33 deletions

diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 2f7344c6e..484864652 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -2,12 +2,14 @@
   lux
   (lux (data text/format
              [number]
+             [product]
              (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
                    ["d" dict])))
   (luxc ["&" base]
         (lang ["la" analysis]
               ["ls" synthesis])
         (synthesizer ["&&;" structure]
+                     ["&&;" case]
                      ["&&;" function]
                      ["&&;" loop])
         ))
@@ -37,7 +39,6 @@
        [#la;Int      #ls;Int]
        [#la;Deg      #ls;Deg]
        [#la;Real     #ls;Real]
-       [#la;Char     #ls;Char]
        [#la;Text     #ls;Text]
        [#la;Absolute #ls;Definition])
 
@@ -63,6 +64,38 @@
         (#ls;Variable (let [var (&&function;to-captured register)]
                         (default var (d;get var resolver)))))
 
+      (#la;Case inputA branchesA)
+      (let [inputS (recur +0 resolver num-locals inputA)]
+        (case (list;reverse branchesA)
+          (^multi (^ (list [(#la;BindP input-register)
+                            (#la;Relative (#;Local output-register))]))
+                  (n.= input-register output-register))
+          inputS
+
+          (^ (list [(#la;BindP register) bodyA]))
+          (#ls;Let register inputS (recur +0 resolver num-locals bodyA))
+          
+          (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
+               (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
+          (#ls;If inputS
+                  (recur +0 resolver num-locals thenA)
+                  (recur +0 resolver num-locals elseA))
+
+          (#;Cons [lastP lastA] prevsPA)
+          (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
+                                    (function [pattern expr]
+                                      (|> (recur +0 resolver num-locals expr)
+                                          #ls;ExecP
+                                          (#ls;SeqP (&&case;path pattern)))))]
+            (#ls;Case inputS
+                      (L/fold &&case;weave
+                              (transform-branch lastP lastA)
+                              (L/map (product;uncurry transform-branch) prevsPA))))
+
+          _
+          (undefined)
+          ))
+      
       (#la;Function scope bodyA)
       (let [inner-arity (n.inc outer-arity)
             raw-env (&&function;environment scope)
@@ -111,36 +144,4 @@
 
       (#la;Procedure name args)
       (#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
-
-      _
-      (undefined)
-      
-      ## (#la;Case inputA branchesA)
-      ## (let [inputS (recur +0 local-offset false inputA)]
-      ##   (case branchesA
-      ##     (^multi (^ (list [(#lp;Bind input-register)
-      ##                       (#la;Variable (#;Local output-register))]))
-      ##             (n.= input-register output-register))
-      ##     inputS
-
-      ##     (^ (list [(#lp;Bind register) bodyA]))
-      ##     (#ls;Let register inputS (recur +0 local-offset tail? bodyA))
-      
-      ##     (^or (^ (list [(#lp;Bool true) thenA] [(#lp;Bool false) elseA]))
-      ##          (^ (list [(#lp;Bool false) elseA] [(#lp;Bool true) thenA])))
-      ##     (#ls;If inputS
-      ##             (recur +0 local-offset tail? thenA)
-      ##             (recur +0 local-offset tail? elseA))
-
-      ##     (#;Cons [headP headA] tailPA)
-      ##     (let [headP+ (|> (recur +0 local-offset tail? headA)
-      ##                      #ls;ExecP
-      ##                      (#ls;SeqP (&&case;path headP)))
-      ##           tailP+ (L/map (function [[pattern bodyA]]
-      ##                           (|> (recur +0 local-offset tail? bodyA)
-      ##                               #ls;ExecP
-      ##                               (#ls;SeqP (&&case;path pattern))))
-      ##                         tailPA)]
-      ##       (#ls;Case inputS (&&case;weave-paths headP+ tailP+)))
-      ##     ))
       )))
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
new file mode 100644
index 000000000..ee2ef84b0
--- /dev/null
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -0,0 +1,91 @@
+(;module:
+  lux
+  (lux (data [bool "B/" Eq<Bool>]
+             [text "T/" Eq<Text>]
+             [number]
+             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+                   ["s" set])))
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])
+        (synthesizer ["&;" function])))
+
+(def: #export (path pattern)
+  (-> la;Pattern ls;Path)
+  (case pattern
+    (^template [<from> <to>]
+      (<from> register)
+      (<to> register))
+    ([#la;BindP #ls;BindP]
+     [#la;BoolP #ls;BoolP]
+     [#la;NatP  #ls;NatP]
+     [#la;IntP  #ls;IntP]
+     [#la;DegP  #ls;DegP]
+     [#la;RealP #ls;RealP]
+     [#la;TextP #ls;TextP])
+    
+    (#la;TupleP membersP)
+    (case (list;reverse membersP)
+      #;Nil
+      #ls;UnitP
+
+      (#;Cons singletonP #;Nil)
+      (path singletonP)
+
+      (#;Cons lastP prevsP)
+      (let [length (list;size membersP)
+            last-idx (n.dec length)
+            last-path (#ls;TupleP (#;Right last-idx) (path lastP))
+            [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]]
+                                     [(n.dec current-idx)
+                                      (#ls;SeqP (#ls;TupleP (#;Left current-idx)
+                                                            (path current-pattern))
+                                                next-path)])
+                                   [(n.dec last-idx) last-path]
+                                   prevsP)]
+        tuple-path))
+    
+    (#la;VariantP tag num-tags memberP)
+    (let [last? (n.= (n.dec num-tags) tag)]
+      (#ls;VariantP (if last? (#;Right tag) (#;Left tag))
+                    (path memberP)))))
+
+(def: #export (weave nextP prevP)
+  (-> ls;Path ls;Path ls;Path)
+  (with-expansions [<default> (as-is (#ls;AltP prevP nextP))]
+    (case [nextP prevP]
+      [#ls;UnitP #ls;UnitP]
+      #ls;UnitP
+
+      (^template [<tag> <test>]
+        [(<tag> next) (<tag> prev)]
+        (if (<test> next prev)
+          prevP
+          <default>))
+      ([#ls;BindP n.=]
+       [#ls;BoolP B/=]
+       [#ls;NatP  n.=]
+       [#ls;IntP  i.=]
+       [#ls;DegP  d.=]
+       [#ls;RealP r.=]
+       [#ls;TextP T/=])
+
+      (^template [<tag> <side>]
+        [(<tag> (<side> next-idx) next-then) (<tag> (<side> prev-idx) prev-then)]
+        (if (n.= next-idx prev-idx)
+          (weave next-then prev-then)
+          <default>))
+      ([#ls;TupleP   #;Left]
+       [#ls;TupleP   #;Right]
+       [#ls;VariantP #;Left]
+       [#ls;VariantP #;Right])
+
+      [(#ls;SeqP next-pre next-post) (#ls;SeqP prev-pre prev-post)]
+      (case (weave next-pre prev-pre)
+        (#ls;AltP _ _)
+        <default>
+
+        weavedP
+        (#ls;SeqP weavedP (weave next-post prev-post)))
+
+      _
+      <default>)))
diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux
index 42aa7a6cd..e8b2a7ec4 100644
--- a/new-luxc/source/luxc/synthesizer/function.lux
+++ b/new-luxc/source/luxc/synthesizer/function.lux
@@ -44,6 +44,10 @@
   (-> Nat Int)
   (|> idx n.inc nat-to-int (i.* -1)))
 
+(def: #export (captured-idx idx)
+  (-> Int Nat)
+  (|> idx (i.* -1) int-to-nat n.dec))
+
 (def: #export (to-local idx)
   (-> Nat Int)
   (nat-to-int idx))
diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux
new file mode 100644
index 000000000..3a48cb3f2
--- /dev/null
+++ b/new-luxc/source/luxc/synthesizer/variable.lux
@@ -0,0 +1,100 @@
+(;module:
+  lux
+  (lux (data [bool "B/" Eq<Bool>]
+             [text "T/" Eq<Text>]
+             [number]
+             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+                   ["s" set])))
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])
+        (synthesizer ["&;" function])))
+
+(def: (bound-vars path)
+  (-> ls;Path (List ls;Variable))
+  (case path
+    (#ls;BindP register)
+    (list (nat-to-int register))
+
+    (^or (#ls;SeqP pre post) (#ls;AltP pre post))
+    (L/append (bound-vars pre) (bound-vars post))
+    
+    _
+    (list)))
+
+(def: (path-bodies path)
+  (-> ls;Path (List ls;Synthesis))
+  (case path
+    (#ls;ExecP body)
+    (list body)
+
+    (#ls;SeqP pre post)
+    (path-bodies post)
+
+    (#ls;AltP pre post)
+    (L/append (path-bodies pre) (path-bodies post))
+    
+    _
+    (list)))
+
+(def: (non-arg? arity var)
+  (-> ls;Arity ls;Variable Bool)
+  (and (&function;local? var)
+       (n.> arity (int-to-nat var))))
+
+(type: Tracker (s;Set ls;Variable))
+
+(def: init-tracker Tracker (s;new number;Hash<Int>))
+
+(def: (unused-vars current-arity bound exprS)
+  (-> ls;Arity (List ls;Variable) ls;Synthesis (List ls;Variable))
+  (let [tracker (loop [exprS exprS
+                       tracker (L/fold s;add init-tracker bound)]
+                  (case exprS
+                    (#ls;Variable var)
+                    (if (non-arg? current-arity var)
+                      (s;remove var tracker)
+                      tracker)
+                    
+                    (#ls;Variant tag last? memberS)
+                    (recur memberS tracker)
+
+                    (#ls;Tuple membersS)
+                    (L/fold recur tracker membersS)
+
+                    (#ls;Call funcS argsS)
+                    (L/fold recur (recur funcS tracker) argsS)
+                    
+                    (^or (#ls;Recur argsS)
+                         (#ls;Procedure name argsS))
+                    (L/fold recur tracker argsS)
+
+                    (#ls;Let offset inputS outputS)
+                    (|> tracker (recur inputS) (recur outputS))
+
+                    (#ls;If testS thenS elseS)
+                    (|> tracker (recur testS) (recur thenS) (recur elseS))
+
+                    (#ls;Loop offset initsS bodyS)
+                    (recur bodyS (L/fold recur tracker initsS))
+
+                    (#ls;Case inputS outputPS)
+                    (let [tracker' (L/fold s;add
+                                           (recur inputS tracker)
+                                           (bound-vars outputPS))]
+                      (L/fold recur tracker' (path-bodies outputPS)))
+
+                    (#ls;Function arity env bodyS)
+                    (L/fold s;remove tracker env)
+
+                    _
+                    tracker
+                    ))]
+    (s;to-list tracker)))
+
+## (def: (optimize-register-use current-arity [pathS bodyS])
+##   (-> ls;Arity [ls;Path ls;Synthesis] [ls;Path ls;Synthesis])
+##   (let [bound (bound-vars pathS)
+##         unused (unused-vars current-arity bound bodyS)
+##         adjusted (adjust-vars unused bound)]
+##     [(|> pathS (clean-pattern adjusted) simplify-pattern)
+##      (clean-expression adjusted bodyS)]))