extra/gap-buffer/gap-buffer.factor

   1 ! Copyright (C) 2007 Alex Chapman All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   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 ;
   9 IN: gap-buffer
  10
  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
  15
  16 TUPLE: gb
  17     seq
  18     gap-start
  19     gap-end
  20     expand-factor
  21     min-size ;
  22
  23 : required-space ( n gb -- n )
  24     [ expand-factor>> * ceiling >fixnum ]
  25     [ min-size>> ] bi max ;
  26
  27 :: <gb> ( seq -- gb )
  28     gb new
  29         5 >>min-size
  30         1.5 >>expand-factor
  31         seq length >>gap-start
  32         seq length over required-space >>gap-end
  33         dup gap-end>> seq { } like resize-array <circular> >>seq ;
  34
  35 M: gb like ( seq gb -- seq ) drop <gb> ;
  36
  37 : gap-length ( gb -- n )
  38     [ gap-end>> ] [ gap-start>> ] bi - ;
  39
  40 : buffer-length ( gb -- n ) seq>> length ;
  41
  42 M: gb length ( gb -- n )
  43     [ buffer-length ] [ gap-length ] bi - ;
  44
  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? ;
  49
  50 ERROR: position-out-of-bounds position gap-buffer ;
  51
  52 : position>index ( pos gb -- i )
  53     2dup valid-position? [
  54         2dup gap-start>> >= [
  55             gap-length +
  56         ] [ drop ] if
  57     ] [
  58         position-out-of-bounds
  59     ] if ;
  60
  61 : valid-index? ( i gb -- ? )
  62     buffer-length -1 swap between? ;
  63
  64 ERROR: index-out-of-bounds index gap-buffer ;
  65
  66 : index>position ( i gb -- pos )
  67     2dup valid-index? [
  68         2dup gap-end>> >= [
  69             gap-length -
  70         ] [ drop ] if
  71     ] [
  72         index-out-of-bounds
  73     ] if ;
  74
  75 M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep seq>> ;
  76
  77 M: gb virtual-exemplar seq>> ;
  78
  79 INSTANCE: gb virtual-sequence
  80
  81 ! ------------- moving the gap -------------------------------
  82
  83 : (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
  84
  85 : copy-element ( dst start seq -- ) [ [ + ] keep ] dip (copy-element) ;
  86
  87 : copy-elements-back ( dst start seq n -- )
  88     dup 0 > [
  89         [ [ copy-element ] 3keep [ 1 + ] dip ] dip 1 - copy-elements-back
  90     ] [ 3drop drop ] if ;
  91
  92 : copy-elements-forward ( dst start seq n -- )
  93     dup 0 > [
  94         [ [ copy-element ] 3keep [ 1 - ] dip ] dip 1 - copy-elements-forward
  95     ] [ 3drop drop ] if ;
  96
  97 : copy-elements ( dst start end seq -- )
  98     pick pick > [
  99         [ dupd - ] dip swap copy-elements-forward
 100     ] [
 101         [ over - ] dip swap copy-elements-back
 102     ] if ;
 103
 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.
 108
 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.
 112
 113 : move-gap? ( i gb -- i gb ? ) 2dup gap-end>> = not ;
 114
 115 : move-gap-forward? ( i gb -- i gb ? ) 2dup gap-start>> >= ;
 116
 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>> - <= ;
 121
 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 + <= ;
 126
 127 : move-gap-forward-inside ( i gb -- )
 128     [ dup gap-length neg swap gap-end>> rot ] keep
 129     seq>> copy-elements ;
 130
 131 : move-gap-back-inside ( i gb -- )
 132     [ dup gap-length swap gap-start>> 1 - rot 1 - ] keep
 133     seq>> copy-elements ;
 134
 135 : move-gap-forward-around ( i gb -- )
 136     0 over move-gap-back-inside [
 137         dup buffer-length [
 138             swap gap-length - neg swap
 139         ] keep
 140     ] keep [
 141         seq>> copy-elements
 142     ] keep dup gap-length swap seq>> change-circular-start ;
 143
 144 : move-gap-back-around ( i gb -- )
 145     dup buffer-length over move-gap-forward-inside [
 146         length swap -1
 147     ] keep [
 148         seq>> copy-elements
 149     ] keep dup length swap seq>> change-circular-start ;
 150
 151 : move-gap-forward ( i gb -- )
 152     move-gap-forward-inside? [
 153         move-gap-forward-inside
 154     ] [
 155         move-gap-forward-around
 156     ] if ;
 157
 158 : move-gap-back ( i gb -- )
 159     move-gap-back-inside? [
 160         move-gap-back-inside
 161     ] [
 162         move-gap-back-around
 163     ] if ;
 164
 165 : (move-gap) ( i gb -- )
 166     move-gap? [
 167         move-gap-forward? [
 168             move-gap-forward
 169         ] [
 170             move-gap-back
 171         ] if
 172     ] [ 2drop ] if ;
 173
 174 : fix-gap ( n gb -- )
 175     2dup [ gap-length + ] keep gap-end<< gap-start<< ;
 176
 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 ;
 181
 182 ! ------------ resizing -------------------------------------
 183
 184 : enough-room? ( n gb -- ? )
 185     ! is there enough room to add 'n' elements to gb?
 186     tuck length + swap buffer-length <= ;
 187
 188 : set-new-gap-end ( array gb -- )
 189     [ buffer-length swap length swap - ] keep
 190     [ gap-end>> + ] keep gap-end<< ;
 191
 192 : after-gap ( gb -- gb )
 193     dup seq>> swap gap-end>> tail ;
 194
 195 : before-gap ( gb -- gb )
 196     dup gap-start>> head ;
 197
 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
 201     ! in 'array'
 202     dup after-gap [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ;
 203
 204 : copy-before-gap ( array gb -- )
 205     ! copy everything before the gap in 'gb' into the start of
 206     ! 'array'
 207     before-gap 0 rot copy ; ! gap start doesn't change
 208
 209 : resize-buffer ( gb new-size -- )
 210     f <array> swap 2dup copy-before-gap 2dup copy-after-gap
 211     [ <circular> ] dip seq<< ;
 212
 213 : decrease-buffer-size ( gb -- )
 214     ! the gap is too big, so resize to something sensible
 215     dup length over required-space resize-buffer ;
 216
 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 ;
 220
 221 : gb-too-big? ( gb -- ? )
 222     dup buffer-length over min-size>> > [
 223         dup length over buffer-length rot expand-factor>> sq / <
 224     ] [ drop f ] if ;
 225
 226 : ?decrease ( gb -- )
 227     dup gb-too-big? [ decrease-buffer-size ] [ drop ] if ;
 228
 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 ;
 232
 233 ! ------- editing operations ---------------
 234
 235 GENERIC#: insert* 2 ( seq pos gb -- )
 236
 237 : prepare-insert ( seq pos gb -- seq gb )
 238     tuck move-gap over length over ensure-room ;
 239
 240 : insert-elements ( seq gb -- )
 241     dup gap-start>> swap seq>> copy ;
 242
 243 : increment-gap-start ( gb n -- )
 244     over gap-start>> + swap gap-start<< ;
 245
 246 M: number insert*
 247     [ 1array ] 2dip insert* ;
 248
 249 M: sequence insert*
 250     prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
 251
 252 : delete* ( pos gb -- )
 253     tuck move-gap dup gap-end>> 1 + over gap-end<< ?decrease ;
 254
 255 ! -------- stack/queue operations -----------
 256
 257 : push-start ( obj gb -- ) 0 swap insert* ;
 258
 259 : push-end ( obj gb -- ) [ length ] keep insert* ;
 260
 261 : pop-elem ( pos gb -- elem ) [ nth ] 2keep delete* ;
 262
 263 : pop-start ( gb -- elem ) 0 swap pop-elem ;
 264
 265 : pop-end ( gb -- elem ) index-of-last pop-elem ;
 266
 267 : rotate-right ( gb -- )
 268     dup [ pop-end ] keep push-start drop ;
 269
 270 : rotate-left ( gb -- )
 271     dup [ pop-start ] keep push-end drop ;
 272
 273 : rotate ( n gb -- )
 274     over 0 > [
 275         '[ _ rotate-right ] times
 276     ] [
 277         [ neg ] dip '[ _ rotate-left ] times
 278     ] if ;