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 ;
9 GENERIC: car ( cons -- car )
10 GENERIC: cdr ( cons -- cdr )
11 GENERIC: nil? ( object -- ? )
13 TUPLE: cons { car read-only } { cdr read-only } ;
17 M: cons car ( cons -- car )
20 M: cons cdr ( cons -- cdr )
24 M: +nil+ nil? drop t ;
25 M: object nil? drop f ;
28 { [ list? ] [ nil? ] } 1|| not ;
30 : nil ( -- symbol ) +nil+ ;
32 : uncons ( cons -- car cdr )
35 : swons ( cdr car -- cons )
38 : unswons ( cons -- cdr car )
41 : 1list ( obj -- cons )
44 : 1list? ( list -- ? )
45 { [ nil? not ] [ cdr nil? ] } 1&& ;
47 : 2list ( a b -- cons )
50 : 3list ( a b c -- cons )
53 : cadr ( list -- elt )
56 : 2car ( list -- car caar )
57 [ car ] [ cdr car ] bi ;
59 : 3car ( list -- car cadr caddr )
60 [ car ] [ cdr car ] [ cdr cdr car ] tri ;
62 : lnth ( n list -- elt )
63 swap [ cdr ] times car ;
66 : (leach) ( list quot -- cdr quot )
67 [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
70 : leach ( list quot: ( elt -- ) -- )
71 over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
73 : lmap ( list quot: ( elt -- ) -- result )
74 over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
76 : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
79 : foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
80 pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
81 [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
83 ] if ; inline recursive
85 : llength ( list -- n )
88 : lreverse ( list -- newlist )
89 nil [ swap cons ] foldl ;
91 : lappend ( list1 list2 -- newlist )
92 [ lreverse ] dip [ swap cons ] foldl ;
94 : lcut ( list index -- before after )
96 [ [ [ cdr ] [ car ] bi ] dip cons ] times
99 : sequence>cons ( sequence -- list )
100 <reversed> nil [ swap cons ] reduce ;
103 : same? ( obj1 obj2 -- ? )
107 : deep-sequence>cons ( sequence -- cons )
108 [ <reversed> ] keep nil
109 [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
112 : (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons )
114 [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ;
118 : lmap>array ( list quot -- array )
119 [ { } ] 2dip (lmap>array) ; inline
121 : lmap-as ( list quot exemplar -- sequence )
122 [ lmap>array ] dip like ;
124 : deep-list>array ( list -- array )
127 { [ dup list? ] [ deep-list>array ] }
128 { [ dup nil? ] [ drop { } ] }
133 : list>array ( list -- array )
136 : traverse ( list pred quot: ( list/elt -- result ) -- result )
138 2over call [ tuck [ call ] 2dip ] when
139 pick list? [ traverse ] [ 2drop ] if
140 ] 2curry lmap ; inline recursive