basis/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
   4 combinators.short-circuit combinators ;
   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 read-only } { cdr read-only } ;
  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 SINGLETON: +nil+
  24 M: +nil+ nil? drop t ;
  25 M: object nil? drop f ;
  26
  27 : atom? ( obj -- ? )
  28     { [ list? ] [ nil? ] } 1|| not ;
  29
  30 : nil ( -- symbol ) +nil+ ;
  31
  32 : uncons ( cons -- car cdr )
  33     [ car ] [ cdr ] bi ;
  34
  35 : swons ( cdr car -- cons )
  36     swap cons ;
  37
  38 : unswons ( cons -- cdr car )
  39     uncons swap ;
  40
  41 : 1list ( obj -- cons )
  42     nil cons ;
  43
  44 : 1list? ( list -- ? )
  45     { [ nil? not ] [ cdr nil? ] } 1&& ;
  46
  47 : 2list ( a b -- cons )
  48     nil cons cons ;
  49
  50 : 3list ( a b c -- cons )
  51     nil cons cons cons ;
  52
  53 : cadr ( list -- elt )
  54     cdr car ;
  55
  56 : 2car ( list -- car caar )
  57     [ car ] [ cdr car ] bi ;
  58
  59 : 3car ( list -- car cadr caddr )
  60     [ car ] [ cdr car ] [ cdr cdr car ] tri ;
  61
  62 : lnth ( n list -- elt )
  63     swap [ cdr ] times car ;
  64
  65 <PRIVATE
  66 : (leach) ( list quot -- cdr quot )
  67     [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
  68 PRIVATE>
  69
  70 : leach ( list quot: ( elt -- ) -- )
  71     over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
  72
  73 : lmap ( list quot: ( elt -- ) -- result )
  74     over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
  75
  76 : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
  77     swapd leach ; inline
  78
  79 : foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
  80     pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
  81         [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
  82         call
  83     ] if ; inline recursive
  84
  85 : llength ( list -- n )
  86     0 [ drop 1+ ] foldl ;
  87
  88 : lreverse ( list -- newlist )
  89     nil [ swap cons ] foldl ;
  90
  91 : lappend ( list1 list2 -- newlist )
  92     [ lreverse ] dip [ swap cons ] foldl ;
  93
  94 : lcut ( list index -- before after )
  95     [ +nil+ ] dip
  96     [ [ [ cdr ] [ car ] bi ] dip cons ] times
  97     lreverse swap ;
  98
  99 : sequence>cons ( sequence -- list )
 100     <reversed> nil [ swap cons ] reduce ;
 101
 102 <PRIVATE
 103 : same? ( obj1 obj2 -- ? )
 104     [ class ] bi@ = ;
 105 PRIVATE>
 106
 107 : deep-sequence>cons ( sequence -- cons )
 108     [ <reversed> ] keep nil
 109     [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
 110
 111 <PRIVATE
 112 : (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons )
 113     over nil? [ 2drop ]
 114     [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ;
 115     inline recursive
 116 PRIVATE>
 117
 118 : lmap>array ( list quot -- array )
 119     [ { } ] 2dip (lmap>array) ; inline
 120
 121 : lmap-as ( list quot exemplar -- sequence )
 122     [ lmap>array ] dip like ;
 123
 124 : deep-list>array ( list -- array )
 125     [
 126         {
 127             { [ dup list? ] [ deep-list>array ] }
 128             { [ dup nil? ] [ drop { } ] }
 129             [ ]
 130         } cond
 131     ] lmap>array ;
 132
 133 : list>array ( list -- array )
 134     [ ] lmap>array ;
 135
 136 : traverse ( list pred quot: ( list/elt -- result ) -- result )
 137     [
 138         2over call [ tuck [ call ] 2dip ] when
 139         pick list? [ traverse ] [ 2drop ] if
 140     ] 2curry lmap ; inline recursive
 141
 142 INSTANCE: cons list