contrib/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   lazy-take-n zero? ;
 228
 229 M: lazy-take list? ( object -- bool )
 230   drop t ;
 231
 232 TUPLE: lazy-subset cons quot ;
 233
 234 : lsubset ( list quot -- list )
 235     over nil? [ 2drop nil ] [ <lazy-subset> <memoized-cons> ] if ;
 236
 237 : car-subset?  ( lazy-subset -- )
 238   [ lazy-subset-cons car ] keep
 239   lazy-subset-quot call ;
 240
 241 : skip ( lazy-subset -- )
 242   [ lazy-subset-cons cdr ] keep
 243   set-lazy-subset-cons ;
 244
 245 M: lazy-subset car ( lazy-subset -- car )
 246   dup car-subset? [
 247     lazy-subset-cons car
 248   ] [
 249     dup skip car
 250   ] if ;
 251
 252 M: lazy-subset cdr ( lazy-subset -- cdr )
 253   dup car-subset? [
 254     [ lazy-subset-cons cdr ] keep
 255     lazy-subset-quot lsubset
 256   ] [
 257     dup skip cdr
 258   ] if ;
 259
 260 M: lazy-subset nil? ( lazy-subset -- bool )
 261   dup lazy-subset-cons nil? [
 262     drop t
 263   ] [
 264     dup car-subset? [
 265       drop f
 266     ] [
 267       dup skip nil?
 268     ] if
 269   ] if ;
 270
 271 M: lazy-subset list? ( object -- bool )
 272   drop t ;
 273
 274 : list>vector ( list -- vector )
 275   [ [ , ] leach ] V{ } make ;
 276
 277 : list>array ( list -- array )
 278   [ [ , ] leach ] { } make ;
 279
 280 TUPLE: lazy-append list1 list2 ;
 281
 282 : lappend ( list1 list2 -- result )
 283   {
 284     { [ over nil? ] [ nip ] }
 285     { [ t ] [ <lazy-append> ] }
 286   } cond ;
 287
 288 M: lazy-append car ( lazy-append -- car )
 289   lazy-append-list1 car ;
 290
 291 M: lazy-append cdr ( lazy-append -- cdr )
 292   [ lazy-append-list1 cdr  ] keep
 293   lazy-append-list2 lappend ;
 294
 295 M: lazy-append nil? ( lazy-append -- bool )
 296   dup lazy-append-list1 nil? [
 297     lazy-append-list2 nil?
 298   ] [
 299     drop f
 300   ] if ;
 301
 302 M: lazy-append list? ( object -- bool )
 303   drop t ;
 304
 305 TUPLE: lazy-from-by n quot ;
 306
 307 : lfrom-by ( n quot -- list )
 308   <lazy-from-by> ;
 309
 310 : lfrom ( n -- list )
 311   [ 1 + ] lfrom-by ;
 312
 313 M: lazy-from-by car ( lazy-from-by -- car )
 314   lazy-from-by-n ;
 315
 316 M: lazy-from-by cdr ( lazy-from-by -- cdr )
 317   [ lazy-from-by-n ] keep
 318   lazy-from-by-quot dup >r call r> lfrom-by ;
 319
 320 M: lazy-from-by nil? ( lazy-from-by -- bool )
 321   drop f ;
 322
 323 M: lazy-from-by list? ( object -- bool )
 324   drop t ;
 325
 326 TUPLE: lazy-zip list1 list2 ;
 327
 328 : lzip ( list1 list2 -- lazy-zip )
 329     over nil? over nil? or
 330     [ 2drop nil ] [ <lazy-zip> ] if ;
 331
 332 M: lazy-zip car ( lazy-zip -- car )
 333     [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
 334
 335 M: lazy-zip cdr ( lazy-zip -- cdr )
 336     [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
 337
 338 M: lazy-zip nil? ( lazy-zip -- bool )
 339     drop f ;
 340
 341 M: lazy-zip list? ( object -- bool )
 342   drop t ;
 343
 344 TUPLE: sequence-cons index seq ;
 345
 346 : seq>list ( index seq -- list )
 347   2dup length >= [
 348     2drop nil
 349   ] [
 350     <sequence-cons>
 351   ] if ;
 352
 353 M: sequence-cons car ( sequence-cons -- car )
 354   [ sequence-cons-index ] keep
 355   sequence-cons-seq nth ;
 356
 357 M: sequence-cons cdr ( sequence-cons -- cdr )
 358   [ sequence-cons-index 1+ ] keep
 359   sequence-cons-seq seq>list ;
 360
 361 M: sequence-cons nil? ( sequence-cons -- bool )
 362     drop f ;
 363
 364 M: sequence-cons list? ( object -- bool )
 365   drop t ;
 366
 367 : >list ( object -- list )
 368   {
 369     { [ dup sequence? ] [ 0 swap seq>list ] }
 370     { [ dup list?     ] [ ] }
 371     { [ t ] [ "Could not convert object to a list" throw ] }
 372   } cond ;
 373
 374 TUPLE: lazy-concat car cdr ;
 375
 376 DEFER: lconcat
 377
 378 : (lconcat) ( car cdr -- list )
 379   over nil? [
 380     nip lconcat
 381   ] [
 382     <lazy-concat>
 383   ] if ;
 384
 385 : lconcat ( list -- list )
 386   dup nil? [
 387     drop nil
 388   ] [
 389     uncons (lconcat)
 390   ] if ;
 391
 392 M: lazy-concat car ( lazy-concat -- car )
 393   lazy-concat-car car ;
 394
 395 M: lazy-concat cdr ( lazy-concat -- cdr )
 396   [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
 397
 398 M: lazy-concat nil? ( lazy-concat -- bool )
 399   dup lazy-concat-car nil? [
 400     lazy-concat-cdr nil?
 401   ] [
 402     drop f
 403   ] if ;
 404
 405 M: lazy-concat list? ( object -- bool )
 406   drop t ;
 407
 408 : lcartesian-product ( list1 list2 -- result )
 409   swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
 410
 411 : lcartesian-product* ( lists -- result )
 412   dup nil? [
 413     drop nil
 414   ] [
 415     [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
 416       swap [ swap [ add ] lmap-with ] lmap-with lconcat
 417     ] reduce
 418   ] if ;
 419
 420 : lcomp ( list quot -- result )
 421   >r lcartesian-product* r> lmap ;
 422
 423 : lcomp* ( list guards quot -- result )
 424   >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;