ton/crypto/fift/lib/Lists.fif

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 !

variable ctxdump  variable curctx
// (a1 .. an) e -- executes e for a1, ..., an
{ ctxdump @ curctx @ ctxdump 2! curctx 2!
  { curctx 2@ over null? not } { swap uncons rot tuck curctx 2! execute }
  while 2drop ctxdump 2@ curctx ! ctxdump !
} : list-foreach
forget ctxdump  forget curctx

//
// Experimental implementation of `for` loops with index
//
variable loopdump  variable curloop
{ curloop @ loopdump @ loopdump 2! } : push-loop-ctx
{ loopdump 2@ loopdump ! curloop ! } : pop-loop-ctx
// ilast i0 e -- executes e for i=i0,i0+1,...,ilast-1
{ -rot 2dup > {
    push-loop-ctx {
      triple dup curloop ! first execute curloop @ untriple 1+ 2dup <=
    } until pop-loop-ctx
  } if 2drop drop
} : for
// ilast i0 e -- same as 'for', but pushes current index i before executing e
{ -rot 2dup > {
    push-loop-ctx {
      triple dup curloop ! untriple nip swap execute curloop @ untriple 1+ 2dup <=
    } until pop-loop-ctx
  } if 2drop drop
} : for-i
// ( -- i )  Returns innermost loop index
{ curloop @ third } : i
// ( -- j )  Returns outer loop index
{ loopdump @ car third } : j
{ loopdump @ cadr third } : k
forget curloop  forget loopdump

//
// 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]))