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