initial commit

crypto/fift/lib/Lists.fif

@@ -0,0 +1,184 @@
+library Lists  // List utilities
+//
+{ hole dup 1 { @ execute } does create } : recursive
+// x x' -- ?  recursively compares two S-expressions
+recursive equal? {
+  dup tuple? {
+    over tuple? {
+      over count over count over = { // t t' l ?
+        0 { dup 0>= { 2dup [] 3 pick 2 pick [] equal? { 1+ } { drop -1 } cond
+            } if } rot times
+        nip nip 0>=
+      } { drop 2drop false } cond
+    } { 2drop false } cond
+  } { eqv? } cond
+} swap !
+// (a1 .. an) -- (an .. a1)
+{ null swap { dup null? not } { uncons swap rot cons swap } while drop } : list-reverse
+// (a1 .. an) -- an   Computes last element of non-empty list l
+{ { uncons dup null? { drop true } { nip false } cond } until } : list-last
+// l l' -- l++l'  Concatenates two lists
+recursive list+ {
+  over null? { nip } { swap uncons rot list+ cons } cond
+} swap !
+// l l' -- l'' -1 or 0, where l = l' ++ l''
+// Removes prefix from list
+{ { dup null? { drop true true } {
+  swap dup null? { 2drop false true } { // l' l
+  uncons swap rot uncons -rot equal? { false } {
+  2drop false true
+  } cond } cond } cond } until
+} : list-
+// (a1 .. an) -- a1 .. an n   Explodes a list
+{ 0 { over null? not } { swap uncons rot 1+ } while nip } : explode-list
+// (a1 .. an) x -- a1 .. an n x   Explodes a list under the topmost element
+{ swap explode-list dup 1+ roll } : explode-list-1
+// l -- t   Transforms a list into a tuple with the same elements
+{ explode-list tuple } : list>tuple
+// a1 ... an n x -- (a1 .. an) x
+{ null swap rot { -rot cons swap } swap times } : mklist-1
+// (s1 ... sn) -- s1+...+sn   Concatenates a list of strings
+{ "" { over null? not } { swap uncons -rot $+ } while nip
+} : concat-string-list
+// (x1 ... xn) -- x1+...+xn   Sums a list of integers
+{ 0 { over null? not } { swap uncons -rot + } while nip
+} : sum-list
+// (a1 ... an) a e -- e(...e(e(a,a1),a2),...),an)
+{ -rot { over null? not } { swap uncons -rot 3 pick execute } while nip nip
+} : foldl
+// (a1 ... an) e -- e(...e(e(a1,a2),a3),...),an)
+{ swap uncons swap rot foldl } : foldl-ne
+// (a1 ... an) a e -- e(a1,e(a2,...,e(an,a)...))
+recursive foldr {
+  rot dup null? { 2drop } {
+    uncons -rot 2swap swap 3 pick foldr rot execute
+  } cond
+} swap !
+// (a1 ... an) e -- e(a1,e(a2,...,e(a[n-1],an)...))
+recursive foldr-ne {
+  over cdr null? { drop car } {
+    swap uncons 2 pick foldr-ne rot execute
+  } cond
+} swap !
+// (l1 ... ln) -- l1++...++ln   Concatenates a list of lists
+{ dup null? { ' list+ foldr-ne } ifnot } : concat-list-lists
+// (a1 .. an . t) n -- t   Computes the n-th tail of a list
+{ ' cdr swap times } : list-tail
+// (a0 .. an ..) n -- an   Computes the n-th element of a list
+{ list-tail car } : list-ref
+// l -- ?
+{ { dup null? { drop true true } {
+    dup pair? { cdr false } {
+    drop false true
+  } cond } cond } until
+} : list?
+// l -- n
+{ 0 { over null? not } { 1+ swap uncons nip swap } while nip
+} : list-length
+// l e -- t  // returns tail of l after first member that satisfies e
+{ swap {
+  dup null? { nip true } {
+  tuck car over execute { drop true } {
+  swap cdr false
+  } cond } cond } until
+} : list-tail-from
+// a l -- t  // tail of l after first occurence of a using eq?
+{ swap 1 ' eq? does list-tail-from } : list-member-eq
+{ swap 1 ' eqv? does list-tail-from } : list-member-eqv
+{ swap 1 ' equal? does list-tail-from } : list-member-equal
+// a l -- ?
+{ list-member-eq null? not } : list-member?
+{ list-member-eqv null? not } : list-member-eqv?
+// l -- a -1 or 0 // returns car l if l is non-empty
+{ dup null? { drop false } { car true } cond
+} : safe-car
+{ dup null? { drop false } { car second true } cond
+} : get-first-value
+// l e -- v -1 or 0
+{ list-tail-from safe-car } : assoc-gen
+{ list-tail-from get-first-value } : assoc-gen-x
+// a l -- (a.v) -1 or 0 -- returns first entry (a . v) in l
+{ swap 1 { swap first eq? } does assoc-gen } : assq
+{ swap 1 { swap first eqv? } does assoc-gen } : assv
+{ swap 1 { swap first equal? } does assoc-gen } : assoc
+// a l -- v -1 or 0 -- returns v from first entry (a . v) in l
+{ swap 1 { swap first eq? } does assoc-gen-x } : assq-val
+{ swap 1 { swap first eqv? } does assoc-gen-x } : assv-val
+{ swap 1 { swap first equal? } does assoc-gen-x } : assoc-val
+// (a1 .. an) e -- (e(a1) .. e(an))
+recursive list-map {
+  over null? { drop } {
+  swap uncons -rot over execute -rot list-map cons
+  } cond
+} swap !
+//
+// create Lisp-style lists using words "(" and ")"
+//
+variable ')
+'nop box constant ',
+{ ") without (" abort } ') ! 
+{ ') @ execute } : )
+anon constant dot-marker
+// m x1 ... xn t m -- (x1 ... xn . t)
+{ swap
+  { -rot 2dup eq? not }
+  { over dot-marker eq? abort"invalid dotted list"
+    swap rot cons } while 2drop
+} : list-tail-until-marker
+// m x1 ... xn m -- (x1 ... xn)
+{ null swap list-tail-until-marker } : list-until-marker
+{ over dot-marker eq? { nip 2dup eq? abort"invalid dotted list" }
+  { null swap } cond
+  list-tail-until-marker
+} : list-until-marker-ext
+{ ') @ ', @ } : ops-get
+{ ', ! ') ! } : ops-set
+{ anon dup ops-get 3 { ops-set list-until-marker-ext } does ') ! 'nop ', !
+} : (
+// test of Lisp-style lists
+// ( 42 ( `+ 9 ( `* 3 4 ) ) "test" ) .l cr
+// ( `eq? ( `* 3 4 ) 3 4 * ) .l cr
+// `alpha ( `beta `gamma `delta ) cons .l cr
+// { ( `eq? ( `* 3 5 pick ) 3 4 roll * ) } : 3*sample
+// 17 3*sample .l cr
+
+// similar syntax _( x1 .. xn ) for tuples
+{ 2 { 1+ 2dup pick eq? } until 3 - nip } : count-to-marker
+{ count-to-marker tuple nip } : tuple-until-marker
+{ anon dup ops-get 3 { ops-set tuple-until-marker } does ') ! 'nop ', ! } : _(
+// test of tuples
+// _( _( 2 "two" ) _( 3 "three" ) _( 4 "four" ) ) .dump cr
+
+// pseudo-Lisp tokenizer
+"()[]'" 34 hold constant lisp-delims
+{ lisp-delims 11 (word) } : lisp-token
+{ null cons `quote swap cons } : do-quote
+{ 1 { ', @ 2 { 2 { ', ! execute ', @ execute } does ', ! }
+      does ', ! } does
+} : postpone-prefix
+{ ', @ 1 { ', ! } does ', ! } : postpone-',
+( `( ' ( pair
+  `) ' ) pair
+  `[ ' _( pair
+  `] ' ) pair
+  `' ' do-quote postpone-prefix pair
+  `. ' dot-marker postpone-prefix pair
+  `" { char " word } pair
+  `;; { 0 word drop postpone-', } pair
+) constant lisp-token-dict
+variable eol
+{ eol @ eol 0! anon dup ') @ 'nop 3
+  { ops-set list-until-marker-ext true eol ! } does ') ! rot ', !
+  { lisp-token dup (number) dup { roll drop } {
+      drop atom dup lisp-token-dict assq { nip second execute } if
+    } cond
+    ', @ execute
+    eol @
+  } until
+  -rot eol ! execute
+} :_ List-generic(
+{ 'nop 'nop List-generic( } :_ LIST(
+// LIST((lambda (x) (+ x 1)) (* 3 4))
+// LIST('(+ 3 4))
+// LIST(2 3 "test" . 9)
+// LIST((process '[plus 3 4]))