basis/lists/lists.factor

   1 ! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
   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 locals ;
   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 ) car>> ;
  18
  19 M: cons cdr ( cons -- cdr ) cdr>> ;
  20
  21 SINGLETON: +nil+
  22 M: +nil+ nil? drop t ;
  23 M: object nil? drop f ;
  24
  25 : atom? ( obj -- ? ) list? not ; inline
  26
  27 : nil ( -- symbol ) +nil+ ; inline
  28
  29 : uncons ( cons -- car cdr ) [ car ] [ cdr ] bi ; inline
  30
  31 : swons ( cdr car -- cons ) swap cons ; inline
  32
  33 : unswons ( cons -- cdr car ) uncons swap ; inline
  34
  35 : 1list ( obj -- cons ) nil cons ; inline
  36
  37 : 1list? ( list -- ? ) { [ nil? not ] [ cdr nil? ] } 1&& ; inline
  38
  39 : 2list ( a b -- cons ) nil cons cons ; inline
  40
  41 : 3list ( a b c -- cons ) nil cons cons cons ; inline
  42
  43 : cadr ( list -- elt ) cdr car ; inline
  44
  45 : 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; inline
  46
  47 : 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; inline
  48
  49 : lnth ( n list -- elt ) swap [ cdr ] times car ; inline
  50
  51 <PRIVATE
  52
  53 : (leach) ( list quot -- cdr quot )
  54     [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
  55
  56 PRIVATE>
  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     list nil? [ identity ] [
  69         list cdr identity quot foldr
  70         list car quot 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 : lcut ( list index -- before after )
  83     [ nil ] dip
  84     [ [ unswons ] dip cons ] times
  85     lreverse swap ;
  86
  87 : sequence>list ( sequence -- list )
  88     <reversed> nil [ swons ] reduce ;
  89
  90 : lmap>array ( list quot -- array )
  91     accumulator [ leach ] dip { } like ; inline
  92
  93 : list>array ( list -- array )
  94     [ ] lmap>array ;
  95
  96 :: traverse ( list pred quot: ( list/elt -- result ) -- result )
  97     list [| elt |
  98         elt dup pred call [ quot call ] when
  99         dup list? [ pred quot traverse ] when
 100     ] lmap ; inline recursive
 101
 102 INSTANCE: cons list
 103 INSTANCE: +nil+ list