Added destructuring lambda/rec-lambda, changed let to use the same [] array destructuring syntax, added basic multiset & set-foldl. Fixed a bunch of bugs in fungll, hopefully close to working, but just realized that < is only defined for ints, while it's how the RB-Tree set/map sort their values/keys, so I'll need to extend it like = for all types. Tomorrow!

fungll.kp

@@ -7,21 +7,6 @@
     ;               by L. Thomas van Binsbergena, Elizabeth Scott, Adrian Johnstone
     ; retrived from from http://ltvanbinsbergen.nl/publications/jcola-fgll.pdf
     
-    ; quick recognizer sketch
-    ;nterm(X,p)(t,k,c) = p(t,k,c)
-    ;term(lt)(t,k,c)   =(if (= lt t[k]) (c (+ k 1))
-                                       false)
-    ;seqStart(t,k,c)   = c(k)
-    ;seqOp(p,q)(t,k,c) = p(t,k, (lambda (r) q(t,r,c)) )
-    ;altStart(t,k,c)   = false
-    ;altOp(p,q)(t,k,c) = p(t,k,c) or q(t,k,c)
-    ;recognize(p)(t)   = p(t,0, (lambda (r) (= r (len t)))
-
-
-    ;var G = map<pair<int, int>, set<Pending>>()
-    ;var P = map<pair<int,int>, set<int>>()
-    ;var Y = set<BS>()
-
     ; discriptor is a triple of grammer-slot and 2 indicies of t-string
     ;   corresponding to process
     ;       <X::= a.b,l,k>
@@ -49,57 +34,51 @@
 
     ; I've decided, a slot is [X [stff] int-for-dot]
 
-
     id (lambda (sigma) sigma)
     altStart                  (lambda (t s k c) id)
-    altOp    (lambda (p q)    (lambda (t s k c) (lcompose (p t s k c) (q t s <empty> k c))))
+    altOp    (lambda (p q)    (lambda (t s k c) (lcompose (p t s k c) (q t s [] k c))))
-    term (lambda (s) [ s term_parser ])
+    term_parser                 (lambda (t [X b i] l k c) (lambda (sigma)
-    term_parser                 (lambda (t gram_slot l k c) (lambda (sigma)
+        (if (= (idx b (- i 1)) (idx t k)) ((c [[X b i] l (+ 1 k)]) sigma)
-        (if (= (get-s gram_slot) (idx t k)) ((c [gram_slot l (+ 1 k)]) sigma)
                                             sigma)))
-    seqStart (lambda (t X b l c0) (continue [X::=.b,l,l,l] c0)
+    term (lambda (s) [ s term_parser ])
-    seqOp (lambda (p [s q]) (lambda (t X b l c0) (let (
+
-                                c2 (lambda ([slot l r]) (continue [slot l k r] c0))
+    continue (lambda (BSR_element c) (lambda ([U G P Y])
-                                c1 (lambda ([slot l k]) (q t slot l k c2))
-                               ) (p t X sb l c1)))))
-    continue (lambda (descriptor? c) (lambda (sigma)
-        (if (set-contains? U descriptor?) sigma
             (let (
-                [U G P Y] sigma
+                [slot l k r] BSR_element
-                (slot l r) descriptor?
+                descriptor [slot l r]
-                (X rhs i) slot
+                (X b i) slot
-                BSR_element [slot l k r]
+                Yp (if (or (!= 0 i) (= (len rhs) i)) (set-insert Y BSR_element)
-                Yp (if (or (= 0 i) (= (len rhs) i)) (set-insert Y BSR_element)
+                                                     Y)
-                                                    Y)
                 Up (set-insert U descriptor)
-            ) ((c BSR_element) [Up G P Yp]))
+            ) (if (set-contains? U descriptor) [U G P Yp]
-        )))
+                                               ((c descriptor) [Up G P Yp])))))
-    cont_for (lambda (s p) (lambda (descriptor?) (lambda (sigma) (let (
+    seqStart (lambda (t X b l c0) (continue [[X b 0] l l l] c0))
-            [U G P Y] sigma
+    seqOp (lambda (p [s q]) (lambda (t X b l c0) (let (
-            sigmap [U G (set-insert P [[s k] r]) Y]
+                                c1 (lambda ([slot l k]) (let (
-            composed (foldl (lambda (cp [g l c]) (compose cp (c [g l r]))) id (map-get-or-default G [s k] []))
+                                    c2 (lambda ([slot l r]) (continue [slot l k r] c0))
-        ) (composed sigmap)))))
+                                   ) (q t slot l k c2)))
-    nterm (lambda (s p) [ s (nterm_parser p) ])
+                               ) (p t X (cons s b) l c1))))
-    nterm_parser (lambda (p) (lambda (t gram_slot l k c) (lambda (sigma)
+
+    cont_for (lambda (s p) (lambda ([[s d i] k r]) (lambda ([U G P Y]) (let (
+            composed (set-foldl (lambda (cp [g l c]) (lcompose cp (c [g l r]))) id (multimap-get G [s k]))
+        ) (composed [U G (multimap-insert P [s k] r) Y])))))
+    nterm_parser (lambda (p) (lambda (t gram_slot l k c) (lambda ([U G P Y])
         (let (
-            R (map-get-or-default P [s k] [])
+            [X b i] gram_slot
-            [U G P Y] sigma
+            s (idx b (- i 1))
-            sigmap [U (map-insert G [s k] [gram_slot l c]) Y]
+            R (multimap-get P [s k])
+            sigmap [U (multimap-insert G [s k] [gram_slot l c]) P Y]
         ) (if (= 0 (size R)) ((p t s k (cont_for s p)) sigmap)
-                             (foldl (lambda (cp r) (compose cp (c [gram_slot l r]))) id R))
+                             (set-foldl (lambda (cp r) (lcompose cp (c [gram_slot l r]))) id R)
-        ))))
+        )))))
+    nterm (lambda (s p) [ s (nterm_parser p) ])
     parse (lambda ([s f]) (lambda (t)
         (let (
-            X (fresh)
+            X '__FUNGLL_UNIQUE_START_SYMBOL__
-            sigma [ empty empty empty empty ]
+            sigma [ set-empty multimap-empty multimap-empty set-empty ]
-            c (lambda (bsr_element) (lambda (sigma) sigma))
+            c (lambda (descriptor) (lambda (sigma) sigma))
-            [U G P Y] ((f t X::=s. 0 0 c) sigma)
+            [U G P Y] ((f t ['X [s] 1] 0 0 c) sigma)
-         ) Y)))
+         ) (set-foldl cons [] Y))))
-
-    ; Big notes
-    ;   - haven't figured out exactly how grammer slots are going to work, also if s is already a vector
-    ;   - also need to add [] destructuring to parameter lists & change let desturcturing to []
-    ;   - much more I'm sure I'm quite tired
 )
-(provide)
+(provide altStart altOp term seqStart seqOp nterm parse)
 )))

fungll_test.kp

@@ -0,0 +1,6 @@
+(with_import "./fungll.kp"
+(let (
+    just_a_parser (parse (nterm 'A (altOp altStart (seqOp seqStart (term (idx "a" 0))))))
+    parse_result (just_a_parser "a")
+    _ (println "parse result " parse_result)
+) nil))

k_prime.krak

@@ -1115,7 +1115,7 @@ fun main(argc: int, argv: **char): int {
         if params.size <= 1 {
             return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("Need 2 or more params to <"))))
         }
-        if !params[0].is_int() { return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("called < with first not an int ") + pr_str(params[0], true)))); }
+        if !params[0].is_int() { return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("called < with first not an int ") + pr_str(params[0], true) + "\nenv was\n" + dynamic_env->to_string()))); }
         for (var i = 0; i < params.size - 1; i++;) {
             if !params[i+1].is_int() { return make_pair(null<KPEnv>(), KPResult::Err(kpString(str("called < with param ") + (i+1) + " not an int " + pr_str(params[i+1], true)))); }
             if !(params[i].get_int() < params[i+1].get_int()) {

prelude.kp

@@ -114,12 +114,23 @@
             destructure_helper (rec-lambda recurse (vs i r)
                 (cond (= (len vs) i)      r
                       (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i)))
-                                                new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i))
+                                                new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (slice (idx vs i) 1 -1))
                                                 )
                                                 (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1))))))
                       true                (recurse vs (+ i 2) (concat r (slice vs i (+ i 2))))
             ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de)))
 
+        ; and a destructuring-capable lambda!
+        lambda (vau se (p b) (let (
+            sym_params (map (lambda (param) (if (symbol? param) param
+                                                                (str-to-symbol (str param)))) p)
+            body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b)
+        ) (wrap (eval (array vau (quote _) sym_params body) se))))
+
+        ; and rec-lambda - yes it's the same definition again
+        rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
+
+
         is_pair? (lambda (x) (and (array? x) (> (len x) 0)))
 
         quasiquote (vY (lambda (recurse) (vau de (x)

rb.kp

@@ -20,6 +20,10 @@
                                         ~E  0
                                         [c a x b] (+ 1 (recurse a) (recurse b))))
 
+    generic-foldl (rec-lambda recurse (f z t) (match t
+                                                     ~E z
+                                                     [c a x b]  (recurse f (f (recurse f z a) x) b)))
+
     generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t
                                             ~E                            (not-found)
                                             [c a x b] (match (cmp v x) '< (recurse a cmp v found not-found)
@@ -87,15 +91,17 @@
                                     ['B ~E x ~E]            (match (cmp v x) '= EE
                                                                              _  t)
                                     [c a x b]               (match (cmp v x) '< (rotate [c (del a v) x b])
-                                                                             '= (let ((vp bp) (min_delete b))
+                                                                             '= (let ([vp bp] (min_delete b))
                                                                                 (rotate [c a vp bp]))
                                                                              '> (rotate [c a x (del b v)]))))
     ) (del (redden t) v)))
 
+
     set-cmp (lambda (a b) (cond (< a b) '<
                                 (= a b) '=
                                 true    '>))
     set-empty empty
+    set-foldl generic-foldl
     set-insert           (lambda (t x)   (generic-insert     t set-cmp x false))
     set-contains?        (lambda (t x)   (generic-contains?  t set-cmp x       (lambda (f) true)      (lambda () false)))
     set-remove           (lambda (t x)   (generic-delete     t set-cmp x))
@@ -112,8 +118,15 @@
     map-get-or-default   (lambda (t k d) (generic-contains?  t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () d)))
     map-get-with-default (lambda (t k d) (generic-contains?  t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (d))))
     map-remove           (lambda (t k)   (generic-delete     t map-cmp [k nil]))
+
+    ; This could be 2x as efficent by being implmented on generic instead of map,
+    ; as we wouldn't have to traverse once to find and once to insert
+    multimap-empty map-empty
+    multimap-insert           (lambda (t k v) (map-insert t k (set-insert (map-get-or-default t k set-empty) v)))
+    multimap-get              (lambda (t k)   (map-get-or-default t k set-empty))
 )
-    (provide set-empty set-insert set-contains? set-remove
+    (provide set-empty set-foldl set-insert set-contains? set-remove
              map-empty map-insert map-contains-key? map-get map-get-or-default map-get-with-default map-remove
+             multimap-empty multimap-insert multimap-get
              size)
 ))

rb_test.kp

@@ -12,6 +12,7 @@
     _ (println fourth " set-contains? " 2 " ? " (set-contains? fourth 2) " size " (size fourth))
     _ (println fourth " set-contains? " 3 " ? " (set-contains? fourth 3) " size " (size fourth))
     _ (println fourth " set-contains? " 4 " ? " (set-contains? fourth 4) " size " (size fourth))
+    _ (println fourth " foldl with + " (set-foldl + 0 fourth))
     fifth (set-remove fourth 1)
     _ (println fifth " set-contains? " 1 " ? " (set-contains? fifth 1) " size " (size fifth))
     _ (println fifth " set-contains? " 2 " ? " (set-contains? fifth 2) " size " (size fifth))