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 ;
   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-state car cdr ;
  18
  19 : lazy-cons ( car cdr -- promise )
  20     [ T{ promise f f t f } clone ] 2dip
  21     [ <promise> ] bi@ \ lazy-cons-state boa
  22     >>value ;
  23
  24 M: lazy-cons-state car ( lazy-cons -- car )
  25     car>> force ;
  26
  27 M: lazy-cons-state cdr ( lazy-cons -- cdr )
  28     cdr>> force ;
  29
  30 M: lazy-cons-state 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-state cons quot ;
  74
  75 C: <lazy-map-state> lazy-map-state
  76
  77 : lazy-map ( list quot -- result )
  78     over nil? [ 2drop nil ] [ <lazy-map-state> <memoized-cons> ] if ;
  79
  80 M: lazy-map-state car ( lazy-map -- car )
  81     [ cons>> car ] [ quot>> call( old -- new ) ] bi ;
  82
  83 M: lazy-map-state cdr ( lazy-map -- cdr )
  84     [ cons>> cdr ] [ quot>> lazy-map ] bi ;
  85
  86 M: lazy-map-state 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>> cdr ] [ quot>> ] bi ]
 118     [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi
 119     [ 2drop nil ] [ luntil ] if ;
 120
 121 M: lazy-until nil? ( lazy-until -- ? )
 122     drop f ;
 123
 124 TUPLE: lazy-while cons quot ;
 125
 126 C: <lazy-while> lazy-while
 127
 128 : lwhile ( list quot -- result )
 129     over nil? [ drop ] [ <lazy-while> ] if ;
 130
 131 M: lazy-while car ( lazy-while -- car )
 132     cons>> car ;
 133
 134 M: lazy-while cdr ( lazy-while -- cdr )
 135     [ cons>> cdr ] keep quot>> lwhile ;
 136
 137 M: lazy-while nil? ( lazy-while -- ? )
 138     [ car ] keep quot>> call( elt -- ? ) not ;
 139
 140 TUPLE: lazy-filter cons quot ;
 141
 142 C: <lazy-filter> lazy-filter
 143
 144 : lfilter ( list quot -- result )
 145     over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
 146
 147 : car-filter? ( lazy-filter -- ? )
 148     [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
 149
 150 : skip ( lazy-filter -- )
 151     dup cons>> cdr >>cons drop ;
 152
 153 M: lazy-filter car ( lazy-filter -- car )
 154     dup car-filter? [ cons>> ] [ dup skip ] if car ;
 155
 156 M: lazy-filter cdr ( lazy-filter -- cdr )
 157     dup car-filter? [
 158         [ cons>> cdr ] [ quot>> ] bi lfilter
 159     ] [
 160         dup skip cdr
 161     ] if ;
 162
 163 M: lazy-filter nil? ( lazy-filter -- ? )
 164     dup cons>> nil? [
 165         drop t
 166     ] [
 167         dup car-filter? [
 168             drop f
 169         ] [
 170             dup skip nil?
 171         ] if
 172     ] if ;
 173
 174 TUPLE: lazy-append list1 list2 ;
 175
 176 C: <lazy-append> lazy-append
 177
 178 : lappend ( list1 list2 -- result )
 179     over nil? [ nip ] [ <lazy-append> ] if ;
 180
 181 M: lazy-append car ( lazy-append -- car )
 182     list1>> car ;
 183
 184 M: lazy-append cdr ( lazy-append -- cdr )
 185     [ list1>> cdr ] [ list2>> ] bi lappend ;
 186
 187 M: lazy-append nil? ( lazy-append -- ? )
 188      drop f ;
 189
 190 TUPLE: lazy-from-by n quot ;
 191
 192 : lfrom-by ( n quot: ( n -- o ) -- lazy-from-by ) lazy-from-by boa ; inline
 193
 194 : lfrom ( n -- list )
 195     [ 1 + ] lfrom-by ;
 196
 197 M: lazy-from-by car ( lazy-from-by -- car )
 198     n>> ;
 199
 200 M: lazy-from-by cdr ( lazy-from-by -- cdr )
 201     [ n>> ] keep
 202     quot>> [ call( old -- new ) ] keep lfrom-by ;
 203
 204 M: lazy-from-by nil? ( lazy-from-by -- ? )
 205     drop f ;
 206
 207 TUPLE: lazy-zip list1 list2 ;
 208
 209 C: <lazy-zip> lazy-zip
 210
 211 : lzip ( list1 list2 -- lazy-zip )
 212         over nil? over nil? or
 213         [ 2drop nil ] [ <lazy-zip> ] if ;
 214
 215 M: lazy-zip car ( lazy-zip -- car )
 216         [ list1>> car ] keep list2>> car 2array ;
 217
 218 M: lazy-zip cdr ( lazy-zip -- cdr )
 219         [ list1>> cdr ] keep list2>> cdr lzip ;
 220
 221 M: lazy-zip nil? ( lazy-zip -- ? )
 222         drop f ;
 223
 224 TUPLE: sequence-cons index seq ;
 225
 226 C: <sequence-cons> sequence-cons
 227
 228 : sequence-tail>list ( index seq -- list )
 229     2dup length >= [
 230         2drop nil
 231     ] [
 232         <sequence-cons>
 233     ] if ;
 234
 235 M: sequence-cons car ( sequence-cons -- car )
 236     [ index>> ] [ seq>> nth ] bi ;
 237
 238 M: sequence-cons cdr ( sequence-cons -- cdr )
 239     [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
 240
 241 M: sequence-cons nil? ( sequence-cons -- ? )
 242     drop f ;
 243
 244 M: sequence >list 0 swap sequence-tail>list ;
 245
 246 TUPLE: lazy-concat car cdr ;
 247
 248 C: <lazy-concat> lazy-concat
 249
 250 DEFER: lconcat
 251
 252 : (lconcat) ( car cdr -- list )
 253     over nil? [ nip lconcat ] [ <lazy-concat> ] if ;
 254
 255 : lconcat ( list -- result )
 256     dup nil? [ drop nil ] [ uncons (lconcat) ] if ;
 257
 258 M: lazy-concat car ( lazy-concat -- car )
 259     car>> car ;
 260
 261 M: lazy-concat cdr ( lazy-concat -- cdr )
 262     [ car>> cdr ] keep cdr>> (lconcat) ;
 263
 264 M: lazy-concat nil? ( lazy-concat -- ? )
 265     dup car>> nil? [ cdr>> nil?  ] [ drop f ] if ;
 266
 267 : lcartesian-product ( list1 list2 -- result )
 268     swap [ swap [ 2array ] with lazy-map  ] with lazy-map  lconcat ;
 269
 270 : lcartesian-product* ( lists -- result )
 271     dup nil? [
 272         drop nil
 273     ] [
 274         uncons
 275         [ car lcartesian-product ] [ cdr ] bi
 276         list>array swap [
 277             swap [ swap [ suffix ] with lazy-map  ] with lazy-map  lconcat
 278         ] reduce
 279     ] if ;
 280
 281 : lcomp ( list quot -- result )
 282     [ lcartesian-product* ] dip lazy-map ;
 283
 284 : lcomp* ( list guards quot -- result )
 285     [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
 286
 287 DEFER: lmerge
 288
 289 : (lmerge) ( list1 list2 -- result )
 290     over [ car ] curry -rot
 291     [
 292         dup [ car ] curry -rot
 293         [
 294             [ cdr ] bi@ lmerge
 295         ] 2curry lazy-cons
 296     ] 2curry lazy-cons ;
 297
 298 : lmerge ( list1 list2 -- result )
 299     {
 300         { [ over nil? ] [ nip ] }
 301         { [ dup nil? ] [ drop ] }
 302         { [ t ] [ (lmerge) ] }
 303     } cond ;
 304
 305 TUPLE: lazy-io stream car cdr quot ;
 306
 307 C: <lazy-io> lazy-io
 308
 309 : lcontents ( stream -- result )
 310     f f [ stream-read1 ] <lazy-io> ;
 311
 312 : llines ( stream -- result )
 313     f f [ stream-readln ] <lazy-io> ;
 314
 315 M: lazy-io car ( lazy-io -- car )
 316     dup car>> [
 317         nip
 318     ] [
 319         [ ] [ stream>> ] [ quot>> ] tri
 320         call( stream -- value ) [ >>car ] [ drop nil ] if*
 321     ] if* ;
 322
 323 M: lazy-io cdr ( lazy-io -- cdr )
 324     dup cdr>> dup [
 325         nip
 326     ] [
 327         drop dup
 328         [ stream>> ]
 329         [ quot>> ]
 330         [ car ] tri [
 331             [ f f ] dip <lazy-io> [ >>cdr drop ] keep
 332         ] [
 333             3drop nil
 334         ] if
 335     ] if ;
 336
 337 M: lazy-io nil? ( lazy-io -- ? )
 338     car nil? ;
 339
 340 INSTANCE: sequence-cons list
 341 INSTANCE: memoized-cons list
 342 INSTANCE: promise list
 343 INSTANCE: lazy-io list
 344 INSTANCE: lazy-concat list
 345 INSTANCE: lazy-cons-state list
 346 INSTANCE: lazy-map-state list
 347 INSTANCE: lazy-take list
 348 INSTANCE: lazy-append list
 349 INSTANCE: lazy-from-by list
 350 INSTANCE: lazy-zip list
 351 INSTANCE: lazy-while list
 352 INSTANCE: lazy-until list
 353 INSTANCE: lazy-filter list