diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index 5da01b2491..c4f1cf3d91 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -4,8 +4,8 @@ ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain ! for a good introduction see: ! https://common-lisp.net/project/flexichain/download/StrandhVilleneuveMoore.pdf -USING: accessors arrays circular fry kernel math math.functions -math.order multiline sequences sequences.private ; +USING: accessors arrays circular fry kernel locals math +math.functions math.order multiline sequences sequences.private ; IN: gap-buffer ! gap-start -- the first element of the gap @@ -24,30 +24,29 @@ TUPLE: gb [ expand-factor>> * ceiling >fixnum ] [ min-size>> ] bi max ; -: ( seq -- gb ) +:: ( seq -- gb ) gb new 5 >>min-size 1.5 >>expand-factor - swap - [ length >>gap-start ] keep - [ length over required-space >>gap-end ] keep - over gap-end>> swap { } like resize-array >>seq ; + seq length >>gap-start + seq length over required-space >>gap-end + dup gap-end>> seq { } like resize-array >>seq ; M: gb like ( seq gb -- seq ) drop ; -: gap-length ( gb -- n ) [ gap-end>> ] keep gap-start>> - ; +: gap-length ( gb -- n ) + [ gap-end>> ] [ gap-start>> ] bi - ; : 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 -- ? ) - ! 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? ; -: valid-index? ( i gb -- ? ) - buffer-length -1 swap between? ; - ERROR: position-out-of-bounds position gap-buffer ; : position>index ( pos gb -- i ) @@ -59,8 +58,10 @@ ERROR: position-out-of-bounds position gap-buffer ; position-out-of-bounds ] if ; -TUPLE: index-out-of-bounds index gap-buffer ; -C: index-out-of-bounds +: valid-index? ( i gb -- ? ) + buffer-length -1 swap between? ; + +ERROR: index-out-of-bounds index gap-buffer ; : index>position ( i gb -- pos ) 2dup valid-index? [ @@ -68,18 +69,10 @@ C: index-out-of-bounds gap-length - ] [ drop ] if ] [ - throw + index-out-of-bounds ] if ; 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>> ; @@ -108,13 +101,14 @@ INSTANCE: gb virtual-sequence [ over - ] dip 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. +! 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. +! 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 gap-end>> = not ; @@ -122,17 +116,21 @@ INSTANCE: gb virtual-sequence : move-gap-back-inside? ( i gb -- i gb ? ) ! 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 ? ) ! 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 -- ) - [ 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 -- ) - [ 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 -- ) 0 over move-gap-back-inside [ @@ -176,10 +174,10 @@ INSTANCE: gb virtual-sequence : fix-gap ( n gb -- ) 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 -GENERIC: move-gap ( n gb -- ) - -M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; +! moving the gap to position 5 means that the element in +! position 5 will be immediately after the gap +: move-gap ( n gb -- ) + 2dup [ position>index ] keep (move-gap) fix-gap ; ! ------------ resizing ------------------------------------- @@ -198,12 +196,14 @@ M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; dup gap-start>> 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' + ! 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 [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ; : 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 : 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 ; : ?decrease ( gb -- ) - dup gb-too-big? [ - decrease-buffer-size - ] [ drop ] if ; + 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 ; + 2dup enough-room? [ 2drop ] [ increase-buffer-size ] if ; ! ------- 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 ; : insert-elements ( seq gb -- ) @@ -247,20 +243,14 @@ GENERIC#: insert* 2 ( seq position gb -- ) : increment-gap-start ( gb n -- ) over gap-start>> + swap gap-start<< ; -! generic dispatch identifies numbers as sequences before numbers... -M: number insert* ( elem position gb -- ) [ 1array ] 2dip insert* ; -! : number-insert ( num position gb -- ) [ 1array ] 2dip insert* ; +M: number insert* + [ 1array ] 2dip insert* ; -M: sequence insert* ( seq position gb -- ) +M: sequence insert* prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ; -: (delete*) ( gb -- ) - dup gap-end>> 1 + over gap-end<< ?decrease ; - -GENERIC: delete* ( pos gb -- ) - -M: gb delete* ( position gb -- ) - tuck move-gap (delete*) ; +: delete* ( pos gb -- ) + tuck move-gap dup gap-end>> 1 + over gap-end<< ?decrease ; ! -------- stack/queue operations ----------- @@ -268,7 +258,7 @@ M: gb delete* ( position gb -- ) : 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 ;