libs/lazy-lists/lists.factor

   1 ! Copyright (C) 2004 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Updated by Matthew Willis, July 2006
   5 ! Updated by Chris Double, September 2006
   6 !
   7 USING: kernel sequences math vectors arrays namespaces generic errors ;
   8 IN: lazy-lists
   9
  10 ! Lazy List Protocol
  11 GENERIC: car   ( cons -- car )
  12 GENERIC: cdr   ( cons -- cdr )
  13 GENERIC: nil?  ( cons -- bool )
  14 GENERIC: list? ( object -- bool )
  15
  16 TUPLE: promise quot forced? value ;
  17
  18 C: promise ( quot -- promise ) [ set-promise-quot ] keep ;
  19
  20 : promise ( quot -- promise )
  21   <promise> ;
  22
  23 : promise-with ( value quot -- promise )
  24   curry <promise> ;
  25
  26 : promise-with2 ( value1 value2 quot -- promise )
  27   curry curry <promise> ;
  28
  29 : force ( promise -- value )
  30     #! Force the given promise leaving the value of calling the
  31     #! promises quotation on the stack. Re-forcing the promise
  32     #! will return the same value and not recall the quotation.
  33     dup promise-forced? [
  34         dup promise-quot call over set-promise-value
  35         t over set-promise-forced?
  36     ] unless
  37     promise-value ;
  38
  39 M: promise car ( promise -- car )
  40   force car ;
  41
  42 M: promise cdr ( promise -- cdr )
  43   force cdr ;
  44
  45 M: promise nil? ( cons -- bool )
  46   force nil? ;
  47
  48 M: promise list? ( object -- bool )
  49   drop t ;
  50
  51 TUPLE: cons car cdr ;
  52
  53 M: object list? ( object -- bool )
  54   drop f ;
  55
  56 C: cons ( car cdr -- list )
  57     [ set-cons-cdr ] keep
  58     [ set-cons-car ] keep ;
  59
  60 M: cons car ( cons -- car )
  61     cons-car ;
  62
  63 M: cons cdr ( cons -- cdr )
  64     cons-cdr ;
  65
  66 : nil ( -- cons )
  67   T{ cons f f f } ;
  68
  69 M: cons nil? ( cons -- bool )
  70     nil eq? ;
  71
  72 M: cons list? ( object -- bool )
  73   drop t ;
  74
  75 : cons ( car cdr -- list )
  76     <cons> ;
  77
  78 : 1list ( obj -- cons )
  79     nil <cons> ;
  80
  81 : 2list ( a b -- cons )
  82     nil <cons> <cons> ;
  83
  84 : 3list ( a b c -- cons )
  85     nil <cons> <cons> <cons> ;
  86
  87 ! Both 'car' and 'cdr' are promises
  88 TUPLE: lazy-cons car cdr ;
  89
  90 : lazy-cons ( car cdr -- promise )
  91     >r promise r> promise <lazy-cons>
  92     T{ promise f f t f } clone [ set-promise-value ] keep ;
  93
  94 M: lazy-cons car ( lazy-cons -- car )
  95     lazy-cons-car force ;
  96
  97 M: lazy-cons cdr ( lazy-cons -- cdr )
  98     lazy-cons-cdr force ;
  99
 100 M: lazy-cons nil? ( lazy-cons -- bool )
 101     nil eq? ;
 102
 103 M: lazy-cons list? ( object -- bool )
 104   drop t ;
 105
 106 DEFER: lunit
 107 DEFER: lnth
 108 TUPLE: list ;
 109
 110 : 1lazy-list ( a -- lazy-cons )
 111   [ nil ] lazy-cons ;
 112
 113 : 2lazy-list ( a b -- lazy-cons )
 114   1lazy-list unit lazy-cons ;
 115
 116 : 3lazy-list ( a b c -- lazy-cons )
 117   2lazy-list unit lazy-cons ;
 118
 119 : lnth ( n list -- elt )
 120   swap [ cdr ] times car ;
 121
 122 : uncons ( cons -- car cdr )
 123     #! Return the car and cdr of the lazy list
 124     dup car swap cdr ;
 125
 126 : leach ( list quot -- )
 127   swap dup nil? [
 128     2drop
 129   ] [
 130     uncons swap pick call swap leach
 131   ] if ;
 132
 133 : 2curry ( a b quot -- quot )
 134   curry curry ;
 135
 136 TUPLE: memoized-cons original car cdr nil? ;
 137
 138 : not-memoized ( -- obj )
 139   { } ;
 140
 141 : not-memoized? ( obj -- bool )
 142   not-memoized eq? ;
 143
 144 C: memoized-cons ( cons -- memoized-cons )
 145   [ set-memoized-cons-original ] keep
 146   not-memoized over set-memoized-cons-car
 147   not-memoized over set-memoized-cons-cdr
 148   not-memoized over set-memoized-cons-nil? ;
 149
 150 M: memoized-cons car ( memoized-cons -- car )
 151   dup memoized-cons-car not-memoized? [
 152     dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
 153   ] [
 154     memoized-cons-car
 155   ] if ;
 156
 157 M: memoized-cons cdr ( memoized-cons -- cdr )
 158   dup memoized-cons-cdr not-memoized? [
 159     dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
 160   ] [
 161     memoized-cons-cdr
 162   ] if ;
 163
 164 M: memoized-cons nil? ( memoized-cons -- bool )
 165   dup memoized-cons-nil? not-memoized? [
 166     dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
 167   ] [
 168     memoized-cons-nil?
 169   ] if ;
 170
 171 M: memoized-cons list? ( object -- bool )
 172   drop t ;
 173
 174 TUPLE: lazy-map cons quot ;
 175
 176 : lmap ( list quot -- result )
 177     over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
 178
 179 M: lazy-map car ( lazy-map -- car )
 180   [ lazy-map-cons car ] keep
 181   lazy-map-quot call ;
 182
 183 M: lazy-map cdr ( lazy-map -- cdr )
 184   [ lazy-map-cons cdr ] keep
 185   lazy-map-quot lmap ;
 186
 187 M: lazy-map nil? ( lazy-map -- bool )
 188   lazy-map-cons nil? ;
 189
 190 M: lazy-map list? ( object -- bool )
 191   drop t ;
 192
 193 TUPLE: lazy-map-with value cons quot ;
 194
 195 : lmap-with ( value list quot -- result )
 196   over nil? [ 3drop nil ] [ <lazy-map-with> <memoized-cons> ] if ;
 197
 198 M: lazy-map-with car ( lazy-map-with -- car )
 199   [ lazy-map-with-value ] keep
 200   [ lazy-map-with-cons car ] keep
 201   lazy-map-with-quot call ;
 202
 203 M: lazy-map-with cdr ( lazy-map-with -- cdr )
 204   [ lazy-map-with-value ] keep
 205   [ lazy-map-with-cons cdr ] keep
 206   lazy-map-with-quot lmap-with ;
 207
 208 M: lazy-map-with nil? ( lazy-map-with -- bool )
 209   lazy-map-with-cons nil? ;
 210
 211 M: lazy-map-with list? ( object -- bool )
 212   drop t ;
 213
 214 TUPLE: lazy-take n cons ;
 215
 216 : ltake ( n list -- result )
 217     over zero? [ 2drop nil ] [ <lazy-take> ] if ;
 218
 219 M: lazy-take car ( lazy-take -- car )
 220   lazy-take-cons car ;
 221
 222 M: lazy-take cdr ( lazy-take -- cdr )
 223   [ lazy-take-n 1- ] keep
 224   lazy-take-cons cdr ltake ;
 225
 226 M: lazy-take nil? ( lazy-take -- bool )
 227   dup lazy-take-n zero? [
 228     drop t
 229   ] [
 230     lazy-take-cons nil?
 231   ] if ;
 232
 233 M: lazy-take list? ( object -- bool )
 234   drop t ;
 235
 236 TUPLE: lazy-subset cons quot ;
 237
 238 : lsubset ( list quot -- list )
 239     over nil? [ 2drop nil ] [ <lazy-subset> <memoized-cons> ] if ;
 240
 241 : car-subset?  ( lazy-subset -- )
 242   [ lazy-subset-cons car ] keep
 243   lazy-subset-quot call ;
 244
 245 : skip ( lazy-subset -- )
 246   [ lazy-subset-cons cdr ] keep
 247   set-lazy-subset-cons ;
 248
 249 M: lazy-subset car ( lazy-subset -- car )
 250   dup car-subset? [
 251     lazy-subset-cons car
 252   ] [
 253     dup skip car
 254   ] if ;
 255
 256 M: lazy-subset cdr ( lazy-subset -- cdr )
 257   dup car-subset? [
 258     [ lazy-subset-cons cdr ] keep
 259     lazy-subset-quot lsubset
 260   ] [
 261     dup skip cdr
 262   ] if ;
 263
 264 M: lazy-subset nil? ( lazy-subset -- bool )
 265   dup lazy-subset-cons nil? [
 266     drop t
 267   ] [
 268     dup car-subset? [
 269       drop f
 270     ] [
 271       dup skip nil?
 272     ] if
 273   ] if ;
 274
 275 M: lazy-subset list? ( object -- bool )
 276   drop t ;
 277
 278 : list>vector ( list -- vector )
 279   [ [ , ] leach ] V{ } make ;
 280
 281 : list>array ( list -- array )
 282   [ [ , ] leach ] { } make ;
 283
 284 TUPLE: lazy-append list1 list2 ;
 285
 286 : lappend ( list1 list2 -- result )
 287   {
 288     { [ over nil? ] [ nip ] }
 289     { [ t ] [ <lazy-append> ] }
 290   } cond ;
 291
 292 M: lazy-append car ( lazy-append -- car )
 293   lazy-append-list1 car ;
 294
 295 M: lazy-append cdr ( lazy-append -- cdr )
 296   [ lazy-append-list1 cdr  ] keep
 297   lazy-append-list2 lappend ;
 298
 299 M: lazy-append nil? ( lazy-append -- bool )
 300   dup lazy-append-list1 nil? [
 301     lazy-append-list2 nil?
 302   ] [
 303     drop f
 304   ] if ;
 305
 306 M: lazy-append list? ( object -- bool )
 307   drop t ;
 308
 309 TUPLE: lazy-from-by n quot ;
 310
 311 : lfrom-by ( n quot -- list )
 312   <lazy-from-by> ;
 313
 314 : lfrom ( n -- list )
 315   [ 1 + ] lfrom-by ;
 316
 317 M: lazy-from-by car ( lazy-from-by -- car )
 318   lazy-from-by-n ;
 319
 320 M: lazy-from-by cdr ( lazy-from-by -- cdr )
 321   [ lazy-from-by-n ] keep
 322   lazy-from-by-quot dup >r call r> lfrom-by ;
 323
 324 M: lazy-from-by nil? ( lazy-from-by -- bool )
 325   drop f ;
 326
 327 M: lazy-from-by list? ( object -- bool )
 328   drop t ;
 329
 330 TUPLE: lazy-zip list1 list2 ;
 331
 332 : lzip ( list1 list2 -- lazy-zip )
 333     over nil? over nil? or
 334     [ 2drop nil ] [ <lazy-zip> ] if ;
 335
 336 M: lazy-zip car ( lazy-zip -- car )
 337     [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
 338
 339 M: lazy-zip cdr ( lazy-zip -- cdr )
 340     [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
 341
 342 M: lazy-zip nil? ( lazy-zip -- bool )
 343     drop f ;
 344
 345 M: lazy-zip list? ( object -- bool )
 346   drop t ;
 347
 348 TUPLE: sequence-cons index seq ;
 349
 350 : seq>list ( index seq -- list )
 351   2dup length >= [
 352     2drop nil
 353   ] [
 354     <sequence-cons>
 355   ] if ;
 356
 357 M: sequence-cons car ( sequence-cons -- car )
 358   [ sequence-cons-index ] keep
 359   sequence-cons-seq nth ;
 360
 361 M: sequence-cons cdr ( sequence-cons -- cdr )
 362   [ sequence-cons-index 1+ ] keep
 363   sequence-cons-seq seq>list ;
 364
 365 M: sequence-cons nil? ( sequence-cons -- bool )
 366     drop f ;
 367
 368 M: sequence-cons list? ( object -- bool )
 369   drop t ;
 370
 371 : >list ( object -- list )
 372   {
 373     { [ dup sequence? ] [ 0 swap seq>list ] }
 374     { [ dup list?     ] [ ] }
 375     { [ t ] [ "Could not convert object to a list" throw ] }
 376   } cond ;
 377
 378 TUPLE: lazy-concat car cdr ;
 379
 380 DEFER: lconcat
 381
 382 : (lconcat) ( car cdr -- list )
 383   over nil? [
 384     nip lconcat
 385   ] [
 386     <lazy-concat>
 387   ] if ;
 388
 389 : lconcat ( list -- list )
 390   dup nil? [
 391     drop nil
 392   ] [
 393     uncons (lconcat)
 394   ] if ;
 395
 396 M: lazy-concat car ( lazy-concat -- car )
 397   lazy-concat-car car ;
 398
 399 M: lazy-concat cdr ( lazy-concat -- cdr )
 400   [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
 401
 402 M: lazy-concat nil? ( lazy-concat -- bool )
 403   dup lazy-concat-car nil? [
 404     lazy-concat-cdr nil?
 405   ] [
 406     drop f
 407   ] if ;
 408
 409 M: lazy-concat list? ( object -- bool )
 410   drop t ;
 411
 412 : lcartesian-product ( list1 list2 -- result )
 413   swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
 414
 415 : lcartesian-product* ( lists -- result )
 416   dup nil? [
 417     drop nil
 418   ] [
 419     [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
 420       swap [ swap [ add ] lmap-with ] lmap-with lconcat
 421     ] reduce
 422   ] if ;
 423
 424 : lcomp ( list quot -- result )
 425   >r lcartesian-product* r> lmap ;
 426
 427 : lcomp* ( list guards quot -- result )
 428   >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;
 429
 430 DEFER: lmerge
 431
 432 : (lmerge) ( list1 list2 -- result )
 433   over [ car ] curry -rot
 434   [
 435     dup [ car ] curry -rot
 436     [
 437       >r cdr r> cdr lmerge
 438     ] curry curry lazy-cons
 439   ] curry curry lazy-cons ;
 440
 441 : lmerge ( list1 list2 -- result )
 442   {
 443     { [ over nil? ] [ nip   ] }
 444     { [ dup nil?  ]  [ drop ] }
 445     { [ t         ]  [ (lmerge) ] }
 446   } cond ;