1 ! Copyright (C) 2007 Alex Chapman All Rights Reserved.
2 ! See http://factorcode.org/license.txt for BSD license.
4 ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
5 ! for a good introduction see:
6 ! https://common-lisp.net/project/flexichain/download/StrandhVilleneuveMoore.pdf
7 USING: accessors arrays circular fry kernel locals math
8 math.functions math.order multiline sequences sequences.private ;
11 ! gap-start -- the first element of the gap
12 ! gap-end -- the first element after the gap
13 ! expand-factor -- should be > 1 + +
14 ! min-size -- < 5 is not sensible
23 : required-space ( n gb -- n )
24 [ expand-factor>> * ceiling >fixnum ]
25 [ min-size>> ] bi max ;
31 seq length >>gap-start
32 seq length over required-space >>gap-end
33 dup gap-end>> seq { } like resize-array <circular> >>seq ;
35 M: gb like ( seq gb -- seq ) drop <gb> ;
37 : gap-length ( gb -- n )
38 [ gap-end>> ] [ gap-start>> ] bi - ;
40 : buffer-length ( gb -- n ) seq>> length ;
42 M: gb length ( gb -- n )
43 [ buffer-length ] [ gap-length ] bi - ;
45 : valid-position? ( pos gb -- ? )
46 ! one element past the end of the buffer is a valid position
47 ! when we're inserting
48 length -1 swap between? ;
50 ERROR: position-out-of-bounds position gap-buffer ;
52 : position>index ( pos gb -- i )
53 2dup valid-position? [
58 position-out-of-bounds
61 : valid-index? ( i gb -- ? )
62 buffer-length -1 swap between? ;
64 ERROR: index-out-of-bounds index gap-buffer ;
66 : index>position ( i gb -- pos )
75 M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep seq>> ;
77 M: gb virtual-exemplar seq>> ;
79 INSTANCE: gb virtual-sequence
81 ! ------------- moving the gap -------------------------------
83 : (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
85 : copy-element ( dst start seq -- ) [ [ + ] keep ] dip (copy-element) ;
87 : copy-elements-back ( dst start seq n -- )
89 [ [ copy-element ] 3keep [ 1 + ] dip ] dip 1 - copy-elements-back
92 : copy-elements-forward ( dst start seq n -- )
94 [ [ copy-element ] 3keep [ 1 - ] dip ] dip 1 - copy-elements-forward
97 : copy-elements ( dst start end seq -- )
99 [ dupd - ] dip swap copy-elements-forward
101 [ over - ] dip swap copy-elements-back
104 ! the gap can be moved either forward or back. Moving the gap
105 ! 'inside' means moving elements across the gap. Moving the gap
106 ! 'around' means changing the start of the circular buffer to
107 ! avoid moving as many elements.
109 ! We decide which method (inside or around) to pick based on the
110 ! number of elements that will need to be moved. We always try
111 ! to move as few elements as possible.
113 : move-gap? ( i gb -- i gb ? ) 2dup gap-end>> = not ;
115 : move-gap-forward? ( i gb -- i gb ? ) 2dup gap-start>> >= ;
117 : move-gap-back-inside? ( i gb -- i gb ? )
118 ! is it cheaper to move the gap inside than around?
119 2dup [ gap-start>> swap 2 * - ] keep
120 [ buffer-length ] keep gap-end>> - <= ;
122 : move-gap-forward-inside? ( i gb -- i gb ? )
123 ! is it cheaper to move the gap inside than around?
124 2dup [ gap-end>> [ 2 * ] dip - ] keep
125 [ gap-start>> ] keep buffer-length + <= ;
127 : move-gap-forward-inside ( i gb -- )
128 [ dup gap-length neg swap gap-end>> rot ] keep
129 seq>> copy-elements ;
131 : move-gap-back-inside ( i gb -- )
132 [ dup gap-length swap gap-start>> 1 - rot 1 - ] keep
133 seq>> copy-elements ;
135 : move-gap-forward-around ( i gb -- )
136 0 over move-gap-back-inside [
138 swap gap-length - neg swap
142 ] keep dup gap-length swap seq>> change-circular-start ;
144 : move-gap-back-around ( i gb -- )
145 dup buffer-length over move-gap-forward-inside [
149 ] keep dup length swap seq>> change-circular-start ;
151 : move-gap-forward ( i gb -- )
152 move-gap-forward-inside? [
153 move-gap-forward-inside
155 move-gap-forward-around
158 : move-gap-back ( i gb -- )
159 move-gap-back-inside? [
165 : (move-gap) ( i gb -- )
174 : fix-gap ( n gb -- )
175 2dup [ gap-length + ] keep gap-end<< gap-start<< ;
177 ! moving the gap to position 5 means that the element in
178 ! position 5 will be immediately after the gap
179 : move-gap ( n gb -- )
180 2dup [ position>index ] keep (move-gap) fix-gap ;
182 ! ------------ resizing -------------------------------------
184 : enough-room? ( n gb -- ? )
185 ! is there enough room to add 'n' elements to gb?
186 tuck length + swap buffer-length <= ;
188 : set-new-gap-end ( array gb -- )
189 [ buffer-length swap length swap - ] keep
190 [ gap-end>> + ] keep gap-end<< ;
192 : after-gap ( gb -- gb )
193 dup seq>> swap gap-end>> tail ;
195 : before-gap ( gb -- gb )
196 dup gap-start>> head ;
198 : copy-after-gap ( array gb -- )
199 ! copy everything after the gap in 'gb' into the end of
200 ! 'array', and change 'gb's gap-end to reflect the gap-end
202 dup after-gap [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ;
204 : copy-before-gap ( array gb -- )
205 ! copy everything before the gap in 'gb' into the start of
207 before-gap 0 rot copy ; ! gap start doesn't change
209 : resize-buffer ( gb new-size -- )
210 f <array> swap 2dup copy-before-gap 2dup copy-after-gap
211 [ <circular> ] dip seq<< ;
213 : decrease-buffer-size ( gb -- )
214 ! the gap is too big, so resize to something sensible
215 dup length over required-space resize-buffer ;
217 : increase-buffer-size ( n gb -- )
218 ! increase the buffer to fit at least 'n' more elements
219 tuck length + over required-space resize-buffer ;
221 : gb-too-big? ( gb -- ? )
222 dup buffer-length over min-size>> > [
223 dup length over buffer-length rot expand-factor>> sq / <
226 : ?decrease ( gb -- )
227 dup gb-too-big? [ decrease-buffer-size ] [ drop ] if ;
229 : ensure-room ( n gb -- )
230 ! ensure that ther will be enough room for 'n' more elements
231 2dup enough-room? [ 2drop ] [ increase-buffer-size ] if ;
233 ! ------- editing operations ---------------
235 GENERIC#: insert* 2 ( seq pos gb -- )
237 : prepare-insert ( seq pos gb -- seq gb )
238 tuck move-gap over length over ensure-room ;
240 : insert-elements ( seq gb -- )
241 dup gap-start>> swap seq>> copy ;
243 : increment-gap-start ( gb n -- )
244 over gap-start>> + swap gap-start<< ;
247 [ 1array ] 2dip insert* ;
250 prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
252 : delete* ( pos gb -- )
253 tuck move-gap dup gap-end>> 1 + over gap-end<< ?decrease ;
255 ! -------- stack/queue operations -----------
257 : push-start ( obj gb -- ) 0 swap insert* ;
259 : push-end ( obj gb -- ) [ length ] keep insert* ;
261 : pop-elem ( pos gb -- elem ) [ nth ] 2keep delete* ;
263 : pop-start ( gb -- elem ) 0 swap pop-elem ;
265 : pop-end ( gb -- elem ) index-of-last pop-elem ;
267 : rotate-right ( gb -- )
268 dup [ pop-end ] keep push-start drop ;
270 : rotate-left ( gb -- )
271 dup [ pop-start ] keep push-end drop ;
275 '[ _ rotate-right ] times
277 [ neg ] dip '[ _ rotate-left ] times