proof of concept new "cursors" framework
Joe Groff
parent
5da799f5a0
commit
ab148a85e0
|
|
@ -1 +1 @@
|
|||
Doug Coleman
|
||||
Joe Groff
|
||||
|
|
|
|||
|
|
@ -1,44 +1,68 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cursors math tools.test make ;
|
||||
! (c)2010 Joe Groff bsd license
|
||||
USING: accessors cursors make math sequences sorting tools.test ;
|
||||
FROM: cursors => each map assoc-each assoc>map ;
|
||||
IN: cursors.tests
|
||||
|
||||
[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
|
||||
[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
|
||||
[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
|
||||
[ { 1 2 3 4 } ] [
|
||||
[ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> , ] -each ]
|
||||
{ } make
|
||||
] unit-test
|
||||
|
||||
[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
|
||||
[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
|
||||
[ { 1 3 } ] [
|
||||
[ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ]
|
||||
{ } make
|
||||
] unit-test
|
||||
|
||||
[ t ] [ { } [ odd? ] all? ] unit-test
|
||||
[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
|
||||
[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
|
||||
[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } [ , ] each ] B{ } make ] unit-test
|
||||
[ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test
|
||||
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test
|
||||
|
||||
[ t ] [ { } [ odd? ] all? ] unit-test
|
||||
[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
|
||||
[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
[
|
||||
{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue , ] assoc-each
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue ] { } assoc>map
|
||||
] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { 1 2 } { } [ + ] 2map ] unit-test
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
[
|
||||
H{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue , ] assoc-each
|
||||
] { } make natural-sort
|
||||
] unit-test
|
||||
|
||||
[ { 11 } ]
|
||||
[ { 1 2 } { 10 } [ + ] 2map ] unit-test
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
H{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue ] { } assoc>map natural-sort
|
||||
] unit-test
|
||||
|
||||
[ { 11 22 } ]
|
||||
[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test
|
||||
: compile-test-each ( xs -- )
|
||||
[ , ] each ;
|
||||
|
||||
[ { } ]
|
||||
[ { 1 2 } { } { } [ + + ] 3map ] unit-test
|
||||
: compile-test-map ( xs -- ys )
|
||||
[ 2 * ] map ;
|
||||
|
||||
[ { 111 } ]
|
||||
[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test
|
||||
: compile-test-assoc-each ( xs -- )
|
||||
[ ": " glue , ] assoc-each ;
|
||||
|
||||
[ { 111 222 } ]
|
||||
[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
|
||||
: compile-test-assoc>map ( xs -- ys )
|
||||
[ ": " glue ] { } assoc>map ;
|
||||
|
||||
: test-3map ( -- seq )
|
||||
{ 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
|
||||
[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } compile-test-each ] B{ } make ] unit-test
|
||||
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test
|
||||
|
||||
[ { 111 222 } ] [ test-3map ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,153 +1,392 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generalizations kernel math sequences
|
||||
sequences.private fry ;
|
||||
! (c)2010 Joe Groff bsd license
|
||||
USING: accessors assocs combinators.short-circuit fry hashtables
|
||||
kernel locals math math.functions sequences sequences.private ;
|
||||
FROM: hashtables.private => tombstone? ;
|
||||
IN: cursors
|
||||
|
||||
GENERIC: cursor-done? ( cursor -- ? )
|
||||
GENERIC: cursor-get-unsafe ( cursor -- obj )
|
||||
GENERIC: cursor-advance ( cursor -- )
|
||||
!
|
||||
! basic cursor protocol
|
||||
!
|
||||
|
||||
MIXIN: cursor
|
||||
|
||||
GENERIC: cursor-compatible? ( cursor cursor -- ? )
|
||||
GENERIC: cursor-valid? ( cursor -- ? )
|
||||
GENERIC: cursor-write ( obj cursor -- )
|
||||
GENERIC: cursor= ( cursor cursor -- ? )
|
||||
GENERIC: cursor<= ( cursor cursor -- ? )
|
||||
GENERIC: cursor>= ( cursor cursor -- ? )
|
||||
GENERIC: cursor-distance-hint ( cursor cursor -- n )
|
||||
|
||||
ERROR: cursor-ended cursor ;
|
||||
M: cursor cursor<= cursor= ; inline
|
||||
M: cursor cursor>= cursor= ; inline
|
||||
M: cursor cursor-distance-hint 2drop 0 ; inline
|
||||
|
||||
: cursor-get ( cursor -- obj )
|
||||
dup cursor-done?
|
||||
[ cursor-ended ] [ cursor-get-unsafe ] if ; inline
|
||||
!
|
||||
! cursor iteration
|
||||
!
|
||||
|
||||
: find-done? ( cursor quot -- ? )
|
||||
over cursor-done?
|
||||
[ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
|
||||
MIXIN: forward-cursor
|
||||
INSTANCE: forward-cursor cursor
|
||||
|
||||
: cursor-until ( cursor quot -- )
|
||||
[ find-done? not ]
|
||||
[ drop cursor-advance ] bi-curry bi-curry while ; inline
|
||||
|
||||
: cursor-each ( cursor quot -- )
|
||||
[ f ] compose cursor-until ; inline
|
||||
GENERIC: inc-cursor ( cursor -- cursor' )
|
||||
|
||||
: cursor-find ( cursor quot -- obj ? )
|
||||
[ cursor-until ] [ drop ] 2bi
|
||||
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
|
||||
MIXIN: bidirectional-cursor
|
||||
INSTANCE: bidirectional-cursor forward-cursor
|
||||
|
||||
: cursor-any? ( cursor quot -- ? )
|
||||
cursor-find nip ; inline
|
||||
GENERIC: dec-cursor ( cursor -- cursor' )
|
||||
|
||||
: cursor-all? ( cursor quot -- ? )
|
||||
[ not ] compose cursor-any? not ; inline
|
||||
MIXIN: random-access-cursor
|
||||
INSTANCE: random-access-cursor bidirectional-cursor
|
||||
|
||||
: cursor-map-quot ( quot to -- quot' )
|
||||
[ [ call ] dip cursor-write ] 2curry ; inline
|
||||
GENERIC# cursor+ 1 ( cursor n -- cursor' )
|
||||
GENERIC# cursor- 1 ( cursor n -- cursor' )
|
||||
GENERIC: cursor-distance ( cursor cursor -- n )
|
||||
GENERIC: cursor< ( cursor cursor -- ? )
|
||||
GENERIC: cursor> ( cursor cursor -- ? )
|
||||
|
||||
: cursor-map ( from to quot -- )
|
||||
swap cursor-map-quot cursor-each ; inline
|
||||
M: random-access-cursor inc-cursor 1 cursor+ ; inline
|
||||
M: random-access-cursor dec-cursor -1 cursor+ ; inline
|
||||
M: random-access-cursor cursor- neg cursor+ ; inline
|
||||
M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline
|
||||
M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline
|
||||
M: random-access-cursor cursor-distance-hint cursor-distance ; inline
|
||||
|
||||
: cursor-write-if ( obj quot to -- )
|
||||
[ over [ call ] dip ] dip
|
||||
[ cursor-write ] 2curry when ; inline
|
||||
!
|
||||
! input cursors
|
||||
!
|
||||
|
||||
: cursor-filter-quot ( quot to -- quot' )
|
||||
[ cursor-write-if ] 2curry ; inline
|
||||
ERROR: invalid-cursor cursor ;
|
||||
|
||||
: cursor-filter ( from to quot -- )
|
||||
swap cursor-filter-quot cursor-each ; inline
|
||||
MIXIN: input-cursor
|
||||
|
||||
TUPLE: from-sequence { seq sequence } { n integer } ;
|
||||
GENERIC: cursor-value ( cursor -- value )
|
||||
<PRIVATE
|
||||
GENERIC: cursor-value-unsafe ( cursor -- value )
|
||||
PRIVATE>
|
||||
M: input-cursor cursor-value-unsafe cursor-value ; inline
|
||||
M: input-cursor cursor-value
|
||||
dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
|
||||
: >from-sequence< ( from-sequence -- n seq )
|
||||
[ n>> ] [ seq>> ] bi ; inline
|
||||
!
|
||||
! output cursors
|
||||
!
|
||||
|
||||
M: from-sequence cursor-done? ( cursor -- ? )
|
||||
>from-sequence< length >= ;
|
||||
MIXIN: output-cursor
|
||||
|
||||
M: from-sequence cursor-valid?
|
||||
>from-sequence< bounds-check? not ;
|
||||
GENERIC: set-cursor-value ( value cursor -- )
|
||||
<PRIVATE
|
||||
GENERIC: set-cursor-value-unsafe ( value cursor -- )
|
||||
PRIVATE>
|
||||
M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
|
||||
M: output-cursor set-cursor-value
|
||||
dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
|
||||
M: from-sequence cursor-get-unsafe
|
||||
>from-sequence< nth-unsafe ;
|
||||
!
|
||||
! basic iterator
|
||||
!
|
||||
|
||||
M: from-sequence cursor-advance
|
||||
[ 1 + ] change-n drop ;
|
||||
: -each ( ... begin end quot: ( ... cursor -- ... ) -- ... )
|
||||
[ '[ dup _ cursor>= ] ]
|
||||
[ '[ _ keep inc-cursor ] ] bi* until drop ; inline
|
||||
|
||||
: >input ( seq -- cursor )
|
||||
0 from-sequence boa ; inline
|
||||
!
|
||||
! numeric cursors
|
||||
!
|
||||
|
||||
: iterate ( seq quot iterator -- )
|
||||
[ >input ] 2dip call ; inline
|
||||
TUPLE: numeric-cursor
|
||||
{ value read-only } ;
|
||||
|
||||
: each ( seq quot -- ) [ cursor-each ] iterate ; inline
|
||||
: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
|
||||
: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
|
||||
: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
|
||||
M: numeric-cursor cursor-valid? drop t ; inline
|
||||
|
||||
TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
|
||||
M: numeric-cursor cursor= [ value>> ] bi@ = ; inline
|
||||
|
||||
M: to-sequence cursor-write
|
||||
seq>> push ;
|
||||
M: numeric-cursor cursor<= [ value>> ] bi@ <= ; inline
|
||||
M: numeric-cursor cursor< [ value>> ] bi@ < ; inline
|
||||
M: numeric-cursor cursor> [ value>> ] bi@ > ; inline
|
||||
M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
|
||||
|
||||
: freeze ( cursor -- seq )
|
||||
[ seq>> ] [ exemplar>> ] bi like ; inline
|
||||
INSTANCE: numeric-cursor input-cursor
|
||||
|
||||
: >output ( seq -- cursor )
|
||||
[ [ length ] keep new-resizable ] keep
|
||||
to-sequence boa ; inline
|
||||
M: numeric-cursor cursor-value value>> ; inline
|
||||
|
||||
: transform ( seq quot transformer -- newseq )
|
||||
[ [ >input ] [ >output ] bi ] 2dip
|
||||
[ call ]
|
||||
[ 2drop freeze ] 3bi ; inline
|
||||
!
|
||||
! linear cursor
|
||||
!
|
||||
|
||||
: map ( seq quot -- ) [ cursor-map ] transform ; inline
|
||||
: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
|
||||
TUPLE: linear-cursor < numeric-cursor
|
||||
{ delta read-only } ;
|
||||
C: <linear-cursor> linear-cursor
|
||||
|
||||
: find-done2? ( cursor cursor quot -- ? )
|
||||
2over [ cursor-done? ] either?
|
||||
[ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
|
||||
INSTANCE: linear-cursor random-access-cursor
|
||||
|
||||
: cursor-until2 ( cursor cursor quot -- )
|
||||
[ find-done2? not ]
|
||||
[ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
|
||||
M: linear-cursor cursor-compatible?
|
||||
[ linear-cursor? ] both? ; inline
|
||||
|
||||
: cursor-each2 ( cursor cursor quot -- )
|
||||
[ f ] compose cursor-until2 ; inline
|
||||
M: linear-cursor inc-cursor
|
||||
[ value>> ] [ delta>> ] bi [ + ] keep <linear-cursor> ; inline
|
||||
M: linear-cursor dec-cursor
|
||||
[ value>> ] [ delta>> ] bi [ - ] keep <linear-cursor> ; inline
|
||||
M: linear-cursor cursor+
|
||||
[ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep <linear-cursor> ; inline
|
||||
M: linear-cursor cursor-
|
||||
[ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
|
||||
|
||||
: cursor-map2 ( from to quot -- )
|
||||
swap cursor-map-quot cursor-each2 ; inline
|
||||
GENERIC: up/i ( distance delta -- distance' )
|
||||
M: integer up/i [ 1 - + ] keep /i ; inline
|
||||
M: real up/i / ceiling >integer ; inline
|
||||
|
||||
: iterate2 ( seq1 seq2 quot iterator -- )
|
||||
[ [ >input ] bi@ ] 2dip call ; inline
|
||||
M: linear-cursor cursor-distance
|
||||
[ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline
|
||||
|
||||
: transform2 ( seq1 seq2 quot transformer -- newseq )
|
||||
[ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
|
||||
[ call ]
|
||||
[ 2drop nip freeze ] 4 nbi ; inline
|
||||
!
|
||||
! quadratic cursor
|
||||
!
|
||||
|
||||
: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
|
||||
: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
|
||||
TUPLE: quadratic-cursor < numeric-cursor
|
||||
{ delta read-only }
|
||||
{ delta2 read-only } ;
|
||||
|
||||
: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
|
||||
[ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
|
||||
[ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
|
||||
C: <quadratic-cursor> quadratic-cursor
|
||||
|
||||
: cursor-until3 ( cursor cursor quot -- )
|
||||
[ find-done3? not ]
|
||||
[ drop [ cursor-advance ] tri@ ]
|
||||
bi-curry bi-curry bi-curry bi-curry while ; inline
|
||||
INSTANCE: quadratic-cursor bidirectional-cursor
|
||||
|
||||
: cursor-each3 ( cursor cursor quot -- )
|
||||
[ f ] compose cursor-until3 ; inline
|
||||
M: quadratic-cursor cursor-compatible?
|
||||
[ linear-cursor? ] both? ; inline
|
||||
|
||||
: cursor-map3 ( from to quot -- )
|
||||
swap cursor-map-quot cursor-each3 ; inline
|
||||
M: quadratic-cursor inc-cursor
|
||||
[ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri <quadratic-cursor> ; inline
|
||||
|
||||
: iterate3 ( seq1 seq2 seq3 quot iterator -- )
|
||||
[ [ >input ] tri@ ] 2dip call ; inline
|
||||
M: quadratic-cursor dec-cursor
|
||||
[ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep <quadratic-cursor> ; inline
|
||||
|
||||
: transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
|
||||
[ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
|
||||
[ call ]
|
||||
[ 2drop 2nip freeze ] 5 nbi ; inline
|
||||
!
|
||||
! collections
|
||||
!
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
|
||||
: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline
|
||||
MIXIN: collection
|
||||
|
||||
GENERIC: begin-cursor ( collection -- cursor )
|
||||
GENERIC: end-cursor ( collection -- cursor )
|
||||
|
||||
: all- ( collection quot -- begin end quot )
|
||||
[ [ begin-cursor ] [ end-cursor ] bi ] dip ; inline
|
||||
|
||||
!
|
||||
! containers
|
||||
!
|
||||
|
||||
MIXIN: container
|
||||
INSTANCE: container collection
|
||||
|
||||
: -container- ( quot -- quot' )
|
||||
'[ cursor-value-unsafe @ ] ; inline
|
||||
|
||||
: container- ( container quot -- begin end quot' )
|
||||
all- -container- ; inline
|
||||
|
||||
: each ( ... container quot: ( ... x -- ... ) -- ... ) container- -each ; inline
|
||||
|
||||
!
|
||||
! sequence cursor
|
||||
!
|
||||
|
||||
TUPLE: sequence-cursor
|
||||
{ seq read-only }
|
||||
{ n fixnum read-only } ;
|
||||
C: <sequence-cursor> sequence-cursor
|
||||
|
||||
INSTANCE: sequence container
|
||||
|
||||
M: sequence begin-cursor 0 <sequence-cursor> ; inline
|
||||
M: sequence end-cursor dup length <sequence-cursor> ; inline
|
||||
|
||||
INSTANCE: sequence-cursor random-access-cursor
|
||||
|
||||
M: sequence-cursor cursor-compatible?
|
||||
{
|
||||
[ [ sequence-cursor? ] both? ]
|
||||
[ [ seq>> ] bi@ eq? ]
|
||||
} 2&& ; inline
|
||||
|
||||
M: sequence-cursor cursor-valid?
|
||||
[ n>> ] [ seq>> ] bi bounds-check? ; inline
|
||||
|
||||
M: sequence-cursor cursor= [ n>> ] bi@ = ; inline
|
||||
M: sequence-cursor cursor<= [ n>> ] bi@ <= ; inline
|
||||
M: sequence-cursor cursor>= [ n>> ] bi@ >= ; inline
|
||||
M: sequence-cursor cursor< [ n>> ] bi@ < ; inline
|
||||
M: sequence-cursor cursor> [ n>> ] bi@ > ; inline
|
||||
M: sequence-cursor inc-cursor [ seq>> ] [ n>> ] bi 1 + <sequence-cursor> ; inline
|
||||
M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - <sequence-cursor> ; inline
|
||||
M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + <sequence-cursor> ; inline
|
||||
M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - <sequence-cursor> ; inline
|
||||
M: sequence-cursor cursor-distance ( cursor cursor -- n )
|
||||
[ n>> ] bi@ - ; inline
|
||||
|
||||
INSTANCE: sequence-cursor input-cursor
|
||||
|
||||
M: sequence-cursor cursor-value-unsafe [ n>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; inline
|
||||
|
||||
INSTANCE: sequence-cursor output-cursor
|
||||
|
||||
M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline
|
||||
M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline
|
||||
|
||||
!
|
||||
! pipe cursor
|
||||
!
|
||||
|
||||
TUPLE: pipe-cursor
|
||||
{ from read-only }
|
||||
{ to read-only } ;
|
||||
C: <pipe-cursor> pipe-cursor
|
||||
|
||||
INSTANCE: pipe-cursor forward-cursor
|
||||
|
||||
M: pipe-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline
|
||||
M: pipe-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline
|
||||
M: pipe-cursor cursor= [ from>> ] bi@ cursor= ; inline
|
||||
M: pipe-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi <pipe-cursor> ; inline
|
||||
|
||||
INSTANCE: pipe-cursor output-cursor
|
||||
|
||||
M: pipe-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline
|
||||
M: pipe-cursor set-cursor-value to>> set-cursor-value ; inline
|
||||
|
||||
: -pipe- ( begin end quot to -- begin' end' quot' )
|
||||
swap [ '[ _ <pipe-cursor> ] bi@ ] dip '[ from>> @ ] ; inline
|
||||
|
||||
!
|
||||
! pusher cursor
|
||||
!
|
||||
|
||||
TUPLE: pusher-cursor
|
||||
{ growable read-only } ;
|
||||
C: <pusher-cursor> pusher-cursor
|
||||
|
||||
INSTANCE: pusher-cursor forward-cursor
|
||||
|
||||
! XXX define a protocol for stream cursors that don't actually move
|
||||
M: pusher-cursor cursor-compatible? 2drop f ; inline
|
||||
M: pusher-cursor cursor-valid? drop t ; inline
|
||||
M: pusher-cursor cursor= 2drop f ; inline
|
||||
M: pusher-cursor inc-cursor ; inline
|
||||
|
||||
INSTANCE: pusher-cursor output-cursor
|
||||
|
||||
M: pusher-cursor set-cursor-value growable>> push ; inline
|
||||
|
||||
!
|
||||
! Create cursors into new sequences
|
||||
!
|
||||
|
||||
: new-growable-cursor ( begin end exemplar -- cursor result )
|
||||
[ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
|
||||
|
||||
GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
|
||||
|
||||
M: random-access-cursor new-sequence-cursor
|
||||
[ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
|
||||
M: forward-cursor new-sequence-cursor
|
||||
new-growable-cursor ; inline
|
||||
|
||||
: -into-sequence- ( begin end quot exemplar -- begin' end' quot' result )
|
||||
swap [ [ 2dup ] dip new-sequence-cursor ] dip swap [ swap -pipe- ] dip ; inline
|
||||
|
||||
: -into-growable- ( begin end quot exemplar -- begin' end' quot' result )
|
||||
swap [ [ 2dup ] dip new-growable-cursor ] dip swap [ swap -pipe- ] dip ; inline
|
||||
|
||||
!
|
||||
! map
|
||||
!
|
||||
|
||||
: -map- ( quot -- quot' )
|
||||
'[ _ keep set-cursor-value-unsafe ] ; inline
|
||||
|
||||
: -map ( ... begin end quot: ( ... cursor -- ... value ) -- ... )
|
||||
-map- -each ; inline
|
||||
|
||||
! XXX generalize exemplar
|
||||
: -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq )
|
||||
[ -into-sequence- [ -map ] dip ] keep like ; inline
|
||||
|
||||
: map! ( ... container quot: ( ... x -- ... newx ) -- ... container )
|
||||
[ container- -map ] keep ; inline
|
||||
: map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq )
|
||||
[ container- ] dip -map-as ; inline
|
||||
: map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer )
|
||||
over map-as ; inline
|
||||
|
||||
!
|
||||
! assoc cursors
|
||||
!
|
||||
|
||||
MIXIN: assoc-cursor
|
||||
|
||||
GENERIC: cursor-key-value ( cursor -- key value )
|
||||
|
||||
: -assoc- ( quot -- quot' )
|
||||
'[ cursor-key-value @ ] ; inline
|
||||
|
||||
: assoc- ( assoc quot -- begin end quot' )
|
||||
all- -assoc- ; inline
|
||||
|
||||
: assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... )
|
||||
assoc- -each ; inline
|
||||
: assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
|
||||
[ assoc- ] dip -map-as ; inline
|
||||
|
||||
INSTANCE: input-cursor assoc-cursor
|
||||
|
||||
M: input-cursor cursor-key-value
|
||||
cursor-value first2 ; inline
|
||||
|
||||
!
|
||||
! hashtable cursor
|
||||
!
|
||||
|
||||
TUPLE: hashtable-cursor
|
||||
{ hashtable hashtable read-only }
|
||||
{ n fixnum read-only } ;
|
||||
<PRIVATE
|
||||
C: <hashtable-cursor> hashtable-cursor
|
||||
PRIVATE>
|
||||
|
||||
INSTANCE: hashtable-cursor forward-cursor
|
||||
|
||||
M: hashtable-cursor cursor-compatible?
|
||||
{
|
||||
[ [ hashtable-cursor? ] both? ]
|
||||
[ [ hashtable>> ] bi@ eq? ]
|
||||
} 2&& ; inline
|
||||
|
||||
M: hashtable-cursor cursor-valid? ( cursor -- ? )
|
||||
[ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline
|
||||
|
||||
M: hashtable-cursor cursor= ( cursor cursor -- ? )
|
||||
[ n>> ] bi@ = ; inline
|
||||
M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n )
|
||||
nip hashtable>> assoc-size ; inline
|
||||
|
||||
<PRIVATE
|
||||
: (inc-hashtable-cursor) ( array n -- n' )
|
||||
[ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 2 + ] while nip ; inline
|
||||
PRIVATE>
|
||||
|
||||
M: hashtable-cursor inc-cursor ( cursor -- cursor' )
|
||||
[ hashtable>> dup array>> ] [ n>> 2 + ] bi
|
||||
(inc-hashtable-cursor) <hashtable-cursor> ; inline
|
||||
|
||||
INSTANCE: hashtable-cursor assoc-cursor
|
||||
|
||||
M: hashtable-cursor cursor-key-value
|
||||
[ n>> ] [ hashtable>> array>> ] bi
|
||||
[ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
|
||||
|
||||
INSTANCE: hashtable collection
|
||||
|
||||
M: hashtable begin-cursor
|
||||
dup array>> 0 (inc-hashtable-cursor) <hashtable-cursor> ; inline
|
||||
M: hashtable end-cursor
|
||||
dup array>> length <hashtable-cursor> ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue