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 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 ] keep
 164     quot>> call ;
 165
 166 : skip ( lazy-filter -- )
 167     dup cons>> cdr >>cons ;
 168
 169 M: lazy-filter car ( lazy-filter -- car )
 170     dup car-filter? [ cons>> ] [ dup skip ] if car ;
 171
 172 M: lazy-filter cdr ( lazy-filter -- cdr )
 173     dup car-filter? [
 174         [ cons>> cdr ] keep
 175         quot>> lfilter
 176     ] [
 177         dup skip cdr
 178     ] if ;
 179
 180 M: lazy-filter nil? ( lazy-filter -- bool )
 181     dup cons>> nil? [
 182         drop t
 183     ] [
 184         dup car-filter? [
 185             drop f
 186         ] [
 187             dup skip nil?
 188         ] if
 189     ] if ;
 190
 191 : list>vector ( list -- vector )
 192     [ [ , ] leach ] V{ } make ;
 193
 194 : list>array ( list -- array )
 195     [ [ , ] leach ] { } make ;
 196
 197 TUPLE: lazy-append list1 list2 ;
 198
 199 C: <lazy-append> lazy-append
 200
 201 : lappend ( list1 list2 -- result )
 202     over nil? [ nip ] [ <lazy-append> ] if ;
 203
 204 M: lazy-append car ( lazy-append -- car )
 205     list1>> car ;
 206
 207 M: lazy-append cdr ( lazy-append -- cdr )
 208     [ list1>> cdr    ] keep
 209     list2>> lappend ;
 210
 211 M: lazy-append nil? ( lazy-append -- bool )
 212      drop f ;
 213
 214 TUPLE: lazy-from-by n quot ;
 215
 216 C: lfrom-by lazy-from-by ( n quot -- list )
 217
 218 : lfrom ( n -- list )
 219     [ 1+ ] lfrom-by ;
 220
 221 M: lazy-from-by car ( lazy-from-by -- car )
 222     n>> ;
 223
 224 M: lazy-from-by cdr ( lazy-from-by -- cdr )
 225     [ n>> ] keep
 226     quot>> dup slip lfrom-by ;
 227
 228 M: lazy-from-by nil? ( lazy-from-by -- bool )
 229     drop f ;
 230
 231 TUPLE: lazy-zip list1 list2 ;
 232
 233 C: <lazy-zip> lazy-zip
 234
 235 : lzip ( list1 list2 -- lazy-zip )
 236         over nil? over nil? or
 237         [ 2drop nil ] [ <lazy-zip> ] if ;
 238
 239 M: lazy-zip car ( lazy-zip -- car )
 240         [ list1>> car ] keep list2>> car 2array ;
 241
 242 M: lazy-zip cdr ( lazy-zip -- cdr )
 243         [ list1>> cdr ] keep list2>> cdr lzip ;
 244
 245 M: lazy-zip nil? ( lazy-zip -- bool )
 246         drop f ;
 247
 248 TUPLE: sequence-cons index seq ;
 249
 250 C: <sequence-cons> sequence-cons
 251
 252 : seq>list ( index seq -- list )
 253     2dup length >= [
 254         2drop nil
 255     ] [
 256         <sequence-cons>
 257     ] if ;
 258
 259 M: sequence-cons car ( sequence-cons -- car )
 260     [ index>> ] keep
 261     seq>> nth ;
 262
 263 M: sequence-cons cdr ( sequence-cons -- cdr )
 264     [ index>> 1+ ] keep
 265     seq>> seq>list ;
 266
 267 M: sequence-cons nil? ( sequence-cons -- bool )
 268         drop f ;
 269
 270 : >list ( object -- list )
 271     {
 272         { [ dup sequence? ] [ 0 swap seq>list ] }
 273         { [ dup list?         ] [ ] }
 274         [ "Could not convert object to a list" throw ]
 275     } cond ;
 276
 277 TUPLE: lazy-concat car cdr ;
 278
 279 C: <lazy-concat> lazy-concat
 280
 281 DEFER: lconcat
 282
 283 : (lconcat) ( car cdr -- list )
 284     over nil? [
 285         nip lconcat
 286     ] [
 287         <lazy-concat>
 288     ] if ;
 289
 290 : lconcat ( list -- result )
 291     dup nil? [
 292         drop nil
 293     ] [
 294         uncons swap (lconcat)
 295     ] if ;
 296
 297 M: lazy-concat car ( lazy-concat -- car )
 298     car>> car ;
 299
 300 M: lazy-concat cdr ( lazy-concat -- cdr )
 301     [ car>> cdr ] keep cdr>> (lconcat) ;
 302
 303 M: lazy-concat nil? ( lazy-concat -- bool )
 304     dup car>> nil? [
 305         cdr>> nil?
 306     ] [
 307         drop f
 308     ] if ;
 309
 310 : lcartesian-product ( list1 list2 -- result )
 311     swap [ swap [ 2array ] lazy-map-with  ] lazy-map-with  lconcat ;
 312
 313 : lcartesian-product* ( lists -- result )
 314     dup nil? [
 315         drop nil
 316     ] [
 317         [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
 318             swap [ swap [ suffix ] lazy-map-with  ] lazy-map-with  lconcat
 319         ] reduce
 320     ] if ;
 321
 322 : lcomp ( list quot -- result )
 323     [ lcartesian-product* ] dip lazy-map ;
 324
 325 : lcomp* ( list guards quot -- result )
 326     [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
 327
 328 DEFER: lmerge
 329
 330 : (lmerge) ( list1 list2 -- result )
 331     over [ car ] curry -rot
 332     [
 333         dup [ car ] curry -rot
 334         [
 335             [ cdr ] bi@ lmerge
 336         ] 2curry lazy-cons
 337     ] 2curry lazy-cons ;
 338
 339 : lmerge ( list1 list2 -- result )
 340     {
 341         { [ over nil? ] [ nip     ] }
 342         { [ dup nil?    ]    [ drop ] }
 343         { [ t                 ]    [ (lmerge) ] }
 344     } cond ;
 345
 346 TUPLE: lazy-io stream car cdr quot ;
 347
 348 C: <lazy-io> lazy-io
 349
 350 : lcontents ( stream -- result )
 351     f f [ stream-read1 ] <lazy-io> ;
 352
 353 : llines ( stream -- result )
 354     f f [ stream-readln ] <lazy-io> ;
 355
 356 M: lazy-io car ( lazy-io -- car )
 357     dup car>> dup [
 358         nip
 359     ] [
 360         drop dup stream>> over quot>> call
 361         swap dupd set-lazy-io-car
 362     ] if ;
 363
 364 M: lazy-io cdr ( lazy-io -- cdr )
 365     dup cdr>> dup [
 366         nip
 367     ] [
 368         drop dup
 369         [ stream>> ] keep
 370         [ quot>> ] keep
 371         car [
 372             [ f f ] dip <lazy-io> [ >>cdr drop ] keep
 373         ] [
 374             3drop nil
 375         ] if
 376     ] if ;
 377
 378 M: lazy-io nil? ( lazy-io -- bool )
 379     car not ;
 380
 381 INSTANCE: sequence-cons list
 382 INSTANCE: memoized-cons list
 383 INSTANCE: promise list
 384 INSTANCE: lazy-io list
 385 INSTANCE: lazy-concat list
 386 INSTANCE: lazy-cons list
 387 INSTANCE: lazy-map list
 388 INSTANCE: lazy-take list
 389 INSTANCE: lazy-append list
 390 INSTANCE: lazy-from-by list
 391 INSTANCE: lazy-zip list
 392 INSTANCE: lazy-while list
 393 INSTANCE: lazy-until list
 394 INSTANCE: lazy-filter list