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