ice-9/gap-buffer.scm

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