1 !:folding=indent:collapseFolds=1:
5 ! Copyright (C) 2003, 2004 Slava Pestov.
7 ! Redistribution and use in source and binary forms, with or without
8 ! modification, are permitted provided that the following conditions are met:
10 ! 1. Redistributions of source code must retain the above copyright notice,
11 ! this list of conditions and the following disclaimer.
13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
14 ! this list of conditions and the following disclaimer in the documentation
15 ! and/or other materials provided with the distribution.
17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35 : 2list ( a b -- [ a b ] )
36 #! Construct a proper list of 2 elements.
39 : 3list ( a b c -- [ a b c ] )
40 #! Construct a proper list of 3 elements.
43 : 2rlist ( a b -- [ b a ] )
44 #! Construct a proper list of 2 elements in reverse stack order.
47 : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
48 #! Append two lists. The first list must be proper. A new
49 #! list is constructed by copying the first list and setting
50 #! its tail to the second.
51 over [ >r uncons r> append cons ] [ nip ] ifte ;
53 : add ( [ list1 ] elem -- [ list1 elem ] )
54 #! Push a new proper list with an element added to the end.
57 : caar ( list -- caar )
60 : cdar ( list -- cadr )
63 : cadr ( list -- cdar )
66 : cddr ( list -- cddr )
69 : clone-list-iter ( result list -- last [ ] )
70 #! DESTRUCTIVE. Helper word for 'clone-list'.
74 uncons >r unit tuck >r rplacd r> r>
77 : clone-list ( list -- list )
78 #! Push a shallow copy of a list.
80 uncons >r unit dup r> clone-list-iter swap rplacd
83 : contains ( element list -- remainder )
84 #! If the proper list contains the element, push the
85 #! remainder of the list, starting from the cell whose car
86 #! is elem. Otherwise push f.
97 : count ( n -- [ 1 2 3 ... n ] )
98 #! If n <= 0, pushes the empty list.
99 [ [ ] times* ] cons expand ;
101 : nth ( n list -- list[n] )
102 #! Gets the nth element of a proper list by successively
103 #! iterating down the cdr pointer.
104 #! Supplying n <= 0 pushes the first element of the list.
105 #! Supplying an argument beyond the end of the list raises
107 swap [ cdr ] times car ;
109 : last* ( list -- last )
110 #! Pushes last cons of a list.
111 #! For example, given a proper list, pushes a cons cell
112 #! whose car is the last element of the list, and whose cdr
114 [ dup cdr cons? ] [ cdr ] while ;
116 : last ( list -- last )
117 #! Pushes last element of a list. Since this pushes the
118 #! car of the last cons cell, the list may be an improper
122 : list? ( list -- boolean )
123 #! Proper list test. A proper list is either f, or a cons
124 #! cell whose cdr is a proper list.
135 : nappend ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
136 #! DESTRUCTIVE. Append two lists. The last node of the first
137 #! list is destructively modified to point to the second
138 #! list, unless the first list is f, in which case the
139 #! second list is returned.
140 over [ over last* rplacd ] [ nip ] ifte ;
142 : first ( list -- obj )
143 #! Push the head of the list, or f if the list is empty.
146 : next ( obj list -- obj )
147 #! Push the next object in the list after an object. Wraps
148 #! around to beginning of list if object is at the end.
150 ! Is there another entry in the list?
161 : nreverse-iter ( list cons -- list cons )
162 [ dup dup cdr 2swap rplacd nreverse-iter ] when* ;
164 : nreverse ( list -- list )
165 #! DESTRUCTIVE. Reverse the given list, without consing.
166 f swap nreverse-iter ;
169 R1 R2 A D C -- A C r:R1 r:R2 r:A r:D r:C >>~
172 r:R1 r:R2 r:A r:D r:C -- A R1 r:R1 r:R2 r:D r:C >>~
175 R1 r:R1X r:R2 r:D r:C -- R1 R2 D C >>~
178 r:R1 r:R2 r:A r:D r:C -- A R2 r:R1 r:R2 r:D r:C >>~
181 R2 r:R1 r:R2X r:D r:C -- R1 R2 D C >>~
183 : partition-iter ( ref ret1 ret2 list combinator -- ref ret1 ret2 )
184 #! Helper word for 'partition'.
186 ! Note this ifte must be in tail position!
187 >r uncons r> partition-iterI >r >r dup r> r> call [
188 partition-iterT{ cons }partition-iterT partition-iter
190 partition-iterF{ cons }partition-iterF partition-iter
194 ] ifte ; inline interpret-only
196 : partition ( ref list combinator -- list1 list2 )
197 #! Compare each element in a proper list against a
198 #! reference element using a combinator. The combinator's
199 #! return value determines if the element is prepended to
200 #! the first or second list.
201 #! The combinator must have stack effect:
202 #! ( ref element -- ? )
203 [ ] [ ] 2swap partition-iter rot drop ; inline interpret-only
205 : remove ( obj list -- list )
206 #! Remove all occurrences of the object from the list.
211 uncons swapd remove cons
217 : sort ( list comparator -- sorted )
218 #! Sort the elements in a proper list using a comparator.
219 #! The comparator must have stack effect:
221 #! To sort elements in descending order, return t if x < y.
222 #! To sort elements in ascending order, return t if x > y.
225 dup >r >r uncons dupd r> partition r>
232 ] ifte ; inline interpret-only
234 : num-sort ( list -- sorted )
235 #! Sorts the list into ascending numerical order.
239 DEFER: tree-contains?
241 : =-or-contains? ( element obj -- ? )
248 : tree-contains? ( element tree -- ? )
250 2dup car =-or-contains? [
256 ! don't bomb on dotted pairs
264 : unique ( elem list -- list )
265 #! Prepend an element to a proper list if it is not
266 #! already contained in the list.
273 : each ( [ list ] [ quotation ] -- )
274 #! Push each element of a proper list in turn, and apply a
275 #! quotation to each element.
277 #! In order to compile, the quotation must consume one more
278 #! value than it produces.
280 >r uncons r> tuck >r >r call r> r> each
283 ] ifte ; inline interpret-only
285 : inject ( list code -- list )
286 #! Applies the code to each item, returns a list that
287 #! contains the result of each application.
289 #! In order to compile, the quotation must consume as many
290 #! values as it produces.
292 ( accum code elem -- accum code )
293 transp over >r >r call r> cons r>
294 ] each drop nreverse ; inline interpret-only
296 : map ( [ items ] [ code ] -- [ mapping ] )
297 #! Applies the code to each item, returns a list that
298 #! contains the result of each application.
300 #! This combinator will not compile.
301 2list restack each unstack ; inline interpret-only
303 : subset-add ( car pred accum -- accum )
304 >r over >r call r> r> rot [ cons ] [ nip ] ifte ;
306 : subset-iter ( accum list pred -- accum )
308 >r unswons r> 2swap pick
309 >r >r subset-add r> r> subset-iter
314 : subset ( list pred -- list )
315 #! Applies a quotation to each element of a list; all
316 #! elements for which the quotation returned a value other
317 #! than f are collected in a new list.
319 #! In order to compile, the quotation must consume as many
320 #! values as it produces.
321 f -rot subset-iter nreverse ; inline interpret-only
323 : length ( list -- length )
324 #! Pushes the length of the given proper list.
325 0 swap [ drop succ ] each ;
327 : leaves ( list -- length )
328 #! Like length, but counts each sub-list recursively.
329 0 swap [ dup list? [ leaves + ] [ drop succ ] ifte ] each ;
331 : reverse ( list -- list )
332 #! Push a new list that is the reverse of a proper list.
333 [ ] swap [ swons ] each ;
335 : all? ( list pred -- ? )
336 #! Push if the predicate returns true for each element of
339 dup >r swap uncons >r swap call [
348 : car= swap car swap car = ;
349 : cdr= swap cdr swap cdr = ;
351 : cons= ( obj cons -- ? )
352 over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ;
354 : cons-hashcode ( cons count -- hash )
358 pred >r uncons r> tuck