gap-buffer: some cleanup.
parent
ad24fa414f
commit
1cba716637
|
@ -4,8 +4,8 @@
|
||||||
! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
|
! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
|
||||||
! for a good introduction see:
|
! for a good introduction see:
|
||||||
! https://common-lisp.net/project/flexichain/download/StrandhVilleneuveMoore.pdf
|
! https://common-lisp.net/project/flexichain/download/StrandhVilleneuveMoore.pdf
|
||||||
USING: accessors arrays circular fry kernel math math.functions
|
USING: accessors arrays circular fry kernel locals math
|
||||||
math.order multiline sequences sequences.private ;
|
math.functions math.order multiline sequences sequences.private ;
|
||||||
IN: gap-buffer
|
IN: gap-buffer
|
||||||
|
|
||||||
! gap-start -- the first element of the gap
|
! gap-start -- the first element of the gap
|
||||||
|
@ -24,30 +24,29 @@ TUPLE: gb
|
||||||
[ expand-factor>> * ceiling >fixnum ]
|
[ expand-factor>> * ceiling >fixnum ]
|
||||||
[ min-size>> ] bi max ;
|
[ min-size>> ] bi max ;
|
||||||
|
|
||||||
: <gb> ( seq -- gb )
|
:: <gb> ( seq -- gb )
|
||||||
gb new
|
gb new
|
||||||
5 >>min-size
|
5 >>min-size
|
||||||
1.5 >>expand-factor
|
1.5 >>expand-factor
|
||||||
swap
|
seq length >>gap-start
|
||||||
[ length >>gap-start ] keep
|
seq length over required-space >>gap-end
|
||||||
[ length over required-space >>gap-end ] keep
|
dup gap-end>> seq { } like resize-array <circular> >>seq ;
|
||||||
over gap-end>> swap { } like resize-array <circular> >>seq ;
|
|
||||||
|
|
||||||
M: gb like ( seq gb -- seq ) drop <gb> ;
|
M: gb like ( seq gb -- seq ) drop <gb> ;
|
||||||
|
|
||||||
: gap-length ( gb -- n ) [ gap-end>> ] keep gap-start>> - ;
|
: gap-length ( gb -- n )
|
||||||
|
[ gap-end>> ] [ gap-start>> ] bi - ;
|
||||||
|
|
||||||
: buffer-length ( gb -- n ) seq>> length ;
|
: buffer-length ( gb -- n ) seq>> length ;
|
||||||
|
|
||||||
M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
|
M: gb length ( gb -- n )
|
||||||
|
[ buffer-length ] [ gap-length ] bi - ;
|
||||||
|
|
||||||
: valid-position? ( pos gb -- ? )
|
: valid-position? ( pos gb -- ? )
|
||||||
! one element past the end of the buffer is a valid position when we're inserting
|
! one element past the end of the buffer is a valid position
|
||||||
|
! when we're inserting
|
||||||
length -1 swap between? ;
|
length -1 swap between? ;
|
||||||
|
|
||||||
: valid-index? ( i gb -- ? )
|
|
||||||
buffer-length -1 swap between? ;
|
|
||||||
|
|
||||||
ERROR: position-out-of-bounds position gap-buffer ;
|
ERROR: position-out-of-bounds position gap-buffer ;
|
||||||
|
|
||||||
: position>index ( pos gb -- i )
|
: position>index ( pos gb -- i )
|
||||||
|
@ -59,8 +58,10 @@ ERROR: position-out-of-bounds position gap-buffer ;
|
||||||
position-out-of-bounds
|
position-out-of-bounds
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
TUPLE: index-out-of-bounds index gap-buffer ;
|
: valid-index? ( i gb -- ? )
|
||||||
C: <index-out-of-bounds> index-out-of-bounds
|
buffer-length -1 swap between? ;
|
||||||
|
|
||||||
|
ERROR: index-out-of-bounds index gap-buffer ;
|
||||||
|
|
||||||
: index>position ( i gb -- pos )
|
: index>position ( i gb -- pos )
|
||||||
2dup valid-index? [
|
2dup valid-index? [
|
||||||
|
@ -68,18 +69,10 @@ C: <index-out-of-bounds> index-out-of-bounds
|
||||||
gap-length -
|
gap-length -
|
||||||
] [ drop ] if
|
] [ drop ] if
|
||||||
] [
|
] [
|
||||||
<index-out-of-bounds> throw
|
index-out-of-bounds
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep seq>> ;
|
M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep seq>> ;
|
||||||
|
|
||||||
M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
|
|
||||||
|
|
||||||
M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
|
|
||||||
|
|
||||||
M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
|
|
||||||
|
|
||||||
M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
|
|
||||||
|
|
||||||
M: gb virtual-exemplar seq>> ;
|
M: gb virtual-exemplar seq>> ;
|
||||||
|
|
||||||
|
@ -108,13 +101,14 @@ INSTANCE: gb virtual-sequence
|
||||||
[ over - ] dip swap copy-elements-back
|
[ over - ] dip swap copy-elements-back
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
! the gap can be moved either forward or back. Moving the gap 'inside' means
|
! the gap can be moved either forward or back. Moving the gap
|
||||||
! moving elements across the gap. Moving the gap 'around' means changing the
|
! 'inside' means moving elements across the gap. Moving the gap
|
||||||
! start of the circular buffer to avoid moving as many elements.
|
! '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
|
! We decide which method (inside or around) to pick based on the
|
||||||
! elements that will need to be moved. We always try to move as few elements as
|
! number of elements that will need to be moved. We always try
|
||||||
! possible.
|
! to move as few elements as possible.
|
||||||
|
|
||||||
: move-gap? ( i gb -- i gb ? ) 2dup gap-end>> = not ;
|
: move-gap? ( i gb -- i gb ? ) 2dup gap-end>> = not ;
|
||||||
|
|
||||||
|
@ -122,17 +116,21 @@ INSTANCE: gb virtual-sequence
|
||||||
|
|
||||||
: move-gap-back-inside? ( i gb -- i gb ? )
|
: move-gap-back-inside? ( i gb -- i gb ? )
|
||||||
! is it cheaper to move the gap inside than around?
|
! is it cheaper to move the gap inside than around?
|
||||||
2dup [ gap-start>> swap 2 * - ] keep [ buffer-length ] keep gap-end>> - <= ;
|
2dup [ gap-start>> swap 2 * - ] keep
|
||||||
|
[ buffer-length ] keep gap-end>> - <= ;
|
||||||
|
|
||||||
: move-gap-forward-inside? ( i gb -- i gb ? )
|
: move-gap-forward-inside? ( i gb -- i gb ? )
|
||||||
! is it cheaper to move the gap inside than around?
|
! is it cheaper to move the gap inside than around?
|
||||||
2dup [ gap-end>> [ 2 * ] dip - ] keep [ gap-start>> ] keep buffer-length + <= ;
|
2dup [ gap-end>> [ 2 * ] dip - ] keep
|
||||||
|
[ gap-start>> ] keep buffer-length + <= ;
|
||||||
|
|
||||||
: move-gap-forward-inside ( i gb -- )
|
: move-gap-forward-inside ( i gb -- )
|
||||||
[ dup gap-length neg swap gap-end>> rot ] keep seq>> copy-elements ;
|
[ dup gap-length neg swap gap-end>> rot ] keep
|
||||||
|
seq>> copy-elements ;
|
||||||
|
|
||||||
: move-gap-back-inside ( i gb -- )
|
: move-gap-back-inside ( i gb -- )
|
||||||
[ dup gap-length swap gap-start>> 1 - rot 1 - ] keep seq>> copy-elements ;
|
[ dup gap-length swap gap-start>> 1 - rot 1 - ] keep
|
||||||
|
seq>> copy-elements ;
|
||||||
|
|
||||||
: move-gap-forward-around ( i gb -- )
|
: move-gap-forward-around ( i gb -- )
|
||||||
0 over move-gap-back-inside [
|
0 over move-gap-back-inside [
|
||||||
|
@ -176,10 +174,10 @@ INSTANCE: gb virtual-sequence
|
||||||
: fix-gap ( n gb -- )
|
: fix-gap ( n gb -- )
|
||||||
2dup [ gap-length + ] keep gap-end<< gap-start<< ;
|
2dup [ gap-length + ] keep gap-end<< gap-start<< ;
|
||||||
|
|
||||||
! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
|
! moving the gap to position 5 means that the element in
|
||||||
GENERIC: move-gap ( n gb -- )
|
! position 5 will be immediately after the gap
|
||||||
|
: move-gap ( n gb -- )
|
||||||
M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
|
2dup [ position>index ] keep (move-gap) fix-gap ;
|
||||||
|
|
||||||
! ------------ resizing -------------------------------------
|
! ------------ resizing -------------------------------------
|
||||||
|
|
||||||
|
@ -198,12 +196,14 @@ M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
|
||||||
dup gap-start>> head ;
|
dup gap-start>> head ;
|
||||||
|
|
||||||
: copy-after-gap ( array gb -- )
|
: copy-after-gap ( array gb -- )
|
||||||
! copy everything after the gap in 'gb' into the end of 'array',
|
! copy everything after the gap in 'gb' into the end of
|
||||||
! and change 'gb's gap-end to reflect the gap-end in 'array'
|
! 'array', and change 'gb's gap-end to reflect the gap-end
|
||||||
|
! in 'array'
|
||||||
dup after-gap [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ;
|
dup after-gap [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ;
|
||||||
|
|
||||||
: copy-before-gap ( array gb -- )
|
: copy-before-gap ( array gb -- )
|
||||||
! copy everything before the gap in 'gb' into the start of 'array'
|
! copy everything before the gap in 'gb' into the start of
|
||||||
|
! 'array'
|
||||||
before-gap 0 rot copy ; ! gap start doesn't change
|
before-gap 0 rot copy ; ! gap start doesn't change
|
||||||
|
|
||||||
: resize-buffer ( gb new-size -- )
|
: resize-buffer ( gb new-size -- )
|
||||||
|
@ -224,21 +224,17 @@ M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
|
||||||
] [ drop f ] if ;
|
] [ drop f ] if ;
|
||||||
|
|
||||||
: ?decrease ( gb -- )
|
: ?decrease ( gb -- )
|
||||||
dup gb-too-big? [
|
dup gb-too-big? [ decrease-buffer-size ] [ drop ] if ;
|
||||||
decrease-buffer-size
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
: ensure-room ( n gb -- )
|
: ensure-room ( n gb -- )
|
||||||
! ensure that ther will be enough room for 'n' more elements
|
! ensure that ther will be enough room for 'n' more elements
|
||||||
2dup enough-room? [ 2drop ] [
|
2dup enough-room? [ 2drop ] [ increase-buffer-size ] if ;
|
||||||
increase-buffer-size
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
! ------- editing operations ---------------
|
! ------- editing operations ---------------
|
||||||
|
|
||||||
GENERIC#: insert* 2 ( seq position gb -- )
|
GENERIC#: insert* 2 ( seq pos gb -- )
|
||||||
|
|
||||||
: prepare-insert ( seq position gb -- seq gb )
|
: prepare-insert ( seq pos gb -- seq gb )
|
||||||
tuck move-gap over length over ensure-room ;
|
tuck move-gap over length over ensure-room ;
|
||||||
|
|
||||||
: insert-elements ( seq gb -- )
|
: insert-elements ( seq gb -- )
|
||||||
|
@ -247,20 +243,14 @@ GENERIC#: insert* 2 ( seq position gb -- )
|
||||||
: increment-gap-start ( gb n -- )
|
: increment-gap-start ( gb n -- )
|
||||||
over gap-start>> + swap gap-start<< ;
|
over gap-start>> + swap gap-start<< ;
|
||||||
|
|
||||||
! generic dispatch identifies numbers as sequences before numbers...
|
M: number insert*
|
||||||
M: number insert* ( elem position gb -- ) [ 1array ] 2dip insert* ;
|
[ 1array ] 2dip insert* ;
|
||||||
! : number-insert ( num position gb -- ) [ 1array ] 2dip insert* ;
|
|
||||||
|
|
||||||
M: sequence insert* ( seq position gb -- )
|
M: sequence insert*
|
||||||
prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
|
prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
|
||||||
|
|
||||||
: (delete*) ( gb -- )
|
: delete* ( pos gb -- )
|
||||||
dup gap-end>> 1 + over gap-end<< ?decrease ;
|
tuck move-gap dup gap-end>> 1 + over gap-end<< ?decrease ;
|
||||||
|
|
||||||
GENERIC: delete* ( pos gb -- )
|
|
||||||
|
|
||||||
M: gb delete* ( position gb -- )
|
|
||||||
tuck move-gap (delete*) ;
|
|
||||||
|
|
||||||
! -------- stack/queue operations -----------
|
! -------- stack/queue operations -----------
|
||||||
|
|
||||||
|
@ -268,7 +258,7 @@ M: gb delete* ( position gb -- )
|
||||||
|
|
||||||
: push-end ( obj gb -- ) [ length ] keep insert* ;
|
: push-end ( obj gb -- ) [ length ] keep insert* ;
|
||||||
|
|
||||||
: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
|
: pop-elem ( pos gb -- elem ) [ nth ] 2keep delete* ;
|
||||||
|
|
||||||
: pop-start ( gb -- elem ) 0 swap pop-elem ;
|
: pop-start ( gb -- elem ) 0 swap pop-elem ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue