libs/gap-buffer/gap-buffer.factor

   1 ! gap buffer -- Alex Chapman (chapman.alex@gmail.com)
   2 ! largely influenced by Strandh and Villeneuve's Flexichain
   3 ! for a good introduction see:
   4 ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
   5 USING: kernel arrays sequences sequences-internals circular math generic ;
   6 IN: gap-buffer
   7
   8 ! gap-start     -- the first element of the gap
   9 ! gap-end       -- the first element after the gap
  10 ! expand-factor -- should be > 1
  11 ! min-size      -- < 5 is not sensible
  12
  13 TUPLE: gb
  14     gap-start
  15     gap-end
  16     expand-factor
  17     min-size ;
  18
  19 : required-space ( n gb -- n )
  20     tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
  21
  22 C: gb ( seq -- gb )
  23     5 over set-gb-min-size
  24     1.5 over set-gb-expand-factor
  25     [ >r length r> set-gb-gap-start ] 2keep
  26     [ swap length over required-space swap set-gb-gap-end ] 2keep
  27     [
  28         over length over required-space rot { } like resize-array <circular> swap set-delegate
  29     ] keep ;
  30
  31 M: gb like ( seq gb -- seq ) drop <gb> ;
  32
  33 : gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
  34
  35 : buffer-length ( gb -- n ) delegate length ;
  36
  37 M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
  38
  39 : position>index ( n gb -- n )
  40     2dup gb-gap-start >= [
  41         gap-length +
  42     ] [ drop ] if ;
  43
  44 : gb@ ( n gb -- n seq ) [ position>index ] keep delegate ;
  45
  46 M: gb nth ( n gb -- elt ) bounds-check gb@ nth-unsafe ;
  47
  48 M: gb nth-unsafe ( n gb -- elt ) gb@ nth-unsafe ;
  49
  50 M: gb set-nth ( elt n seq -- ) bounds-check gb@ set-nth-unsafe ;
  51
  52 M: gb set-nth-unsafe ( elt n seq -- ) gb@ set-nth-unsafe ;
  53
  54 ! ------------- moving the gap -------------------------------
  55
  56 : (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
  57
  58 : copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
  59
  60 : copy-elements-back ( dst start seq n -- )
  61     dup 0 > [
  62         >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
  63     ] [ 3drop drop ] if ;
  64
  65 : copy-elements-forward ( dst start seq n -- )
  66     dup 0 > [
  67         >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
  68     ] [ 3drop drop ] if ;
  69
  70 : copy-elements ( dst start end seq -- )
  71     pick pick > [
  72         >r dupd - r> swap copy-elements-forward
  73     ] [
  74         >r over - r> swap copy-elements-back
  75     ] if ;
  76
  77 ! the gap can be moved either forward or back. Moving the gap 'inside' means
  78 ! moving elements across the gap. Moving the gap 'around' means changing the
  79 ! start of the circular buffer to avoid moving as many elements.
  80
  81 ! We decide which method (inside or around) to pick based on the number of
  82 ! elements that will need to be moved. We always try to move as few elements as
  83 ! possible.
  84
  85 : move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
  86
  87 : move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
  88
  89 : move-gap-back-inside? ( i gb -- i gb ? )
  90     #! is it cheaper to move the gap inside than around?
  91     2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
  92
  93 : move-gap-forward-inside? ( i gb -- i gb ? )
  94     #! is it cheaper to move the gap inside than around?
  95     2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
  96
  97 : move-gap-forward-inside ( i gb -- )
  98     [ dup gap-length neg swap gb-gap-end rot ] keep delegate copy-elements ;
  99
 100 : move-gap-back-inside ( i gb -- )
 101     [ dup gap-length swap gb-gap-start 1- rot 1- ] keep delegate copy-elements ;
 102
 103 : move-gap-forward-around ( i gb -- )
 104     0 over move-gap-back-inside [
 105         dup buffer-length [
 106             swap gap-length - neg swap
 107         ] keep
 108     ] keep [
 109         delegate copy-elements
 110     ] keep dup gap-length swap delegate change-circular-start ;
 111
 112 : move-gap-back-around ( i gb -- )
 113     dup buffer-length over move-gap-forward-inside [
 114         length swap -1
 115     ] keep [
 116         delegate copy-elements
 117     ] keep dup length swap delegate change-circular-start ;
 118
 119 : move-gap-forward ( i gb -- )
 120     move-gap-forward-inside? [
 121         move-gap-forward-inside
 122     ] [
 123         move-gap-forward-around
 124     ] if ;
 125
 126 : move-gap-back ( i gb -- )
 127     move-gap-back-inside? [
 128         move-gap-back-inside
 129     ] [
 130         move-gap-back-around
 131     ] if ;
 132
 133 : (move-gap) ( i gb -- )
 134     move-gap? [
 135         move-gap-forward? [
 136             move-gap-forward
 137         ] [
 138             move-gap-back
 139         ] if
 140     ] [ 2drop ] if ;
 141
 142 : fix-gap ( n gb -- )
 143     2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
 144
 145 : move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
 146
 147 ! ------------ resizing -------------------------------------
 148
 149 : enough-room? ( n gb -- ? )
 150     #! is there enough room to add 'n' elements to gb?
 151     tuck length + swap buffer-length <= ;
 152
 153 : set-new-gap-end ( array gb -- )
 154     [ buffer-length swap length swap - ] keep
 155     [ gb-gap-end + ] keep set-gb-gap-end ;
 156
 157 : after-gap ( gb -- gb )
 158     dup delegate swap gb-gap-end tail ;
 159
 160 : before-gap ( gb -- gb )
 161     dup gb-gap-start head ;
 162
 163 : copy-after-gap ( array gb -- )
 164     #! copy everything after the gap in 'gb' into the end of 'array',
 165     #! and change 'gb's gap-end to reflect the gap-end in 'array'
 166     dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> copy-into ;
 167
 168 : copy-before-gap ( array gb -- )
 169     #! copy everything before the gap in 'gb' into the start of 'array'
 170     before-gap 0 -rot copy-into ; ! gap start doesn't change
 171
 172 : resize-buffer ( gb new-size -- )
 173     f <array> swap 2dup copy-before-gap 2dup copy-after-gap
 174     >r <circular> r> set-delegate ;
 175
 176 : decrease-buffer-size ( gb -- )
 177     #! the gap is too big, so resize to something sensible
 178     dup length over required-space resize-buffer ;
 179
 180 : increase-buffer-size ( n gb -- )
 181     #! increase the buffer to fit at least 'n' more elements
 182     tuck length + over required-space resize-buffer ;
 183
 184 : gb-too-big? ( gb -- ? )
 185     dup buffer-length over gb-min-size > [
 186         dup length over buffer-length rot gb-expand-factor sq / <
 187     ] [ drop f ] if ;
 188
 189 : maybe-decrease ( gb -- )
 190     dup gb-too-big? [
 191         decrease-buffer-size
 192     ] [ drop ] if ;
 193
 194 : ensure-room ( n gb -- )
 195     #! ensure that ther will be enough room for 'n' more elements
 196     2dup enough-room? [ 2drop ] [
 197         increase-buffer-size
 198     ] if ;
 199
 200 ! ------- editing operations ---------------
 201
 202 G: insert* ( seq position gb -- ) 2 standard-combination ;
 203
 204 : prepare-insert ( seq position gb -- seq gb )
 205     tuck move-gap over length over ensure-room ;
 206
 207 : insert-elements ( seq gb -- )
 208     dup gb-gap-start swap delegate rot copy-into ;
 209
 210 : increment-gap-start ( gb n -- )
 211     over gb-gap-start + swap set-gb-gap-start ;
 212
 213 M: sequence insert* ( seq position gb -- )
 214     prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
 215
 216 M: object insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
 217
 218 : delete* ( position gb -- )
 219     tuck move-gap dup gb-gap-end 1+ over set-gb-gap-end maybe-decrease ;
 220
 221 ! -------- stack/queue operations -----------
 222
 223 : push-start ( obj gb -- ) 0 swap insert* ;
 224
 225 : push-end ( obj gb -- ) [ length ] keep insert* ;
 226
 227 : pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
 228
 229 : pop-start ( gb -- elem ) 0 swap pop-elem ;
 230
 231 : pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
 232
 233 : rotate ( n gb -- )
 234     dup length 1 > [
 235         swap dup 0 > [
 236             [ dup [ pop-end ] keep push-start ]
 237         ] [
 238             neg [ dup [ pop-start ] keep push-end ]
 239         ] if times drop
 240     ] [ 2drop ] if ;
 241