f6d14a4e0a6c — Leonard Ritter 19 days ago
* topowalk with cc
* any/all evaluate lazily
4 files changed, 237 insertions(+), 86 deletions(-)

M lib/tukan/uvm.sc
M testing/test_compiler.tuk
M testing/test_fold.tuk
A => testing/topowalk.tuk
M lib/tukan/uvm.sc +20 -16
@@ 505,7 505,7 @@ struct Cell
                                 vl @ i
                             this-function k v ...
                     default
-                        assert false "table structure: internal error"
+                        assert false "cell structure: internal error"
                         unreachable;
                 case None ()
                 default

          
@@ 530,7 530,7 @@ struct Cell
                             vl @ i
                         this-function k v (.. depth "    ") i
                 default
-                    assert false "table structure: internal error"
+                    assert false "cell structure: internal error"
                     unreachable;
             default;
         recur self.keys self.values "" -1

          
@@ 1653,6 1653,20 @@ struct CachedEval
                 # (do (let k v) ... expr... (: k v))
                 case builtins.do
                     return (eval-do self env args 1)
+                # (all first then)
+                case builtins.all
+                    let a = (ueval env ('get-index args 1))
+                    let b = ('get-index args 2)
+                    return
+                        if ('none? a) a
+                        else (ueval env b)
+                # (any try else)
+                case builtins.any
+                    let a = (ueval env ('get-index args 1))
+                    let b = ('get-index args 2)
+                    return
+                        if ('none? a) (ueval env b)
+                        else a
                 # (fn (param ...) expr)
                 case builtins.fn
                     let expr = (rewrite-fn-body expr)

          
@@ 1724,7 1738,7 @@ struct CachedEval
                 if (mtable == mt_closure)
                     return (ueval (uapply-env head args 0))
                 else
-                    print "cannot apply table:" ('tostring expr)
+                    print "cannot apply cell:" ('tostring expr)
                     return (Atom)
             case Atom.Kind.Symbol
                 let table = (expr as Cell)

          
@@ 1878,16 1892,6 @@ struct CachedEval
                         if ('none? subenv) (copy env)
                         else subenv
                     ueval subenv expr
-                case builtins.all
-                    let a = ('get-index args 0)
-                    let b = ('get-index args 1)
-                    if ('none? a) a
-                    else b
-                case builtins.any
-                    let a = ('get-index args 0)
-                    let b = ('get-index args 1)
-                    if ('none? a) b
-                    else a
                 case builtins.dump
                     let x = ('get-index args 0)
                     #if (not ('none? x))

          
@@ 1966,7 1970,7 @@ struct CachedEval
                             else
                                 let result =
                                     ueval
-                                        uapply-env func 
+                                        uapply-env func
                                             Cell.new (copy state) (Atom i)
                                             0
                                 repeat (i + 1)

          
@@ 1986,7 1990,7 @@ struct CachedEval
                             cell =
                                 'set-index cell i
                                     ueval
-                                        uapply-env func 
+                                        uapply-env func
                                             Cell.new (Atom i)
                                             0
                         return (Atom cell)

          
@@ 2004,7 2008,7 @@ struct CachedEval
                         for i in (range sz)
                             let result =
                                 ueval
-                                    uapply-env func 
+                                    uapply-env func
                                         Cell.new (Atom i)
                                         0
                             if (('kind result) == Atom.Kind.Text)

          
M testing/test_compiler.tuk +62 -68
@@ 1,4 1,20 @@ 
 #!/usr/bin/env -S scopes tuk_interpreter.sc
+let countof nextindex
+fn empty? (c)
+    == (nextindex c) 0
+fn lastindex (c)
+    - (nextindex c) 1
+fn last (c)
+    let idx (lastindex c)
+    get c idx
+fn pop (c)
+    let idx (lastindex c)
+    set c idx
+fn swap (c i1 i2)
+    set (set c i1 (get c i2)) i2 (get c i1)
+fn append (c value)
+    set c (nextindex c) value
+
 let source
     quote
         do

          
@@ 31,21 47,8 @@ let source
                             all break "enter empty line to exit\n"
                             readline
                     = state state
-let countof nextindex
-fn empty? (c)
-    == (nextindex c) 0
-fn lastindex (c)
-    - (nextindex c) 1
-fn last (c)
-    let idx (lastindex c)
-    get c idx
-fn pop (c)
-    let idx (lastindex c)
-    set c idx
-fn swap (c i1 i2)
-    set (set c i1 (get c i2)) i2 (get c i1)
-fn append (c value)
-    set c (nextindex c) value
+
+
 fn topowalk (user root edgef visitf)
     let STATE_UNSEEN 'unseen
     let STATE_QUEUED 'queued

          
@@ 107,66 110,57 @@ fn topowalk (user root edgef visitf)
                                 set self 'stack (pop stack)
     get self 'user
 
-#
-    fn cc (f args)
-        let handler f
-        fn final (_ args)
-        let self
-            fold
-                cell f final args
-                65536
-                fn (self i)
-                    let@ f fret args self
-                    let f
-                        cond (== f true) handler f
-                    f fret args
-        get self 2
-
-    fn fib (fret n)
-        cond (< n 2)
-            cell fret false n
-            cell true
-                fn (_ n1)
-                    cell true
-                        fn (_ n2)
-                            cell fret false (dump (+ n1 n2))
-                        - n 2
-                - n 1
-    dump
-        cc fib 10
-
-fn cc (ftable start args)
-    let ftable
-        set ftable '__final__
-            fn (ctx ret args)
+# call-continuation engine
+fn cc (ftable f args)
+    fn final (_ args)
     let self
         fold
-            cell (cell start (cell)) (cell '__final__ (cell)) args
+            cell f final args
             65536
             fn (self i)
-                let@ f ret args self
-                let@ token ctx f
-                (get ftable token) ctx ret args
+                let@ f fret args self
+                let f (any (get ftable f) f)
+                f fret args
     get self 2
-
-dump
+let: order
     cc
         do
-            = fib
-                fn (ctx ret n)
-                    cond (< n 2)
-                        cell ret false n
-                        cell (cell 'fib (cell)) (cell 'fibc1 (cell ret (- n 2))) (- n 1)
-            = fibc1
-                fn (ctx _ n1)
-                    let@ ret n ctx
-                    cell (cell 'fib (cell)) (cell 'fibc2 (append ctx n1)) n
-            = fibc2
-                fn (ctx _ n2)
-                    let@ ret n n1 ctx
-                    cell ret false (+ n1 n2)
-        'fib
-        10
+            = visit-child
+                fn (ret nodeit)
+                    let@ self node i nodeit
+                    let child (get node i)
+                    any
+                        all child
+                            cell 'visit
+                                fn (_ self)
+                                    cell 'visit-child ret
+                                        cell self node (+ i 1)
+                                cell self child
+                        cell ret false self
+            = visit
+                fn (ret args)
+                    let@ self node args
+                    fn post (_ self)
+                        cell ret false
+                            set self 'order
+                                append (get self 'order) node
+                    let visited (get self 'visited)
+                    cond (any (get visited node) false)
+                        cell ret false self
+                        do
+                            let visited (set visited node true)
+                            let self (set self 'visited visited)
+                            cond (== (kindof node) 'cell)
+                                cell 'visit-child post
+                                    cell self node 0
+                                post false self
+        'visit
+        cell
+            do
+                = order (cell)
+                = visited (cell)
+            quote (a b (c d) d e (c d) f)
+dump order # prints (a b c d (c d) e f (a b (c d) d e (c d) f))
 
 #dump # prints (a b c d (c d) e f (a b (c d) d e (c d) f))
     topowalk (cell)

          
M testing/test_fold.tuk +70 -2
@@ 1,6 1,6 @@ 
 dump
     do
-        # fibonacci, head recursive
+        # fibonacci, head recursive - this one is illegal
         fn fib-rec (f n)
             cond (< n 2) n
                 +

          
@@ 9,7 9,7 @@ dump
         fib-rec fib-rec 10
 dump
     do
-        # fibonacci, tail recursive
+        # fibonacci, tail recursion via fold
         get
             fold
                 do 0 1 10

          
@@ 19,6 19,74 @@ dump
                     cond (> n 0)
                         do b (+ a b) (- n 1)
             0
+do
+    # fibonacci, head recursion via emulation of call continuation,
+        implicit zipper structure via nested closures, requires recursive
+        capturing.
+    # call-continuation engine
+    fn cc (ftable f args)
+        fn final (_ args)
+        let self
+            fold
+                cell f final args
+                65536
+                fn (self i)
+                    let@ f fret args self
+                    let f (any (get ftable f) f)
+                    f fret args
+        get self 2
+    fn fib (fret n)
+        cond (< n 2)
+            cell fret false n
+            cell 'fib
+                fn (_ n1)
+                    cell 'fib
+                        fn (_ n2)
+                            cell fret false (+ n1 n2)
+                        - n 2
+                - n 1
+    dump
+        cc
+            do
+                = fib fib
+            'fib
+            10
+do
+    # fibonacci, head recursion via emulation of call continuation, explicit
+        zipper structure, does not require closures.
+    fn append (c value)
+        set c (nextindex c) value
+    fn cc (ftable start args)
+        let ftable
+            set ftable '__final__
+                fn (ctx ret args)
+        let self
+            fold
+                cell (cell start (cell)) (cell '__final__ (cell)) args
+                65536
+                fn (self i)
+                    let@ f ret args self
+                    let@ token ctx f
+                    (get ftable token) ctx ret args
+        get self 2
+    dump
+        cc
+            do
+                = fib
+                    fn (ctx ret n)
+                        cond (< n 2)
+                            cell ret false n
+                            cell (cell 'fib (cell)) (cell 'fibc1 (cell ret (- n 2))) (- n 1)
+                = fibc1
+                    fn (ctx _ n1)
+                        let@ ret n ctx
+                        cell (cell 'fib (cell)) (cell 'fibc2 (append ctx n1)) n
+                = fibc2
+                    fn (ctx _ n2)
+                        let@ ret n n1 ctx
+                        cell ret false (+ n1 n2)
+            'fib
+            10
 dump
     do
         let vec (cell 1 2 3 4)

          
A => testing/topowalk.tuk +85 -0
@@ 0,0 1,85 @@ 
+let countof nextindex
+fn empty? (c)
+    == (nextindex c) 0
+fn lastindex (c)
+    - (nextindex c) 1
+fn last (c)
+    let idx (lastindex c)
+    get c idx
+fn pop (c)
+    let idx (lastindex c)
+    set c idx
+fn swap (c i1 i2)
+    set (set c i1 (get c i2)) i2 (get c i1)
+fn append (c value)
+    set c (nextindex c) value
+fn topowalk (user root edgef visitf)
+    let STATE_UNSEEN 'unseen
+    let STATE_QUEUED 'queued
+    let STATE_COMPLETE 'complete
+    fn get-state (self v)
+        any (get (get self 'state) v) STATE_UNSEEN
+    fn set-state (self v state)
+        set self 'state
+            set (get self 'state) v state
+    fn get-stacksize (self)
+        countof (get self 'stack)
+    fn push-vertex (self v)
+        any
+            all v
+                do
+                    let vs (get-state self v)
+                    cond (== vs 'unseen)
+                        set self 'stack
+                            append (get self 'stack) v
+            self
+    let self
+        fold
+            do
+                = stack (cell root)
+                = state (cell)
+                = user user
+            65536
+            fn (self i)
+                let stack (get self 'stack)
+                let done? (empty? stack)
+                cond (not done?)
+                    do
+                        let v (last stack)
+                        let vs (get-state self v)
+                        cond (== vs STATE_UNSEEN) # not yet seen
+                            do
+                                let self (set-state self v STATE_QUEUED)
+                                let stackp1 (get-stacksize self)
+                                let self (edgef self v push-vertex)
+                                let stackp2 (get-stacksize self)
+                                let stackp1p2 (+ stackp1 stackp2)
+                                let m (// stackp1p2 2)
+                                let rend (- stackp1p2 1)
+                                let stack (get self 'stack)
+                                # swap stack order
+                                set self 'stack
+                                    fold stack (- m stackp1)
+                                        fn (stack i)
+                                            let i (+ i stackp1)
+                                            swap stack i (- rend i)
+                            do
+                                let self
+                                    cond (== vs STATE_QUEUED) # children previously queued
+                                        do
+                                            let self (set-state self v STATE_COMPLETE)
+                                            set self 'user
+                                                visitf (get self 'user) v
+                                        self
+                                set self 'stack (pop stack)
+    get self 'user
+dump # prints (a b c d (c d) e f (a b (c d) d e (c d) f))
+    topowalk (cell)
+        quote (a b (c d) d e (c d) f)
+        fn (self v queue)
+            cond (== (kindof v) 'cell)
+                fold self (countof v)
+                    fn (self i)
+                        queue self (get v i)
+                self
+        append