extra/cursors/cursors.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors assocs combinators.short-circuit fry
   3 generalizations hash-sets hashtables kernel macros math
   4 math.functions math.order sequences sets ;
   5 FROM: sequences.private => nth-unsafe set-nth-unsafe ;
   6 FROM: hashtables.private => tombstone? ;
   7 IN: cursors
   8
   9 !
  10 ! basic cursor protocol
  11 !
  12
  13 MIXIN: cursor
  14
  15 GENERIC: cursor-compatible? ( cursor cursor -- ? )
  16 GENERIC: cursor-valid? ( cursor -- ? )
  17 GENERIC: cursor= ( cursor cursor -- ? )
  18 GENERIC: cursor<= ( cursor cursor -- ? )
  19 GENERIC: cursor>= ( cursor cursor -- ? )
  20 GENERIC: cursor-distance-hint ( cursor cursor -- n )
  21
  22 M: cursor cursor<= cursor= ; inline
  23 M: cursor cursor>= cursor= ; inline
  24 M: cursor cursor-distance-hint 2drop 0 ; inline
  25
  26 !
  27 ! cursor iteration
  28 !
  29
  30 MIXIN: forward-cursor
  31 INSTANCE: forward-cursor cursor
  32
  33 GENERIC: inc-cursor ( cursor -- cursor' )
  34
  35 MIXIN: bidirectional-cursor
  36 INSTANCE: bidirectional-cursor forward-cursor
  37
  38 GENERIC: dec-cursor ( cursor -- cursor' )
  39
  40 MIXIN: random-access-cursor
  41 INSTANCE: random-access-cursor bidirectional-cursor
  42
  43 GENERIC# cursor+ 1 ( cursor n -- cursor' )
  44 GENERIC# cursor- 1 ( cursor n -- cursor' )
  45 GENERIC: cursor-distance ( cursor cursor -- n )
  46 GENERIC: cursor<  ( cursor cursor -- ? )
  47 GENERIC: cursor>  ( cursor cursor -- ? )
  48
  49 M: random-access-cursor inc-cursor  1 cursor+ ; inline
  50 M: random-access-cursor dec-cursor -1 cursor+ ; inline
  51 M: random-access-cursor cursor- neg cursor+ ; inline
  52 M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline
  53 M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline
  54 M: random-access-cursor cursor-distance-hint cursor-distance ; inline
  55
  56 !
  57 ! input cursors
  58 !
  59
  60 ERROR: invalid-cursor cursor ;
  61
  62 MIXIN: input-cursor
  63
  64 GENERIC: cursor-key-value ( cursor -- key value )
  65 <PRIVATE
  66 GENERIC: cursor-key-value-unsafe ( cursor -- key value )
  67 PRIVATE>
  68 M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
  69 M: input-cursor cursor-key-value
  70     dup cursor-valid? [ cursor-key-value-unsafe ] [ invalid-cursor ] if ; inline
  71
  72 : cursor-key ( cursor -- key ) cursor-key-value drop ;
  73 : cursor-value ( cursor -- key ) cursor-key-value nip ;
  74
  75 : cursor-key-unsafe ( cursor -- key ) cursor-key-value-unsafe drop ;
  76 : cursor-value-unsafe ( cursor -- key ) cursor-key-value-unsafe nip ;
  77
  78 !
  79 ! output cursors
  80 !
  81
  82 MIXIN: output-cursor
  83
  84 GENERIC: set-cursor-value ( value cursor -- )
  85 <PRIVATE
  86 GENERIC: set-cursor-value-unsafe ( value cursor -- )
  87 PRIVATE>
  88 M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
  89 M: output-cursor set-cursor-value
  90     dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline
  91
  92 !
  93 ! stream cursors
  94 !
  95
  96 MIXIN: stream-cursor
  97 INSTANCE: stream-cursor forward-cursor
  98
  99 M: stream-cursor cursor-compatible? 2drop f ; inline
 100 M: stream-cursor cursor-valid? drop t ; inline
 101 M: stream-cursor cursor= 2drop f ; inline
 102
 103 MIXIN: infinite-stream-cursor
 104 INSTANCE: infinite-stream-cursor stream-cursor
 105
 106 M: infinite-stream-cursor inc-cursor ; inline
 107
 108 MIXIN: finite-stream-cursor
 109 INSTANCE: finite-stream-cursor stream-cursor
 110
 111 SINGLETON: end-of-stream
 112
 113 GENERIC: cursor-stream-ended? ( cursor -- ? )
 114
 115 M: finite-stream-cursor inc-cursor
 116     dup cursor-stream-ended? [ drop end-of-stream ] when ; inline
 117
 118 INSTANCE: end-of-stream finite-stream-cursor
 119
 120 M: end-of-stream cursor-compatible? drop finite-stream-cursor? ; inline
 121 M: end-of-stream cursor-valid? drop f ; inline
 122 M: end-of-stream cursor= eq? ; inline
 123 M: end-of-stream inc-cursor ; inline
 124 M: end-of-stream cursor-stream-ended? drop t ; inline
 125
 126 !
 127 ! basic iterators
 128 !
 129
 130 : -each ( ... begin end quot: ( ... cursor -- ... ) -- ... )
 131     [ '[ dup _ cursor>= ] ]
 132     [ '[ _ keep inc-cursor ] ] bi* until drop ; inline
 133
 134 : -find ( ... begin end quot: ( ... cursor -- ... ? ) -- ... cursor )
 135     '[ dup _ cursor>= [ t ] [ dup @ ] if ] [ inc-cursor ] until ; inline
 136
 137 : -in- ( quot -- quot' )
 138     '[ cursor-value-unsafe @ ] ; inline
 139
 140 : -out- ( quot -- quot' )
 141     '[ _ keep set-cursor-value-unsafe ] ; inline
 142
 143 : -out ( ... begin end quot: ( ... cursor -- ... value ) -- ... )
 144     -out- -each ; inline
 145
 146 !
 147 ! numeric cursors
 148 !
 149
 150 TUPLE: numeric-cursor
 151     { value read-only } ;
 152
 153 M: numeric-cursor cursor-valid? drop t ; inline
 154
 155 M: numeric-cursor cursor=  [ value>> ] bi@ =  ; inline
 156
 157 M: numeric-cursor cursor<= [ value>> ] bi@ <= ; inline
 158 M: numeric-cursor cursor<  [ value>> ] bi@ <  ; inline
 159 M: numeric-cursor cursor>  [ value>> ] bi@ >  ; inline
 160 M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
 161
 162 INSTANCE: numeric-cursor input-cursor
 163
 164 M: numeric-cursor cursor-key-value value>> dup ; inline
 165
 166 !
 167 ! linear cursor
 168 !
 169
 170 TUPLE: linear-cursor < numeric-cursor
 171     { delta read-only } ;
 172 C: <linear-cursor> linear-cursor
 173
 174 INSTANCE: linear-cursor random-access-cursor
 175
 176 M: linear-cursor cursor-compatible?
 177     [ linear-cursor? ] both? ; inline
 178
 179 M: linear-cursor inc-cursor
 180     [ value>> ] [ delta>> ] bi [ + ] keep <linear-cursor> ; inline
 181 M: linear-cursor dec-cursor
 182     [ value>> ] [ delta>> ] bi [ - ] keep <linear-cursor> ; inline
 183 M: linear-cursor cursor+
 184     [ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep <linear-cursor> ; inline
 185 M: linear-cursor cursor-
 186     [ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
 187
 188 GENERIC: up/i ( distance delta -- distance' )
 189 M: integer up/i [ 1 - + ] keep /i ; inline
 190 M: real up/i / ceiling >integer ; inline
 191
 192 M: linear-cursor cursor-distance
 193     [ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline
 194
 195 !
 196 ! quadratic cursor
 197 !
 198
 199 TUPLE: quadratic-cursor < numeric-cursor
 200     { delta read-only }
 201     { delta2 read-only } ;
 202
 203 C: <quadratic-cursor> quadratic-cursor
 204
 205 INSTANCE: quadratic-cursor bidirectional-cursor
 206
 207 M: quadratic-cursor cursor-compatible?
 208     [ linear-cursor? ] both? ; inline
 209
 210 M: quadratic-cursor inc-cursor
 211     [ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri <quadratic-cursor> ; inline
 212
 213 M: quadratic-cursor dec-cursor
 214     [ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep <quadratic-cursor> ; inline
 215
 216 !
 217 ! collections
 218 !
 219
 220 MIXIN: collection
 221
 222 GENERIC: begin-cursor ( collection -- cursor )
 223 GENERIC: end-cursor ( collection -- cursor )
 224
 225 : all ( collection -- begin end )
 226     [ begin-cursor ] [ end-cursor ] bi ; inline
 227
 228 : all- ( collection quot -- begin end quot )
 229     [ all ] dip ; inline
 230
 231 !
 232 ! containers
 233 !
 234
 235 MIXIN: container
 236 INSTANCE: container collection
 237
 238 : in- ( container quot -- begin end quot' )
 239     all- -in- ; inline
 240
 241 : each ( ... container quot: ( ... x -- ... ) -- ... ) in- -each ; inline
 242
 243 INSTANCE: finite-stream-cursor container
 244
 245 M: finite-stream-cursor begin-cursor ; inline
 246 M: finite-stream-cursor end-cursor drop end-of-stream ; inline
 247
 248 !
 249 ! sequence cursor
 250 !
 251
 252 TUPLE: sequence-cursor
 253     { seq read-only }
 254     { n fixnum read-only } ;
 255 C: <sequence-cursor> sequence-cursor
 256
 257 INSTANCE: sequence container
 258
 259 M: sequence begin-cursor 0 <sequence-cursor> ; inline
 260 M: sequence end-cursor dup length <sequence-cursor> ; inline
 261
 262 INSTANCE: sequence-cursor random-access-cursor
 263
 264 M: sequence-cursor cursor-compatible?
 265     {
 266         [ [ sequence-cursor? ] both? ]
 267         [ [ seq>> ] bi@ eq? ]
 268     } 2&& ; inline
 269
 270 M: sequence-cursor cursor-valid?
 271     [ n>> ] [ seq>> ] bi bounds-check? ; inline
 272
 273 M: sequence-cursor cursor=  [ n>> ] bi@ =  ; inline
 274 M: sequence-cursor cursor<= [ n>> ] bi@ <= ; inline
 275 M: sequence-cursor cursor>= [ n>> ] bi@ >= ; inline
 276 M: sequence-cursor cursor<  [ n>> ] bi@ <  ; inline
 277 M: sequence-cursor cursor>  [ n>> ] bi@ >  ; inline
 278 M: sequence-cursor inc-cursor [ seq>> ] [ n>> ] bi 1 + <sequence-cursor> ; inline
 279 M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - <sequence-cursor> ; inline
 280 M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + <sequence-cursor> ; inline
 281 M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - <sequence-cursor> ; inline
 282 M: sequence-cursor cursor-distance ( cursor cursor -- n )
 283     [ n>> ] bi@ - ; inline
 284
 285 INSTANCE: sequence-cursor input-cursor
 286
 287 M: sequence-cursor cursor-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
 288 M: sequence-cursor cursor-key-value [ n>> dup ] [ seq>> ] bi nth ; inline
 289
 290 INSTANCE: sequence-cursor output-cursor
 291
 292 M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline
 293 M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline
 294
 295 !
 296 ! hash-set cursor
 297 !
 298
 299 TUPLE: hash-set-cursor
 300     { hash-set hash-set read-only }
 301     { n fixnum read-only } ;
 302 <PRIVATE
 303 C: <hash-set-cursor> hash-set-cursor
 304 PRIVATE>
 305
 306 INSTANCE: hash-set-cursor forward-cursor
 307
 308 M: hash-set-cursor cursor-compatible?
 309     {
 310         [ [ hash-set-cursor? ] both? ]
 311         [ [ hash-set>> ] bi@ eq? ]
 312     } 2&& ; inline
 313
 314 M: hash-set-cursor cursor-valid? ( cursor -- ? )
 315     [ n>> ] [ hash-set>> array>> ] bi bounds-check? ; inline
 316
 317 M: hash-set-cursor cursor= ( cursor cursor -- ? )
 318     [ n>> ] bi@ = ; inline
 319 M: hash-set-cursor cursor-distance-hint ( cursor cursor -- n )
 320     nip hash-set>> cardinality ; inline
 321
 322 <PRIVATE
 323 : (inc-hash-set-cursor) ( array n -- n' )
 324     [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 1 + ] while nip ; inline
 325 PRIVATE>
 326
 327 M: hash-set-cursor inc-cursor ( cursor -- cursor' )
 328     [ hash-set>> dup array>> ] [ n>> 1 + ] bi
 329     (inc-hash-set-cursor) <hash-set-cursor> ; inline
 330
 331 INSTANCE: hash-set-cursor input-cursor
 332
 333 M: hash-set-cursor cursor-key-value-unsafe
 334     [ n>> dup ] [ hash-set>> array>> ] bi nth-unsafe ; inline
 335
 336 INSTANCE: hash-set container
 337
 338 M: hash-set begin-cursor
 339     dup array>> 0 (inc-hash-set-cursor) <hash-set-cursor> ; inline
 340 M: hash-set end-cursor
 341     dup array>> length <hash-set-cursor> ; inline
 342
 343 !
 344 ! map cursor
 345 !
 346
 347 TUPLE: map-cursor
 348     { from read-only }
 349     { to read-only } ;
 350 C: <map-cursor> map-cursor
 351
 352 INSTANCE: map-cursor forward-cursor
 353
 354 M: map-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline
 355 M: map-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline
 356 M: map-cursor cursor= [ from>> ] bi@ cursor= ; inline
 357 M: map-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi <map-cursor> ; inline
 358
 359 INSTANCE: map-cursor output-cursor
 360
 361 M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline
 362 M: map-cursor set-cursor-value        to>> set-cursor-value        ; inline
 363
 364 : -map- ( begin end quot to -- begin' end' quot' )
 365     swap [ '[ _ <map-cursor> ] bi@ ] dip '[ from>> @ ] -out- ; inline
 366
 367 : -map ( begin end quot to -- begin' end' quot' )
 368     -map- -each ; inline
 369
 370 !
 371 ! pusher cursor
 372 !
 373
 374 TUPLE: pusher-cursor
 375     { growable read-only } ;
 376 C: <pusher-cursor> pusher-cursor
 377
 378 INSTANCE: pusher-cursor infinite-stream-cursor
 379 INSTANCE: pusher-cursor output-cursor
 380
 381 M: pusher-cursor set-cursor-value growable>> push ; inline
 382
 383 !
 384 ! Create cursors into new sequences
 385 !
 386
 387 : new-growable-cursor ( begin end exemplar -- cursor result )
 388     [ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
 389
 390 GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
 391
 392 M: random-access-cursor new-sequence-cursor
 393     [ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
 394 M: forward-cursor new-sequence-cursor
 395     new-growable-cursor ; inline
 396
 397 : -into-sequence- ( begin end quot exemplar -- begin' end' quot' cursor result )
 398     [ 2over ] dip new-sequence-cursor ; inline
 399
 400 : -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result )
 401     [ 2over ] dip new-growable-cursor ; inline
 402
 403 !
 404 ! map combinators
 405 !
 406
 407 ! XXX generalize exemplar
 408 : -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq )
 409     [ -into-sequence- [ -map ] dip ] keep like ; inline
 410
 411 : map! ( ... container quot: ( ... x -- ... newx ) -- ... container )
 412     [ in- -out ] keep ; inline
 413 : map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq )
 414     [ in- ] dip -map-as ; inline
 415 : map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer )
 416     over map-as ; inline
 417
 418 !
 419 ! assoc combinators
 420 !
 421
 422 : -assoc- ( quot -- quot' )
 423     '[ cursor-key-value @ ] ; inline
 424
 425 : assoc- ( assoc quot -- begin end quot' )
 426     all- -assoc- ; inline
 427
 428 : assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... )
 429     assoc- -each ; inline
 430 : assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
 431     [ assoc- ] dip -map-as ; inline
 432
 433 !
 434 ! hashtable cursor
 435 !
 436
 437 TUPLE: hashtable-cursor
 438     { hashtable hashtable read-only }
 439     { n fixnum read-only } ;
 440 <PRIVATE
 441 C: <hashtable-cursor> hashtable-cursor
 442 PRIVATE>
 443
 444 INSTANCE: hashtable-cursor forward-cursor
 445
 446 M: hashtable-cursor cursor-compatible?
 447     {
 448         [ [ hashtable-cursor? ] both? ]
 449         [ [ hashtable>> ] bi@ eq? ]
 450     } 2&& ; inline
 451
 452 M: hashtable-cursor cursor-valid? ( cursor -- ? )
 453     [ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline
 454
 455 M: hashtable-cursor cursor= ( cursor cursor -- ? )
 456     [ n>> ] bi@ = ; inline
 457 M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n )
 458     nip hashtable>> assoc-size ; inline
 459
 460 <PRIVATE
 461 : (inc-hashtable-cursor) ( array n -- n' )
 462     [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 2 + ] while nip ; inline
 463 PRIVATE>
 464
 465 M: hashtable-cursor inc-cursor ( cursor -- cursor' )
 466     [ hashtable>> dup array>> ] [ n>> 2 + ] bi
 467     (inc-hashtable-cursor) <hashtable-cursor> ; inline
 468
 469 INSTANCE: hashtable-cursor input-cursor
 470
 471 M: hashtable-cursor cursor-key-value-unsafe
 472     [ n>> ] [ hashtable>> array>> ] bi
 473     [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
 474
 475 INSTANCE: hashtable container
 476
 477 M: hashtable begin-cursor
 478     dup array>> 0 (inc-hashtable-cursor) <hashtable-cursor> ; inline
 479 M: hashtable end-cursor
 480     dup array>> length <hashtable-cursor> ; inline
 481
 482 !
 483 ! zip cursor
 484 !
 485
 486 TUPLE: zip-cursor
 487     { keys   read-only }
 488     { values read-only } ;
 489 C: <zip-cursor> zip-cursor
 490
 491 INSTANCE: zip-cursor forward-cursor
 492
 493 M: zip-cursor cursor-compatible? ( cursor cursor -- ? )
 494     {
 495         [ [ zip-cursor? ] both? ]
 496         [ [ keys>> ] bi@ cursor-compatible? ]
 497         [ [ values>> ] bi@ cursor-compatible? ]
 498     } 2&& ; inline
 499
 500 M: zip-cursor cursor-valid? ( cursor -- ? )
 501     [ keys>> ] [ values>> ] bi [ cursor-valid? ] both? ; inline
 502 M: zip-cursor cursor= ( cursor cursor -- ? )
 503     {
 504         [ [ keys>> ] bi@ cursor= ]
 505         [ [ values>> ] bi@ cursor= ]
 506     } 2|| ; inline
 507
 508 M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
 509     [ [ keys>> ] bi@ cursor-distance-hint ]
 510     [ [ values>> ] bi@ cursor-distance-hint ] 2bi max ; inline
 511
 512 M: zip-cursor inc-cursor ( cursor -- cursor' )
 513     [ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
 514
 515 INSTANCE: zip-cursor input-cursor
 516
 517 M: zip-cursor cursor-key-value
 518     [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline
 519
 520 : zip-cursors ( a-begin a-end b-begin b-end -- begin end )
 521     [ <zip-cursor> ] bi-curry@ bi* ; inline
 522
 523 : 2all ( a b -- begin end )
 524     [ all ] bi@ zip-cursors ; inline
 525
 526 : 2all- ( a b quot -- begin end quot )
 527     [ 2all ] dip ; inline
 528
 529 ALIAS: -2in- -assoc-
 530
 531 : 2in- ( a b quot -- begin end quot' )
 532     2all- -2in- ; inline
 533
 534 : 2each ( ... a b quot: ( ... x y -- ... ) -- ... )
 535     2in- -each ; inline
 536
 537 : 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c )
 538     [ 2in- ] dip -map-as ; inline
 539
 540 : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c )
 541     pick 2map-as ; inline
 542
 543 !
 544 ! generalized zips
 545 !
 546
 547 : -unzip- ( quot -- quot' )
 548     '[ [ keys>> cursor-value-unsafe ] [ values>> ] bi @ ] ; inline
 549
 550 MACRO: nzip-cursors ( n -- ) 1 - [ zip-cursors ] n*quot ;
 551
 552 : nall ( seqs... n -- begin end ) [ [ all ] swap napply ] [ nzip-cursors ] bi ; inline
 553
 554 : nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline
 555
 556 MACRO: -nin- ( n -- )
 557     1 - [ -unzip- ] n*quot [ -in- ] prepend ;
 558
 559 : nin- ( seqs... quot n -- begin end quot ) [ nall- ] [ -nin- ] bi ; inline
 560
 561 : neach ( seqs... quot n -- ) nin- -each ; inline
 562 : nmap-as ( seqs... quot exemplar n -- newseq )
 563     swap [ nin- ] dip -map-as ; inline
 564 : nmap ( seqs... quot n -- newseq )
 565     dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline
 566
 567 !
 568 ! utilities
 569 !
 570
 571 : -with- ( invariant begin end quot -- begin end quot' )
 572     [ rot ] dip '[ [ _ ] dip @ ] ; inline
 573
 574 : -2with- ( invariant invariant begin end quot -- begin end quot' )
 575     -with- -with- ; inline
 576
 577 MACRO: -nwith- ( n -- )
 578     [ -with- ] n*quot ;