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