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 ( cons -- car ) car>> ;
  18
  19 M: cons-state 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 ) 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 PRIVATE>
  57
  58 : leach ( ... list quot: ( ... elt -- ... ) -- ... )
  59     over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
  60
  61 : foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
  62     swapd leach ; inline
  63
  64 :: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
  65     list nil? [
  66         identity
  67     ] [
  68         list cdr identity quot foldr
  69         list car quot call
  70     ] if ; inline recursive
  71
  72 : llength ( list -- n )
  73     0 [ drop 1 + ] foldl ;
  74
  75 : lreverse ( list -- newlist )
  76     nil [ swons ] foldl ;
  77
  78 : lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
  79     [ nil ] dip [ swapd dip cons ] curry foldl lreverse ; inline
  80
  81 : lappend ( list1 list2 -- newlist )
  82     [ lreverse ] dip [ swons ] foldl ;
  83
  84 : lcut ( list index -- before after )
  85     [ nil ] dip [ [ unswons ] dip cons ] times lreverse swap ;
  86
  87 : sequence>list ( sequence -- list )
  88     <reversed> nil [ swons ] reduce ;
  89
  90 : lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
  91     collector [ leach ] dip { } like ; inline
  92
  93 : list>array ( list -- array )
  94     [ ] lmap>array ;
  95
  96 : deeplist>array ( list -- array )
  97     [ dup list? [ deeplist>array ] when ] lmap>array ;
  98
  99 INSTANCE: cons-state list
 100 INSTANCE: +nil+ list
 101
 102 GENERIC: >list ( object -- list )
 103
 104 M: list >list ;
 105
 106 M: sequence >list sequence>list ;
 107
 108 ERROR: list-syntax-error ;
 109
 110 <PRIVATE
 111
 112 : items>list ( sequence -- list )
 113     [ +nil+ ] [
 114         <reversed> unclip-slice [ swons ] reduce
 115     ] if-empty ;
 116
 117 : ?list-syntax-error ( right-of-dot? -- )
 118     building get empty? or [ list-syntax-error ] when ;
 119
 120 : (parse-list-literal) ( right-of-dot? -- )
 121     scan-token {
 122         { "}" [ drop +nil+ , ] }
 123         { "." [ ?list-syntax-error t (parse-list-literal) ] }
 124         [
 125             parse-datum dup parsing-word? [
 126                 V{ } clone swap execute-parsing first
 127             ] when
 128             , [ "}" expect ] [ f (parse-list-literal) ] if
 129         ]
 130     } case ;
 131
 132 : parse-list-literal ( -- list )
 133     [ f (parse-list-literal) ] { } make items>list ;
 134
 135 PRIVATE>
 136
 137 SYNTAX: L{ parse-list-literal suffix! ;