guile18/ice-9/gap-buffer.scm

   1 ;;; gap-buffer.scm --- String buffer that supports point
   2
   3 ;;;     Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
   4 ;;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 ;;;
  19
  20 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
  21
  22 ;;; Commentary:
  23
  24 ;; A gap buffer is a structure that models a string but allows relatively
  25 ;; efficient insertion of text somewhere in the middle.  The insertion
  26 ;; location is called `point' with minimum value 1, and a maximum value of the
  27 ;; length of the string (which is not fixed).
  28 ;;
  29 ;; Specifically, we allocate a continuous buffer of characters that is
  30 ;; composed of the BEFORE, the GAP and the AFTER (reading L->R), like so:
  31 ;;
  32 ;;                          +--- POINT
  33 ;;                          v
  34 ;;    +--------------------+--------------------+--------------------+
  35 ;;    |       BEFORE       |        GAP         |       AFTER        |
  36 ;;    +--------------------+--------------------+--------------------+
  37 ;;
  38 ;;     <----- bef-sz ----->|<----- gap-sz ----->|<----- aft-sz ----->
  39 ;;
  40 ;;     <-------------------|       usr-sz       |------------------->
  41 ;;
  42 ;;     <-------------------------- all-sz -------------------------->
  43 ;;
  44 ;; This diagram also shows how the different sizes are computed, and the
  45 ;; location of POINT.  Note that the user-visible buffer size `usr-sz' does
  46 ;; NOT include the GAP, while the allocation `all-sz' DOES.
  47 ;;
  48 ;; The consequence of this arrangement is that "moving point" is simply a
  49 ;; matter of kicking characters across the GAP, while insertion can be viewed
  50 ;; as filling up the gap, increasing `bef-sz' and decreasing `gap-sz'.  When
  51 ;; `gap-sz' falls below some threshold, we reallocate with a larger `all-sz'.
  52 ;;
  53 ;; In the implementation, we actually keep track of the AFTER start offset
  54 ;; `aft-ofs' since it is used more often than `gap-sz'.  In fact, most of the
  55 ;; variables in the diagram are for conceptualization only.
  56 ;;
  57 ;; A gap buffer port is a soft port (see Guile manual) that wraps a gap
  58 ;; buffer.  Character and string writes, as well as character reads, are
  59 ;; supported.  Flushing and closing are not supported.
  60 ;;
  61 ;; These procedures are exported:
  62 ;;   (gb? OBJ)
  63 ;;   (make-gap-buffer . INIT)
  64 ;;   (gb-point GB)
  65 ;;   (gb-point-min GB)
  66 ;;   (gb-point-max GB)
  67 ;;   (gb-insert-string! GB STRING)
  68 ;;   (gb-insert-char! GB CHAR)
  69 ;;   (gb-delete-char! GB COUNT)
  70 ;;   (gb-goto-char GB LOCATION)
  71 ;;   (gb->string GB)
  72 ;;   (gb-filter! GB STRING-PROC)
  73 ;;   (gb->lines GB)
  74 ;;   (gb-filter-lines! GB LINES-PROC)
  75 ;;   (make-gap-buffer-port GB)
  76 ;;
  77 ;; INIT is an optional port or a string.  COUNT and LOCATION are integers.
  78 ;; STRING-PROC is a procedure that takes and returns a string.  LINES-PROC is
  79 ;; a procedure that takes and returns a list of strings, each representing a
  80 ;; line of text (newlines are stripped and added back automatically).
  81 ;;
  82 ;; (The term and concept of "gap buffer" are borrowed from Emacs.  We will
  83 ;; gladly return them when libemacs.so is available. ;-)
  84 ;;
  85 ;; Notes:
  86 ;; - overrun errors are suppressed silently
  87
  88 ;;; Code:
  89
  90 (define-module (ice-9 gap-buffer)
  91   :autoload (srfi srfi-13) (string-join)
  92   :export (gb?
  93            make-gap-buffer
  94            gb-point
  95            gb-point-min
  96            gb-point-max
  97            gb-insert-string!
  98            gb-insert-char!
  99            gb-delete-char!
 100            gb-erase!
 101            gb-goto-char
 102            gb->string
 103            gb-filter!
 104            gb->lines
 105            gb-filter-lines!
 106            make-gap-buffer-port))
 107
 108 (define gap-buffer
 109   (make-record-type 'gap-buffer
 110                     '(s                 ; the buffer, a string
 111                       all-sz            ; total allocation
 112                       gap-ofs           ; GAP starts, aka (1- point)
 113                       aft-ofs           ; AFTER starts
 114                       )))
 115
 116 (define gb? (record-predicate gap-buffer))
 117
 118 (define s:       (record-accessor gap-buffer 's))
 119 (define all-sz:  (record-accessor gap-buffer 'all-sz))
 120 (define gap-ofs: (record-accessor gap-buffer 'gap-ofs))
 121 (define aft-ofs: (record-accessor gap-buffer 'aft-ofs))
 122
 123 (define s!       (record-modifier gap-buffer 's))
 124 (define all-sz!  (record-modifier gap-buffer 'all-sz))
 125 (define gap-ofs! (record-modifier gap-buffer 'gap-ofs))
 126 (define aft-ofs! (record-modifier gap-buffer 'aft-ofs))
 127
 128 ;; todo: expose
 129 (define default-initial-allocation 128)
 130 (define default-chunk-size 128)
 131 (define default-realloc-threshold 32)
 132
 133 (define (round-up n)
 134   (* default-chunk-size (+ 1 (quotient n default-chunk-size))))
 135
 136 (define new (record-constructor gap-buffer '()))
 137
 138 (define (realloc gb inc)
 139   (let* ((old-s   (s: gb))
 140          (all-sz  (all-sz: gb))
 141          (new-sz  (+ all-sz inc))
 142          (gap-ofs (gap-ofs: gb))
 143          (aft-ofs (aft-ofs: gb))
 144          (new-s   (make-string new-sz))
 145          (new-aft-ofs (+ aft-ofs inc)))
 146     (substring-move! old-s 0 gap-ofs new-s 0)
 147     (substring-move! old-s aft-ofs all-sz new-s new-aft-ofs)
 148     (s! gb new-s)
 149     (all-sz! gb new-sz)
 150     (aft-ofs! gb new-aft-ofs)))
 151
 152 (define (make-gap-buffer . init)        ; port/string
 153   (let ((gb (new)))
 154     (cond ((null? init)
 155            (s! gb (make-string default-initial-allocation))
 156            (all-sz! gb default-initial-allocation)
 157            (gap-ofs! gb 0)
 158            (aft-ofs! gb default-initial-allocation))
 159           (else (let ((jam! (lambda (string len)
 160                               (let ((alloc (round-up len)))
 161                                 (s! gb (make-string alloc))
 162                                 (all-sz! gb alloc)
 163                                 (substring-move! string 0 len (s: gb) 0)
 164                                 (gap-ofs! gb len)
 165                                 (aft-ofs! gb alloc))))
 166                       (v (car init)))
 167                   (cond ((port? v)
 168                          (let ((next (lambda () (read-char v))))
 169                            (let loop ((c (next)) (acc '()) (len 0))
 170                              (if (eof-object? c)
 171                                  (jam! (list->string (reverse acc)) len)
 172                                  (loop (next) (cons c acc) (1+ len))))))
 173                         ((string? v)
 174                          (jam! v (string-length v)))
 175                         (else (error "bad init type"))))))
 176     gb))
 177
 178 (define (gb-point gb)
 179   (1+ (gap-ofs: gb)))
 180
 181 (define (gb-point-min gb) 1)            ; no narrowing (for now)
 182
 183 (define (gb-point-max gb)
 184   (1+ (- (all-sz: gb) (- (aft-ofs: gb) (gap-ofs: gb)))))
 185
 186 (define (insert-prep gb len)
 187   (let* ((gap-ofs (gap-ofs: gb))
 188          (aft-ofs (aft-ofs: gb))
 189          (slack (- (- aft-ofs gap-ofs) len)))
 190     (and (< slack default-realloc-threshold)
 191          (realloc gb (round-up (- slack))))
 192     gap-ofs))
 193
 194 (define (gb-insert-string! gb string)
 195   (let* ((len (string-length string))
 196          (gap-ofs (insert-prep gb len)))
 197     (substring-move! string 0 len (s: gb) gap-ofs)
 198     (gap-ofs! gb (+ gap-ofs len))))
 199
 200 (define (gb-insert-char! gb char)
 201   (let ((gap-ofs (insert-prep gb 1)))
 202     (string-set! (s: gb) gap-ofs char)
 203     (gap-ofs! gb (+ gap-ofs 1))))
 204
 205 (define (gb-delete-char! gb count)
 206   (cond ((< count 0)                    ; backwards
 207          (gap-ofs! gb (max 0 (+ (gap-ofs: gb) count))))
 208         ((> count 0)                    ; forwards
 209          (aft-ofs! gb (min (all-sz: gb) (+ (aft-ofs: gb) count))))
 210         ((= count 0)                    ; do nothing
 211          #t)))
 212
 213 (define (gb-erase! gb)
 214   (gap-ofs! gb 0)
 215   (aft-ofs! gb (all-sz: gb)))
 216
 217 (define (point++n! gb n s gap-ofs aft-ofs) ; n>0; warning: reckless
 218   (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
 219   (gap-ofs! gb (+ gap-ofs n))
 220   (aft-ofs! gb (+ aft-ofs n)))
 221
 222 (define (point+-n! gb n s gap-ofs aft-ofs) ; n<0; warning: reckless
 223   (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
 224   (gap-ofs! gb (+ gap-ofs n))
 225   (aft-ofs! gb (+ aft-ofs n)))
 226
 227 (define (gb-goto-char gb new-point)
 228   (let ((pmax (gb-point-max gb)))
 229     (or (and (< new-point 1)    (gb-goto-char gb 1))
 230         (and (> new-point pmax) (gb-goto-char gb pmax))
 231         (let ((delta (- new-point (gb-point gb))))
 232           (or (= delta 0)
 233               ((if (< delta 0)
 234                    point+-n!
 235                    point++n!)
 236                gb delta (s: gb) (gap-ofs: gb) (aft-ofs: gb))))))
 237   new-point)
 238
 239 (define (gb->string gb)
 240   (let ((s (s: gb)))
 241     (string-append (substring s 0 (gap-ofs: gb))
 242                    (substring s (aft-ofs: gb)))))
 243
 244 (define (gb-filter! gb string-proc)
 245   (let ((new (string-proc (gb->string gb))))
 246     (gb-erase! gb)
 247     (gb-insert-string! gb new)))
 248
 249 (define (gb->lines gb)
 250   (let ((str (gb->string gb)))
 251     (let loop ((start 0) (acc '()))
 252       (cond ((string-index str #\newline start)
 253              => (lambda (w)
 254                   (loop (1+ w) (cons (substring str start w) acc))))
 255             (else (reverse (cons (substring str start) acc)))))))
 256
 257 (define (gb-filter-lines! gb lines-proc)
 258   (let ((new-lines (lines-proc (gb->lines gb))))
 259     (gb-erase! gb)
 260     (gb-insert-string! gb (string-join new-lines #\newline))))
 261
 262 (define (make-gap-buffer-port gb)
 263   (or (gb? gb)
 264       (error "not a gap-buffer:" gb))
 265   (make-soft-port
 266    (vector
 267     (lambda (c) (gb-insert-char! gb c))
 268     (lambda (s) (gb-insert-string! gb s))
 269     #f
 270     (lambda () (let ((gap-ofs (gap-ofs: gb))
 271                      (aft-ofs (aft-ofs: gb)))
 272                  (if (= aft-ofs (all-sz: gb))
 273                      #f
 274                      (let* ((s (s: gb))
 275                             (c (string-ref s aft-ofs)))
 276                        (string-set! s gap-ofs c)
 277                        (gap-ofs! gb (1+ gap-ofs))
 278                        (aft-ofs! gb (1+ aft-ofs))
 279                        c))))
 280     #f)
 281    "rw"))
 282
 283 ;;; gap-buffer.scm ends here