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