Commit | Line | Data |
---|---|---|
c517e175 TTN |
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 |