extra/lists/lists.factor

   1 ! Copyright (C) 2008 James Cash
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences accessors math arrays vectors classes words locals ;
   4
   5 IN: lists
   6
   7 ! List Protocol
   8 MIXIN: list
   9 GENERIC: car   ( cons -- car )
  10 GENERIC: cdr   ( cons -- cdr )
  11 GENERIC: nil?  ( object -- ?   )
  12
  13 TUPLE: cons car cdr ;
  14
  15 C: cons cons
  16
  17 M: cons car ( cons -- car )
  18     car>> ;
  19
  20 M: cons cdr ( cons -- cdr )
  21     cdr>> ;
  22
  23 SYMBOL: +nil+
  24 M: word nil? +nil+ eq? ;
  25 M: object nil? drop f ;
  26
  27 : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
  28
  29 : nil ( -- symbol ) +nil+ ;
  30
  31 : uncons ( cons -- cdr car )
  32     [ cdr ] [ car ] bi ;
  33
  34 : 1list ( obj -- cons )
  35     nil cons ;
  36
  37 : 2list ( a b -- cons )
  38     nil cons cons ;
  39
  40 : 3list ( a b c -- cons )
  41     nil cons cons cons ;
  42
  43 : cadr ( cons -- elt )
  44     cdr car ;
  45
  46 : 2car ( cons -- car caar )
  47     [ car ] [ cdr car ] bi ;
  48
  49 : 3car ( cons -- car caar caaar )
  50     [ car ] [ cdr car ] [ cdr cdr car ] tri ;
  51
  52 : lnth ( n list -- elt )
  53     swap [ cdr ] times car ;
  54
  55 : (leach) ( list quot -- cdr quot )
  56     [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
  57
  58 : leach ( list quot: ( elt -- ) -- )
  59     over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
  60
  61 : lmap ( list quot: ( elt -- ) -- result )
  62     over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
  63
  64 : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
  65     swapd leach ; inline
  66
  67 : foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
  68     pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
  69         [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
  70         call
  71     ] if ; inline recursive
  72
  73 : llength ( list -- n )
  74     0 [ drop 1+ ] foldl ;
  75
  76 : lreverse ( list -- newlist )
  77     nil [ swap cons ] foldl ;
  78
  79 : lappend ( list1 list2 -- newlist )
  80     [ lreverse ] dip [ swap cons ] foldl ;
  81
  82 : seq>list ( seq -- list )
  83     <reversed> nil [ swap cons ] reduce ;
  84
  85 : same? ( obj1 obj2 -- ? )
  86     [ class ] bi@ = ;
  87
  88 : seq>cons ( seq -- cons )
  89     [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
  90
  91 : (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons )
  92     over nil? [ 2drop ]
  93     [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ;
  94     inline recursive
  95
  96 : lmap>array ( cons quot -- newcons )
  97     { } -rot (lmap>array) ; inline
  98
  99 : lmap-as ( cons quot exemplar -- seq )
 100     [ lmap>array ] dip like ;
 101
 102 : cons>seq ( cons -- array )
 103     [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ;
 104
 105 : list>seq ( list -- array )
 106     [ ] lmap>array ;
 107
 108 : traverse ( list pred quot: ( list/elt -- result ) -- result )
 109     [ 2over call [ tuck [ call ] 2dip ] when
 110       pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive
 111
 112 INSTANCE: cons list