From 8ba243035aff7699a4cd3ccc06656eabb10c68c5 Mon Sep 17 00:00:00 2001 From: "chapman.alex" Date: Sun, 30 Apr 2006 14:51:44 +0000 Subject: [PATCH] added new and improved gap buffer --- contrib/gap-buffer/circular-tests.factor | 19 ++ contrib/gap-buffer/circular.factor | 25 +++ contrib/gap-buffer/gap-buffer-tests.factor | 41 ++++ contrib/gap-buffer/gap-buffer.factor | 236 +++++++++++++++++++++ contrib/gap-buffer/load.factor | 13 ++ 5 files changed, 334 insertions(+) create mode 100644 contrib/gap-buffer/circular-tests.factor create mode 100644 contrib/gap-buffer/circular.factor create mode 100644 contrib/gap-buffer/gap-buffer-tests.factor create mode 100644 contrib/gap-buffer/gap-buffer.factor create mode 100644 contrib/gap-buffer/load.factor diff --git a/contrib/gap-buffer/circular-tests.factor b/contrib/gap-buffer/circular-tests.factor new file mode 100644 index 0000000000..6aada74a70 --- /dev/null +++ b/contrib/gap-buffer/circular-tests.factor @@ -0,0 +1,19 @@ +USING: kernel test sequences sequences-internals circular ; + +[ 0 ] [ { 0 1 2 3 4 } 0 swap circular@ drop ] unit-test +[ 2 ] [ { 0 1 2 3 4 } 2 swap circular@ drop ] unit-test + +[ CHAR: t ] [ "test" 0 swap nth ] unit-test +[ "test" ] [ "test" "" like ] unit-test + +[ "test" 5 swap nth ] unit-test-fails +[ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test + +[ [ 1 2 3 ] ] [ { 1 2 3 } f like ] unit-test +[ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start f like ] unit-test +[ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start f like ] unit-test + +[ "fob" ] [ "foo" CHAR: b 2 pick set-nth "" like ] unit-test +[ "foo" CHAR: b 3 rot set-nth ] unit-test-fails +[ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe "" like ] unit-test +[ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth "" like ] unit-test diff --git a/contrib/gap-buffer/circular.factor b/contrib/gap-buffer/circular.factor new file mode 100644 index 0000000000..1aa1a672b2 --- /dev/null +++ b/contrib/gap-buffer/circular.factor @@ -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 ; + diff --git a/contrib/gap-buffer/gap-buffer-tests.factor b/contrib/gap-buffer/gap-buffer-tests.factor new file mode 100644 index 0000000000..435abee1b1 --- /dev/null +++ b/contrib/gap-buffer/gap-buffer-tests.factor @@ -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" "" like ] unit-test + +! test move-gap-back-inside +[ t f ] [ 5 "0123456" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test +[ "0123456" ] [ "0123456" 5 over move-gap >string ] unit-test +! test move-gap-forward-inside +[ t ] [ "I once ate a spaniel" 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test +[ "I once ate a spaniel" ] [ "I once ate a spaniel" 15 over move-gap 17 over move-gap >string ] unit-test +! test move-gap-back-around +[ f f ] [ 2 "terriers are ok too" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test +[ "terriers are ok too" ] [ "terriers are ok too" 2 over move-gap >string ] unit-test +! test move-gap-forward-around +[ f t ] [ "god is nam's best friend" 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" 2 over move-gap 22 over move-gap >string ] unit-test + +! test changing buffer contents +[ "factory" ] [ "factor" CHAR: y 6 pick insert* >string ] unit-test +! test inserting multiple elements in different places. buffer should grow +[ "refractory" ] [ "factor" 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" 3 [ 1 over delete* ] times >string ] unit-test +! more testing of nth and set-nth +[ "raptor" ] [ "factor" CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test + +! test stack/queue operations +[ "slaughter" ] [ "laughter" CHAR: s over push-start >string ] unit-test +[ "pantonio" ] [ "pant" "onio" over push-end >string ] unit-test +[ CHAR: f "actor" ] [ "factor" dup pop-start swap >string ] unit-test +[ CHAR: s "pant" ] [ "pants" dup pop-end swap >string ] unit-test +[ "end this is the " ] [ "this is the end " 4 over rotate >string ] unit-test +[ "your jedi training is finished " ] [ "finished your jedi training is " -9 over rotate >string ] unit-test + diff --git a/contrib/gap-buffer/gap-buffer.factor b/contrib/gap-buffer/gap-buffer.factor new file mode 100644 index 0000000000..6a0905e702 --- /dev/null +++ b/contrib/gap-buffer/gap-buffer.factor @@ -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 swap set-delegate + ] keep ; + +M: gb like ( seq gb -- seq ) drop ; + +: 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 swap 2dup copy-before-gap 2dup copy-after-gap + >r 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 ; + diff --git a/contrib/gap-buffer/load.factor b/contrib/gap-buffer/load.factor new file mode 100644 index 0000000000..0fadd0ae90 --- /dev/null +++ b/contrib/gap-buffer/load.factor @@ -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 +