unmaintained/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 ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
   7 USING: kernel arrays sequences sequences.private circular math
   8 math.order math.functions generic ;
   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     gap-start
  18     gap-end
  19     expand-factor
  20     min-size ;
  21
  22 GENERIC: gb-seq ( gb -- seq )
  23 GENERIC: set-gb-seq ( seq gb -- )
  24 M: gb gb-seq ( gb -- seq ) delegate ;
  25 M: gb set-gb-seq ( seq gb -- ) set-delegate ;
  26
  27 : required-space ( n gb -- n )
  28     tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
  29
  30 : <gb> ( seq -- gb )
  31     gb new
  32     5 over set-gb-min-size
  33     1.5 over set-gb-expand-factor
  34     [ >r length r> set-gb-gap-start ] 2keep
  35     [ swap length over required-space swap set-gb-gap-end ] 2keep
  36     [
  37         over length over required-space rot { } like resize-array <circular> swap set-gb-seq
  38     ] keep ;
  39
  40 M: gb like ( seq gb -- seq ) drop <gb> ;
  41
  42 : gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
  43
  44 : buffer-length ( gb -- n ) gb-seq length ;
  45
  46 M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
  47
  48 : valid-position? ( pos gb -- ? )
  49     #! one element past the end of the buffer is a valid position when we're inserting
  50     length -1 swap between? ;
  51
  52 : valid-index? ( i gb -- ? )
  53     buffer-length -1 swap between? ;
  54
  55 TUPLE: position-out-of-bounds position gap-buffer ;
  56 C: <position-out-of-bounds> position-out-of-bounds
  57
  58 : position>index ( pos gb -- i )
  59     2dup valid-position? [
  60         2dup gb-gap-start >= [
  61             gap-length +
  62         ] [ drop ] if
  63     ] [
  64         <position-out-of-bounds> throw
  65     ] if ;
  66
  67 TUPLE: index-out-of-bounds index gap-buffer ;
  68 C: <index-out-of-bounds> index-out-of-bounds
  69
  70 : index>position ( i gb -- pos )
  71     2dup valid-index? [
  72         2dup gb-gap-end >= [
  73             gap-length -
  74         ] [ drop ] if
  75     ] [
  76         <index-out-of-bounds> throw
  77     ] if ;
  78
  79 M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
  80
  81 M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
  82
  83 M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
  84
  85 M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
  86
  87 M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
  88
  89 M: gb virtual-seq gb-seq ;
  90
  91 INSTANCE: gb virtual-sequence
  92
  93 ! ------------- moving the gap -------------------------------
  94
  95 : (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
  96
  97 : copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
  98
  99 : copy-elements-back ( dst start seq n -- )
 100     dup 0 > [
 101         >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
 102     ] [ 3drop drop ] if ;
 103
 104 : copy-elements-forward ( dst start seq n -- )
 105     dup 0 > [
 106         >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
 107     ] [ 3drop drop ] if ;
 108
 109 : copy-elements ( dst start end seq -- )
 110     pick pick > [
 111         >r dupd - r> swap copy-elements-forward
 112     ] [
 113         >r over - r> swap copy-elements-back
 114     ] if ;
 115
 116 ! the gap can be moved either forward or back. Moving the gap 'inside' means
 117 ! moving elements across the gap. Moving the gap 'around' means changing the
 118 ! start of the circular buffer to avoid moving as many elements.
 119
 120 ! We decide which method (inside or around) to pick based on the number of
 121 ! elements that will need to be moved. We always try to move as few elements as
 122 ! possible.
 123
 124 : move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
 125
 126 : move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
 127
 128 : move-gap-back-inside? ( i gb -- i gb ? )
 129     #! is it cheaper to move the gap inside than around?
 130     2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
 131
 132 : move-gap-forward-inside? ( i gb -- i gb ? )
 133     #! is it cheaper to move the gap inside than around?
 134     2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
 135
 136 : move-gap-forward-inside ( i gb -- )
 137     [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
 138
 139 : move-gap-back-inside ( i gb -- )
 140     [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
 141
 142 : move-gap-forward-around ( i gb -- )
 143     0 over move-gap-back-inside [
 144         dup buffer-length [
 145             swap gap-length - neg swap
 146         ] keep
 147     ] keep [
 148         gb-seq copy-elements
 149     ] keep dup gap-length swap gb-seq change-circular-start ;
 150
 151 : move-gap-back-around ( i gb -- )
 152     dup buffer-length over move-gap-forward-inside [
 153         length swap -1
 154     ] keep [
 155         gb-seq copy-elements
 156     ] keep dup length swap gb-seq change-circular-start ;
 157
 158 : move-gap-forward ( i gb -- )
 159     move-gap-forward-inside? [
 160         move-gap-forward-inside
 161     ] [
 162         move-gap-forward-around
 163     ] if ;
 164
 165 : move-gap-back ( i gb -- )
 166     move-gap-back-inside? [
 167         move-gap-back-inside
 168     ] [
 169         move-gap-back-around
 170     ] if ;
 171
 172 : (move-gap) ( i gb -- )
 173     move-gap? [
 174         move-gap-forward? [
 175             move-gap-forward
 176         ] [
 177             move-gap-back
 178         ] if
 179     ] [ 2drop ] if ;
 180
 181 : fix-gap ( n gb -- )
 182     2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
 183
 184 ! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
 185 GENERIC: move-gap ( n gb -- )
 186
 187 M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
 188
 189 ! ------------ resizing -------------------------------------
 190
 191 : enough-room? ( n gb -- ? )
 192     #! is there enough room to add 'n' elements to gb?
 193     tuck length + swap buffer-length <= ;
 194
 195 : set-new-gap-end ( array gb -- )
 196     [ buffer-length swap length swap - ] keep
 197     [ gb-gap-end + ] keep set-gb-gap-end ;
 198
 199 : after-gap ( gb -- gb )
 200     dup gb-seq swap gb-gap-end tail ;
 201
 202 : before-gap ( gb -- gb )
 203     dup gb-gap-start head ;
 204
 205 : copy-after-gap ( array gb -- )
 206     #! copy everything after the gap in 'gb' into the end of 'array',
 207     #! and change 'gb's gap-end to reflect the gap-end in 'array'
 208     dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
 209
 210 : copy-before-gap ( array gb -- )
 211     #! copy everything before the gap in 'gb' into the start of 'array'
 212     before-gap 0 rot copy ; ! gap start doesn't change
 213
 214 : resize-buffer ( gb new-size -- )
 215     f <array> swap 2dup copy-before-gap 2dup copy-after-gap
 216     >r <circular> r> set-gb-seq ;
 217
 218 : decrease-buffer-size ( gb -- )
 219     #! the gap is too big, so resize to something sensible
 220     dup length over required-space resize-buffer ;
 221
 222 : increase-buffer-size ( n gb -- )
 223     #! increase the buffer to fit at least 'n' more elements
 224     tuck length + over required-space resize-buffer ;
 225
 226 : gb-too-big? ( gb -- ? )
 227     dup buffer-length over gb-min-size > [
 228         dup length over buffer-length rot gb-expand-factor sq / <
 229     ] [ drop f ] if ;
 230
 231 : ?decrease ( gb -- )
 232     dup gb-too-big? [
 233         decrease-buffer-size
 234     ] [ drop ] if ;
 235
 236 : ensure-room ( n gb -- )
 237     #! ensure that ther will be enough room for 'n' more elements
 238     2dup enough-room? [ 2drop ] [
 239         increase-buffer-size
 240     ] if ;
 241
 242 ! ------- editing operations ---------------
 243
 244 GENERIC# insert* 2 ( seq position gb -- )
 245
 246 : prepare-insert ( seq position gb -- seq gb )
 247     tuck move-gap over length over ensure-room ;
 248
 249 : insert-elements ( seq gb -- )
 250     dup gb-gap-start swap gb-seq copy ;
 251
 252 : increment-gap-start ( gb n -- )
 253     over gb-gap-start + swap set-gb-gap-start ;
 254
 255 ! generic dispatch identifies numbers as sequences before numbers...
 256 ! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
 257 : number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
 258
 259 M: sequence insert* ( seq position gb -- )
 260     pick number? [
 261         number-insert
 262     ] [
 263         prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
 264     ] if ;
 265
 266 : (delete*) ( gb -- )
 267     dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
 268
 269 GENERIC: delete* ( pos gb -- )
 270
 271 M: gb delete* ( position gb -- )
 272     tuck move-gap (delete*) ;
 273
 274 ! -------- stack/queue operations -----------
 275
 276 : push-start ( obj gb -- ) 0 swap insert* ;
 277
 278 : push-end ( obj gb -- ) [ length ] keep insert* ;
 279
 280 : pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
 281
 282 : pop-start ( gb -- elem ) 0 swap pop-elem ;
 283
 284 : pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
 285
 286 : rotate ( n gb -- )
 287     dup length 1 > [
 288         swap dup 0 > [
 289             [ dup [ pop-end ] keep push-start ]
 290         ] [
 291             neg [ dup [ pop-start ] keep push-end ]
 292         ] if times drop
 293     ] [ 2drop ] if ;
 294