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 ;
8 GENERIC: car ( cons -- car )
9 GENERIC: cdr ( cons -- cdr )
10 GENERIC: nil? ( object -- ? )
16 M: cons car ( cons -- car )
19 M: cons cdr ( cons -- cdr )
23 M: word nil? +nil+ eq? ;
24 M: object nil? drop f ;
26 : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
28 : nil ( -- symbol ) +nil+ ;
30 : uncons ( cons -- cdr car )
33 : 1list ( obj -- cons )
36 : 2list ( a b -- cons )
39 : 3list ( a b c -- cons )
42 : cadr ( cons -- elt )
45 : 2car ( cons -- car caar )
46 [ car ] [ cdr car ] bi ;
48 : 3car ( cons -- car cadr caddr )
49 [ car ] [ cdr car ] [ cdr cdr car ] tri ;
51 : lnth ( n list -- elt )
52 swap [ cdr ] times car ;
54 : (leach) ( list quot -- cdr quot )
55 [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
57 : leach ( list quot: ( elt -- ) -- )
58 over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
60 : lmap ( list quot: ( elt -- ) -- result )
61 over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
63 : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
66 : foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
67 pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
68 [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
70 ] if ; inline recursive
72 : llength ( list -- n )
75 : lreverse ( list -- newlist )
76 nil [ swap cons ] foldl ;
78 : lappend ( list1 list2 -- newlist )
79 [ lreverse ] dip [ swap cons ] foldl ;
81 : seq>list ( seq -- list )
82 <reversed> nil [ swap cons ] reduce ;
84 : same? ( obj1 obj2 -- ? )
87 : seq>cons ( seq -- cons )
88 [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
90 : (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons )
92 [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ;
95 : lmap>array ( cons quot -- newcons )
96 { } -rot (lmap>array) ; inline
98 : lmap-as ( cons quot exemplar -- seq )
99 [ lmap>array ] dip like ;
101 : cons>seq ( cons -- array )
102 [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ;
104 : list>seq ( list -- array )
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