added new and improved gap buffer
chapman.alex
parent
b0776b8f15
commit
8ba243035a
|
|
@ -0,0 +1,19 @@
|
||||||
|
USING: kernel test sequences sequences-internals circular ;
|
||||||
|
|
||||||
|
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap circular@ drop ] unit-test
|
||||||
|
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap circular@ drop ] unit-test
|
||||||
|
|
||||||
|
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
|
||||||
|
[ "test" ] [ "test" <circular> "" like ] unit-test
|
||||||
|
|
||||||
|
[ "test" <circular> 5 swap nth ] unit-test-fails
|
||||||
|
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||||
|
|
||||||
|
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> f like ] unit-test
|
||||||
|
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start f like ] unit-test
|
||||||
|
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start f like ] unit-test
|
||||||
|
|
||||||
|
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth "" like ] unit-test
|
||||||
|
[ "foo" <circular> CHAR: b 3 rot set-nth ] unit-test-fails
|
||||||
|
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe "" like ] unit-test
|
||||||
|
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth "" like ] unit-test
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
USING: kernel sequences math generic sequences-internals ;
|
||||||
|
IN: circular
|
||||||
|
|
||||||
|
! a circular sequence wraps another sequence, but begins at an arbitrary
|
||||||
|
! element in the underlying sequence.
|
||||||
|
TUPLE: circular start ;
|
||||||
|
|
||||||
|
C: circular ( seq circular -- circular )
|
||||||
|
0 over set-circular-start [ set-delegate ] keep ;
|
||||||
|
|
||||||
|
: circular@ ( n circular -- n seq )
|
||||||
|
[ tuck circular-start + swap length mod ] keep delegate ;
|
||||||
|
|
||||||
|
M: circular nth ( n seq -- elt ) bounds-check circular@ nth ;
|
||||||
|
|
||||||
|
M: circular nth-unsafe ( n seq -- elt ) circular@ nth-unsafe ;
|
||||||
|
|
||||||
|
M: circular set-nth ( elt n seq -- ) bounds-check circular@ set-nth ;
|
||||||
|
|
||||||
|
M: circular set-nth-unsafe ( elt n seq -- ) circular@ set-nth-unsafe ;
|
||||||
|
|
||||||
|
: change-circular-start ( n circular -- )
|
||||||
|
#! change start to (start + n) mod length
|
||||||
|
[ circular@ drop ] keep set-circular-start ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,41 @@
|
||||||
|
USING: kernel sequences test gap-buffer strings math ;
|
||||||
|
IN: gb-tests
|
||||||
|
|
||||||
|
! test copy-elements
|
||||||
|
[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
|
||||||
|
[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
|
||||||
|
[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
|
||||||
|
|
||||||
|
! test sequence protocol (like, length, nth, set-nth)
|
||||||
|
[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
|
||||||
|
|
||||||
|
! test move-gap-back-inside
|
||||||
|
[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
|
||||||
|
[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
|
||||||
|
! test move-gap-forward-inside
|
||||||
|
[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
|
||||||
|
[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
|
||||||
|
! test move-gap-back-around
|
||||||
|
[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
|
||||||
|
[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
|
||||||
|
! test move-gap-forward-around
|
||||||
|
[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
|
||||||
|
[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
|
||||||
|
|
||||||
|
! test changing buffer contents
|
||||||
|
[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
|
||||||
|
! test inserting multiple elements in different places. buffer should grow
|
||||||
|
[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
|
||||||
|
! test deleting elements. buffer should shrink
|
||||||
|
[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
|
||||||
|
! more testing of nth and set-nth
|
||||||
|
[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
|
||||||
|
|
||||||
|
! test stack/queue operations
|
||||||
|
[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
|
||||||
|
[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
|
||||||
|
[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
|
||||||
|
[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
|
||||||
|
[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
|
||||||
|
[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
|
||||||
|
|
||||||
|
|
@ -0,0 +1,236 @@
|
||||||
|
! gap buffer -- Alex Chapman (chapman.alex@gmail.com)
|
||||||
|
! largely influenced by Strandh and Villeneuve's Flexichain
|
||||||
|
! for a good introduction see:
|
||||||
|
! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
|
||||||
|
USING: kernel arrays sequences sequences-internals circular math generic ;
|
||||||
|
IN: gap-buffer
|
||||||
|
|
||||||
|
TUPLE: gb
|
||||||
|
gap-start ! the first element of the gap
|
||||||
|
gap-end ! the first element after the gap
|
||||||
|
expand-factor ! should be > 1
|
||||||
|
min-size ; ! < 5 is not sensible
|
||||||
|
|
||||||
|
: required-space ( n gb -- n )
|
||||||
|
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
|
||||||
|
|
||||||
|
C: gb ( seq gb -- gb )
|
||||||
|
5 over set-gb-min-size
|
||||||
|
1.5 over set-gb-expand-factor
|
||||||
|
[ >r length r> set-gb-gap-start ] 2keep
|
||||||
|
[ swap length over required-space swap set-gb-gap-end ] 2keep
|
||||||
|
[
|
||||||
|
over length over required-space rot { } like resize-array <circular> swap set-delegate
|
||||||
|
] keep ;
|
||||||
|
|
||||||
|
M: gb like ( seq gb -- seq ) drop <gb> ;
|
||||||
|
|
||||||
|
: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
|
||||||
|
|
||||||
|
: buffer-length ( gb -- n ) delegate length ;
|
||||||
|
|
||||||
|
M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
|
||||||
|
|
||||||
|
: position>index ( n gb -- n )
|
||||||
|
2dup gb-gap-start >= [
|
||||||
|
gap-length +
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: gb@ ( n gb -- n seq ) [ position>index ] keep delegate ;
|
||||||
|
|
||||||
|
M: gb nth ( n gb -- elt ) bounds-check gb@ nth-unsafe ;
|
||||||
|
|
||||||
|
M: gb nth-unsafe ( n gb -- elt ) gb@ nth-unsafe ;
|
||||||
|
|
||||||
|
M: gb set-nth ( elt n seq -- ) bounds-check gb@ set-nth-unsafe ;
|
||||||
|
|
||||||
|
M: gb set-nth-unsafe ( elt n seq -- ) gb@ set-nth-unsafe ;
|
||||||
|
|
||||||
|
! ------------- moving the gap -------------------------------
|
||||||
|
|
||||||
|
: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
|
||||||
|
|
||||||
|
: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
|
||||||
|
|
||||||
|
: copy-elements-back ( dst start seq n -- )
|
||||||
|
dup 0 > [
|
||||||
|
>r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
|
||||||
|
] [ 3drop drop ] if ;
|
||||||
|
|
||||||
|
: copy-elements-forward ( dst start seq n -- )
|
||||||
|
dup 0 > [
|
||||||
|
>r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
|
||||||
|
] [ 3drop drop ] if ;
|
||||||
|
|
||||||
|
: copy-elements ( dst start end seq -- )
|
||||||
|
pick pick > [
|
||||||
|
>r dupd - r> swap copy-elements-forward
|
||||||
|
] [
|
||||||
|
>r over - r> swap copy-elements-back
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! the gap can be moved either forward or back. Moving the gap 'inside' means
|
||||||
|
! moving elements across the gap. Moving the gap 'around' means changing the
|
||||||
|
! start of the circular buffer to avoid moving as many elements.
|
||||||
|
|
||||||
|
! We decide which method (inside or around) to pick based on the number of
|
||||||
|
! elements that will need to be moved. We always try to move as few elements as
|
||||||
|
! possible.
|
||||||
|
|
||||||
|
: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
|
||||||
|
|
||||||
|
: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
|
||||||
|
|
||||||
|
: move-gap-back-inside? ( i gb -- i gb ? )
|
||||||
|
#! is it cheaper to move the gap inside than around?
|
||||||
|
2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
|
||||||
|
|
||||||
|
: move-gap-forward-inside? ( i gb -- i gb ? )
|
||||||
|
#! is it cheaper to move the gap inside than around?
|
||||||
|
2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
|
||||||
|
|
||||||
|
: move-gap-forward-inside ( i gb -- )
|
||||||
|
[ dup gap-length neg swap gb-gap-end rot ] keep delegate copy-elements ;
|
||||||
|
|
||||||
|
: move-gap-back-inside ( i gb -- )
|
||||||
|
[ dup gap-length swap gb-gap-start 1- rot 1- ] keep delegate copy-elements ;
|
||||||
|
|
||||||
|
: move-gap-forward-around ( i gb -- )
|
||||||
|
0 over move-gap-back-inside [
|
||||||
|
dup buffer-length [
|
||||||
|
swap gap-length - neg swap
|
||||||
|
] keep
|
||||||
|
] keep [
|
||||||
|
delegate copy-elements
|
||||||
|
] keep dup gap-length swap delegate change-circular-start ;
|
||||||
|
|
||||||
|
: move-gap-back-around ( i gb -- )
|
||||||
|
dup buffer-length over move-gap-forward-inside [
|
||||||
|
length swap -1
|
||||||
|
] keep [
|
||||||
|
delegate copy-elements
|
||||||
|
] keep dup length swap delegate change-circular-start ;
|
||||||
|
|
||||||
|
: move-gap-forward ( i gb -- )
|
||||||
|
move-gap-forward-inside? [
|
||||||
|
move-gap-forward-inside
|
||||||
|
] [
|
||||||
|
move-gap-forward-around
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: move-gap-back ( i gb -- )
|
||||||
|
move-gap-back-inside? [
|
||||||
|
move-gap-back-inside
|
||||||
|
] [
|
||||||
|
move-gap-back-around
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: (move-gap) ( i gb -- )
|
||||||
|
move-gap? [
|
||||||
|
move-gap-forward? [
|
||||||
|
move-gap-forward
|
||||||
|
] [
|
||||||
|
move-gap-back
|
||||||
|
] if
|
||||||
|
] [ 2drop ] if ;
|
||||||
|
|
||||||
|
: fix-gap ( n gb -- )
|
||||||
|
2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
|
||||||
|
|
||||||
|
: move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
|
||||||
|
|
||||||
|
! ------------ resizing -------------------------------------
|
||||||
|
|
||||||
|
: enough-room? ( n gb -- ? )
|
||||||
|
#! is there enough room to add 'n' elements to gb?
|
||||||
|
tuck length + swap buffer-length <= ;
|
||||||
|
|
||||||
|
: set-new-gap-end ( array gb -- )
|
||||||
|
[ buffer-length swap length swap - ] keep
|
||||||
|
[ gb-gap-end + ] keep set-gb-gap-end ;
|
||||||
|
|
||||||
|
: after-gap ( gb -- gb )
|
||||||
|
dup gb-gap-end swap delegate tail ;
|
||||||
|
|
||||||
|
: before-gap ( gb -- gb )
|
||||||
|
dup gb-gap-start swap head ;
|
||||||
|
|
||||||
|
: copy-after-gap ( array gb -- )
|
||||||
|
#! copy everything after the gap in 'gb' into the end of 'array',
|
||||||
|
#! and change 'gb's gap-end to reflect the gap-end in 'array'
|
||||||
|
dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> copy-into ;
|
||||||
|
|
||||||
|
: copy-before-gap ( array gb -- )
|
||||||
|
#! copy everything before the gap in 'gb' into the start of 'array'
|
||||||
|
before-gap 0 -rot copy-into ; ! gap start doesn't change
|
||||||
|
|
||||||
|
: resize-buffer ( gb new-size -- )
|
||||||
|
f <array> swap 2dup copy-before-gap 2dup copy-after-gap
|
||||||
|
>r <circular> r> set-delegate ;
|
||||||
|
|
||||||
|
: decrease-buffer-size ( gb -- )
|
||||||
|
#! the gap is too big, so resize to something sensible
|
||||||
|
dup length over required-space resize-buffer ;
|
||||||
|
|
||||||
|
: increase-buffer-size ( n gb -- )
|
||||||
|
#! increase the buffer to fit at least 'n' more elements
|
||||||
|
tuck length + over required-space resize-buffer ;
|
||||||
|
|
||||||
|
: gb-too-big? ( gb -- ? )
|
||||||
|
dup buffer-length over gb-min-size > [
|
||||||
|
dup length over buffer-length rot gb-expand-factor sq / <
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
: maybe-decrease ( gb -- )
|
||||||
|
dup gb-too-big? [
|
||||||
|
decrease-buffer-size
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: ensure-room ( n gb -- )
|
||||||
|
#! ensure that ther will be enough room for 'n' more elements
|
||||||
|
2dup enough-room? [ 2drop ] [
|
||||||
|
increase-buffer-size
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! ------- editing operations ---------------
|
||||||
|
|
||||||
|
G: insert* 2 standard-combination ;
|
||||||
|
|
||||||
|
: prepare-insert ( seq position gb -- seq gb )
|
||||||
|
tuck move-gap over length over ensure-room ;
|
||||||
|
|
||||||
|
: insert-elements ( seq gb -- )
|
||||||
|
dup gb-gap-start swap delegate rot copy-into ;
|
||||||
|
|
||||||
|
: increment-gap-start ( gb n -- )
|
||||||
|
over gb-gap-start + swap set-gb-gap-start ;
|
||||||
|
|
||||||
|
M: sequence insert* ( seq position gb -- )
|
||||||
|
prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
|
||||||
|
|
||||||
|
M: object insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
|
||||||
|
|
||||||
|
: delete* ( position gb -- )
|
||||||
|
tuck move-gap dup gb-gap-end 1+ over set-gb-gap-end maybe-decrease ;
|
||||||
|
|
||||||
|
! -------- stack/queue operations -----------
|
||||||
|
|
||||||
|
: push-start ( obj gb -- ) 0 swap insert* ;
|
||||||
|
|
||||||
|
: push-end ( obj gb -- ) [ length ] keep insert* ;
|
||||||
|
|
||||||
|
: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
|
||||||
|
|
||||||
|
: pop-start ( gb -- elem ) 0 swap pop-elem ;
|
||||||
|
|
||||||
|
: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
|
||||||
|
|
||||||
|
: rotate ( n gb -- )
|
||||||
|
dup length 1 > [
|
||||||
|
swap dup 0 > [
|
||||||
|
[ dup [ pop-end ] keep push-start ]
|
||||||
|
] [
|
||||||
|
neg [ dup [ pop-start ] keep push-end ]
|
||||||
|
] if times drop
|
||||||
|
] [ 2drop ] if ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,13 @@
|
||||||
|
USING: kernel sequences parser words compiler ;
|
||||||
|
|
||||||
|
[ "circular" "gap-buffer" ]
|
||||||
|
|
||||||
|
! load
|
||||||
|
dup [ "contrib/gap-buffer/" swap append ".factor" append run-file ] each
|
||||||
|
|
||||||
|
! compile
|
||||||
|
dup [ words [ try-compile ] each ] each
|
||||||
|
|
||||||
|
! test
|
||||||
|
[ "contrib/gap-buffer/" swap append "-tests.factor" append run-file ] each
|
||||||
|
|
||||||
Loading…
Reference in New Issue