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: accessors combinators combinators.short-circuit kernel
   4 lexer locals make math namespaces parser sequences words ;
   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-state { car read-only } { cdr read-only } ;
  14
  15 C: cons cons-state
  16
  17 M: cons-state car car>> ;
  18
  19 M: cons-state 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 ) 1list cons ; inline
  40
  41 : 3list ( a b c -- cons ) 2list cons ; inline
  42
  43 : cadr ( list -- elt ) cdr car ; inline
  44
  45 : 2car ( list -- car cadr ) uncons car ; inline
  46
  47 : 3car ( list -- car cadr caddr ) uncons uncons car ; 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 : (2leach) ( list1 list2 quot -- cdr1 cdr2 quot )
  57     [ [ [ car ] bi@ ] dip call ] [ [ [ cdr ] bi@ ] dip ] 3bi ; inline
  58
  59 PRIVATE>
  60
  61 : leach ( ... list quot: ( ... elt -- ... ) -- ... )
  62     over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
  63
  64 : 2leach ( ... list1 list2 quot: ( ... elt1 elt2 -- ... ) -- ... )
  65     2over [ nil? ] either? [ 3drop ] [ (2leach) 2leach ] if ; inline recursive
  66
  67 : lreduce ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
  68     swapd leach ; inline
  69
  70 : 2lreduce ( ... list1 list2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
  71     -rotd 2leach ; inline
  72
  73 : foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
  74     swapd leach ; inline
  75
  76 :: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
  77     list nil? [
  78         identity
  79     ] [
  80         list cdr identity quot foldr
  81         list car quot call
  82     ] if ; inline recursive
  83
  84 : llength ( list -- n )
  85     0 [ drop 1 + ] foldl ;
  86
  87 : lreverse ( list -- newlist )
  88     nil [ swons ] foldl ;
  89
  90 : lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
  91     [ nil ] dip [ swapd dip cons ] curry foldl lreverse ; inline
  92
  93 : lappend ( list1 list2 -- newlist )
  94     [ lreverse ] dip [ swons ] foldl ;
  95
  96 : lcut ( list index -- before after )
  97     [ nil ] dip [ [ unswons ] dip cons ] times lreverse swap ;
  98
  99 : sequence>list ( sequence -- list )
 100     <reversed> nil [ swons ] reduce ;
 101
 102 : lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
 103     collector [ leach ] dip { } like ; inline
 104
 105 : list>array ( list -- array )
 106     [ ] lmap>array ;
 107
 108 : deeplist>array ( list -- array )
 109     [ dup list? [ deeplist>array ] when ] lmap>array ;
 110
 111 INSTANCE: cons-state list
 112 INSTANCE: +nil+ list
 113
 114 GENERIC: >list ( object -- list )
 115
 116 M: list >list ;
 117
 118 M: sequence >list sequence>list ;
 119
 120 ERROR: list-syntax-error ;
 121
 122 <PRIVATE
 123
 124 : items>list ( sequence -- list )
 125     [ +nil+ ] [
 126         <reversed> unclip-slice [ swons ] reduce
 127     ] if-empty ;
 128
 129 : ?list-syntax-error ( right-of-dot? -- )
 130     building get empty? or [ list-syntax-error ] when ;
 131
 132 : (parse-list-literal) ( right-of-dot? -- )
 133     scan-token {
 134         { "}" [ drop +nil+ , ] }
 135         { "." [ ?list-syntax-error t (parse-list-literal) ] }
 136         [
 137             parse-datum dup parsing-word? [
 138                 V{ } clone swap execute-parsing first
 139             ] when
 140             , [ "}" expect ] [ f (parse-list-literal) ] if
 141         ]
 142     } case ;
 143
 144 : parse-list-literal ( -- list )
 145     [ f (parse-list-literal) ] { } make items>list ;
 146
 147 PRIVATE>
 148
 149 SYNTAX: L{ parse-list-literal suffix! ;