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