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 : count ( n -- [ 1 2 3 ... n ] )
  98     #! If n <= 0, pushes the empty list.
  99     [ [ ] times* ] cons expand ;
 100
 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
 106     #! an error.
 107     swap [ cdr ] times car ;
 108
 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
 113     #! is f.
 114     [ dup cdr cons? ] [ cdr ] while ;
 115
 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
 119     #! list.
 120     last* car ;
 121
 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.
 125     dup [
 126         dup cons? [
 127             cdr list?
 128         ] [
 129             drop f
 130         ] ifte
 131     ] [
 132         drop t
 133     ] ifte ;
 134
 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 ;
 141
 142 : first ( list -- obj )
 143     #! Push the head of the list, or f if the list is empty.
 144     dup [ car ] when ;
 145
 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.
 149     tuck contains dup [
 150         ! Is there another entry in the list?
 151         cdr dup [
 152             nip car
 153         ] [
 154             ! No. Pick first
 155             drop first
 156         ] ifte
 157     ] [
 158         drop first
 159     ] ifte ;
 160
 161 : nreverse-iter ( list cons -- list cons )
 162     [ dup dup cdr 2swap rplacd nreverse-iter ] when* ;
 163
 164 : nreverse ( list -- list )
 165     #! DESTRUCTIVE. Reverse the given list, without consing.
 166     f swap nreverse-iter ;
 167
 168 ~<< partition-iterI
 169     R1 R2 A D C -- A C r:R1 r:R2 r:A r:D r:C >>~
 170
 171 ~<< partition-iterT{
 172     r:R1 r:R2 r:A r:D r:C -- A R1 r:R1 r:R2 r:D r:C >>~
 173
 174 ~<< }partition-iterT
 175     R1 r:R1X r:R2 r:D r:C -- R1 R2 D C >>~
 176
 177 ~<< partition-iterF{
 178     r:R1 r:R2 r:A r:D r:C -- A R2 r:R1 r:R2 r:D r:C >>~
 179
 180 ~<< }partition-iterF
 181     R2 r:R1 r:R2X r:D r:C -- R1 R2 D C >>~
 182
 183 : partition-iter ( ref ret1 ret2 list combinator -- ref ret1 ret2 )
 184     #! Helper word for 'partition'.
 185     over [
 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
 189         ] [
 190             partition-iterF{ cons }partition-iterF partition-iter
 191         ] ifte
 192     ] [
 193         2drop
 194     ] ifte ; inline interpret-only
 195
 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
 204
 205 : remove ( obj list -- list )
 206     #! Remove all occurrences of the object from the list.
 207     dup [
 208         2dup car = [
 209             cdr remove
 210         ] [
 211             uncons swapd remove cons
 212         ] ifte
 213     ] [
 214         nip
 215     ] ifte ;
 216
 217 : sort ( list comparator -- sorted )
 218     #! Sort the elements in a proper list using a comparator.
 219     #! The comparator must have stack effect:
 220     #! ( x y -- ? )
 221     #! To sort elements in descending order, return t if x < y.
 222     #! To sort elements in ascending order, return t if x > y.
 223     over [
 224         ! Partition
 225         dup >r >r uncons dupd r> partition r>
 226         ! Recurse
 227         tuck sort >r sort r>
 228         ! Combine
 229         swapd cons nappend
 230     ] [
 231         drop
 232     ] ifte ; inline interpret-only
 233
 234 : num-sort ( list -- sorted )
 235     #! Sorts the list into ascending numerical order.
 236     [ > ] sort ;
 237
 238 ! Redefined below
 239 DEFER: tree-contains?
 240
 241 : =-or-contains? ( element obj -- ? )
 242     dup cons? [
 243         tree-contains?
 244     ] [
 245         =
 246     ] ifte ;
 247
 248 : tree-contains? ( element tree -- ? )
 249     dup [
 250         2dup car =-or-contains? [
 251             nip
 252         ] [
 253             cdr dup cons? [
 254                 tree-contains?
 255             ] [
 256                 ! don't bomb on dotted pairs
 257                 =-or-contains?
 258             ] ifte
 259         ] ifte
 260     ] [
 261         2drop f
 262     ] ifte ;
 263
 264 : unique ( elem list -- list )
 265     #! Prepend an element to a proper list if it is not
 266     #! already contained in the list.
 267     2dup contains [
 268         nip
 269     ] [
 270         cons
 271     ] ifte ;
 272
 273 : each ( [ list ] [ quotation ] -- )
 274     #! Push each element of a proper list in turn, and apply a
 275     #! quotation to each element.
 276     #!
 277     #! In order to compile, the quotation must consume one more
 278     #! value than it produces.
 279     over [
 280         >r uncons r> tuck >r >r call r> r> each
 281     ] [
 282         2drop
 283     ] ifte ; inline interpret-only
 284
 285 : inject ( list code -- list )
 286     #! Applies the code to each item, returns a list that
 287     #! contains the result of each application.
 288     #!
 289     #! In order to compile, the quotation must consume as many
 290     #! values as it produces.
 291     f transp [
 292         ( accum code elem -- accum code )
 293         transp over >r >r call r> cons r>
 294     ] each drop nreverse ; inline interpret-only
 295
 296 : map ( [ items ] [ code ] -- [ mapping ] )
 297     #! Applies the code to each item, returns a list that
 298     #! contains the result of each application.
 299     #!
 300     #! This combinator will not compile.
 301     2list restack each unstack ; inline interpret-only
 302
 303 : subset-add ( car pred accum -- accum )
 304     >r over >r call r> r> rot [ cons ] [ nip ] ifte ;
 305
 306 : subset-iter ( accum list pred -- accum )
 307     over [
 308         >r unswons r> 2swap pick
 309         >r >r subset-add r> r> subset-iter
 310         ] [
 311         2drop
 312     ] ifte ;
 313
 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.
 318     #!
 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
 322
 323 : length ( list -- length )
 324     #! Pushes the length of the given proper list.
 325     0 swap [ drop succ ] each ;
 326
 327 : leaves ( list -- length )
 328     #! Like length, but counts each sub-list recursively.
 329     0 swap [ dup list? [ leaves + ] [ drop succ ] ifte ] each ;
 330
 331 : reverse ( list -- list )
 332     #! Push a new list that is the reverse of a proper list.
 333     [ ] swap [ swons ] each ;
 334
 335 : all? ( list pred -- ? )
 336     #! Push if the predicate returns true for each element of
 337     #! the list.
 338     over [
 339         dup >r swap uncons >r swap call [
 340             r> r> all?
 341         ] [
 342             r> drop r> drop f
 343         ] ifte
 344     ] [
 345         2drop t
 346     ] ifte ;
 347
 348 : car= swap car swap car = ;
 349 : cdr= swap cdr swap cdr = ;
 350
 351 : cons= ( obj cons -- ? )
 352     over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ;
 353
 354 : cons-hashcode ( cons count -- hash )
 355     dup 0 = [
 356         nip
 357     ] [
 358         pred >r uncons r> tuck
 359         cons-hashcode >r
 360         cons-hashcode r>
 361         xor
 362     ] ifte ;