library/lists.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  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.
  16 !
  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.
  27
  28 IN: lists
  29 USE: arithmetic
  30 USE: combinators
  31 USE: kernel
  32 USE: logic
  33 USE: stack
  34
  35 : 2list ( a b -- [ a b ] )
  36     #! Construct a proper list of 2 elements.
  37     unit cons ;
  38
  39 : 3list ( a b c -- [ a b c ] )
  40     #! Construct a proper list of 3 elements.
  41     2list cons ;
  42
  43 : 2rlist ( a b -- [ b a ] )
  44     #! Construct a proper list of 2 elements in reverse stack order.
  45     swap unit cons ;
  46
  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 ;
  52
  53 : add ( [ list1 ] elem -- [ list1 elem ] )
  54     #! Push a new proper list with an element added to the end.
  55     unit append ;
  56
  57 : caar ( list -- caar )
  58     car car ; inline
  59
  60 : cdar ( list -- cadr )
  61     cdr car ; inline
  62
  63 : cadr ( list -- cdar )
  64     car cdr ; inline
  65
  66 : cddr ( list -- cddr )
  67     cdr cdr ; inline
  68
  69 : clone-list-iter ( result list -- last [ ] )
  70     #! DESTRUCTIVE. Helper word for 'clone-list'.
  71     [
  72         dup cons?
  73     ] [
  74         uncons >r unit tuck >r rplacd r> r>
  75     ] while ;
  76
  77 : clone-list ( list -- list )
  78     #! Push a shallow copy of a list.
  79     dup [
  80         uncons >r unit dup r> clone-list-iter swap rplacd
  81     ] when ;
  82
  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.
  87     dup [
  88         2dup car = [
  89             nip
  90         ] [
  91             cdr contains
  92         ] ifte
  93     ] [
  94         2drop f
  95     ] ifte ;
  96
  97 : nth ( n list -- list[n] )
  98     #! Gets the nth element of a proper list by successively
  99     #! iterating down the cdr pointer.
 100     #! Supplying n <= 0 pushes the first element of the list.
 101     #! Supplying an argument beyond the end of the list raises
 102     #! an error.
 103     swap [ cdr ] times car ;
 104
 105 : last* ( list -- last )
 106     #! Pushes last cons of a list.
 107     #! For example, given a proper list, pushes a cons cell
 108     #! whose car is the last element of the list, and whose cdr
 109     #! is f.
 110     [ dup cdr cons? ] [ cdr ] while ;
 111
 112 : last ( list -- last )
 113     #! Pushes last element of a list. Since this pushes the
 114     #! car of the last cons cell, the list may be an improper
 115     #! list.
 116     last* car ;
 117
 118 : list? ( list -- boolean )
 119     #! Proper list test. A proper list is either f, or a cons
 120     #! cell whose cdr is a proper list.
 121     dup [
 122         dup cons? [
 123             cdr list?
 124         ] [
 125             drop f
 126         ] ifte
 127     ] [
 128         drop t
 129     ] ifte ;
 130
 131 : nappend ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
 132     #! DESTRUCTIVE. Append two lists. The last node of the first
 133     #! list is destructively modified to point to the second
 134     #! list, unless the first list is f, in which case the
 135     #! second list is returned.
 136     over [ over last* rplacd ] [ nip ] ifte ;
 137
 138 : first ( list -- obj )
 139     #! Push the head of the list, or f if the list is empty.
 140     dup [ car ] when ;
 141
 142 : next ( obj list -- obj )
 143     #! Push the next object in the list after an object. Wraps
 144     #! around to beginning of list if object is at the end.
 145     tuck contains dup [
 146         ! Is there another entry in the list?
 147         cdr dup [
 148             nip car
 149         ] [
 150             ! No. Pick first
 151             drop first
 152         ] ifte
 153     ] [
 154         drop first
 155     ] ifte ;
 156
 157 : nreverse-iter ( list cons -- list cons )
 158     [ dup dup cdr 2swap rplacd nreverse-iter ] when* ;
 159
 160 : nreverse ( list -- list )
 161     #! DESTRUCTIVE. Reverse the given list, without consing.
 162     f swap nreverse-iter ;
 163
 164 : partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
 165     >r >r [ r> cons r> ] [ r> r> swapd cons ] ifte ; inline
 166
 167 : partition-step ( ret1 ret2 ref combinator car -- ret1 ret2 )
 168     >r 2swap r> -rot >r >r dup >r swap call r> swap r> r>
 169     partition-add ; inline
 170
 171 : partition-iter ( ret1 ret2 ref combinator list -- ret1 ret2 )
 172     dup [
 173         3dup cdr >r >r >r
 174         car partition-step
 175         r> r> r> partition-iter
 176     ] [
 177         3drop
 178     ] ifte ; inline interpret-only
 179
 180 : partition ( ref list combinator -- list1 list2 )
 181     #! Compare each element in a proper list against a
 182     #! reference element using a combinator. The combinator's
 183     #! return value determines if the element is prepended to
 184     #! the first or second list.
 185     #! The combinator must have stack effect:
 186     #! ( ref element -- ? )
 187     swap >r >r >r [ ] [ ] r> r> r> partition-iter ;
 188     inline interpret-only
 189
 190 : sort ( list comparator -- sorted )
 191     #! Sort the elements in a proper list using a comparator.
 192     #! The comparator must have stack effect:
 193     #! ( x y -- ? )
 194     #! To sort elements in descending order, return t if x < y.
 195     #! To sort elements in ascending order, return t if x > y.
 196     over [
 197         ! Partition
 198         dup >r >r uncons dupd r> partition r>
 199         ! Recurse
 200         tuck sort >r sort r>
 201         ! Combine
 202         swapd cons nappend
 203     ] [
 204         drop
 205     ] ifte ; inline interpret-only
 206
 207 : num-sort ( list -- sorted )
 208     #! Sorts the list into ascending numerical order.
 209     [ > ] sort ;
 210
 211 : remove ( obj list -- list )
 212     #! Remove all occurrences of the object from the list.
 213     dup [
 214         2dup car = [
 215             cdr remove
 216         ] [
 217             uncons swapd remove cons
 218         ] ifte
 219     ] [
 220         nip
 221     ] ifte ;
 222
 223 ! Redefined below
 224 DEFER: tree-contains?
 225
 226 : =-or-contains? ( element obj -- ? )
 227     dup cons? [
 228         tree-contains?
 229     ] [
 230         =
 231     ] ifte ;
 232
 233 : tree-contains? ( element tree -- ? )
 234     dup [
 235         2dup car =-or-contains? [
 236             nip
 237         ] [
 238             cdr dup cons? [
 239                 tree-contains?
 240             ] [
 241                 ! don't bomb on dotted pairs
 242                 =-or-contains?
 243             ] ifte
 244         ] ifte
 245     ] [
 246         2drop f
 247     ] ifte ;
 248
 249 : unique ( elem list -- list )
 250     #! Prepend an element to a proper list if it is not
 251     #! already contained in the list.
 252     2dup contains [
 253         nip
 254     ] [
 255         cons
 256     ] ifte ;
 257
 258 : each ( [ list ] [ quotation ] -- )
 259     #! Push each element of a proper list in turn, and apply a
 260     #! quotation to each element.
 261     #!
 262     #! In order to compile, the quotation must consume one more
 263     #! value than it produces.
 264     over [
 265         >r uncons r> tuck >r >r call r> r> each
 266     ] [
 267         2drop
 268     ] ifte ; inline interpret-only
 269
 270 : inject ( list code -- list )
 271     #! Applies the code to each item, returns a list that
 272     #! contains the result of each application.
 273     #!
 274     #! In order to compile, the quotation must consume as many
 275     #! values as it produces.
 276     f transp [
 277         ( accum code elem -- accum code )
 278         transp over >r >r call r> cons r>
 279     ] each drop nreverse ; inline interpret-only
 280
 281 : subset-add ( car pred accum -- accum )
 282     >r over >r call r> r> rot [ cons ] [ nip ] ifte ;
 283
 284 : subset-iter ( accum list pred -- accum )
 285     over [
 286         >r unswons r> 2swap pick
 287         >r >r subset-add r> r> subset-iter
 288         ] [
 289         2drop
 290     ] ifte ;
 291
 292 : subset ( list pred -- list )
 293     #! Applies a quotation to each element of a list; all
 294     #! elements for which the quotation returned a value other
 295     #! than f are collected in a new list.
 296     #!
 297     #! In order to compile, the quotation must consume as many
 298     #! values as it produces.
 299     f -rot subset-iter nreverse ; inline interpret-only
 300
 301 : length ( list -- length )
 302     #! Pushes the length of the given proper list.
 303     0 swap [ drop succ ] each ;
 304
 305 : leaves ( list -- length )
 306     #! Like length, but counts each sub-list recursively.
 307     0 swap [ dup list? [ leaves + ] [ drop succ ] ifte ] each ;
 308
 309 : reverse ( list -- list )
 310     #! Push a new list that is the reverse of a proper list.
 311     [ ] swap [ swons ] each ;
 312
 313 : all? ( list pred -- ? )
 314     #! Push if the predicate returns true for each element of
 315     #! the list.
 316     over [
 317         dup >r swap uncons >r swap call [
 318             r> r> all?
 319         ] [
 320             r> drop r> drop f
 321         ] ifte
 322     ] [
 323         2drop t
 324     ] ifte ;
 325
 326 : car= swap car swap car = ;
 327 : cdr= swap cdr swap cdr = ;
 328
 329 : cons= ( obj cons -- ? )
 330     over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ;
 331
 332 : cons-hashcode ( cons count -- hash )
 333     dup 0 = [
 334         nip
 335     ] [
 336         pred >r uncons r> tuck
 337         cons-hashcode >r
 338         cons-hashcode r>
 339         xor
 340     ] ifte ;