Commit | Line | Data |
---|---|---|
c517e175 TTN |
1 | ;;; gap-buffer.scm --- String buffer that supports point |
2 | ||
cd5fea8d | 3 | ;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc. |
c517e175 | 4 | ;;; |
53befeb7 NJ |
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 3 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 | |
c517e175 TTN |
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 | |
4167fc54 | 218 | (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs) |
c517e175 TTN |
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 | |
4167fc54 | 223 | (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n)) |
c517e175 TTN |
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 |