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