basis/lists/lazy/lazy.factor

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