[bpt/guile.git] / module / ice-9 / gap-buffer.scm

;;; gap-buffer.scm --- String buffer that supports point

;;;	Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; A gap buffer is a structure that models a string but allows relatively
;; efficient insertion of text somewhere in the middle.  The insertion
;; location is called `point' with minimum value 1, and a maximum value of the
;; length of the string (which is not fixed).
;;
;; Specifically, we allocate a continuous buffer of characters that is
;; composed of the BEFORE, the GAP and the AFTER (reading L->R), like so:
;;
;;                          +--- POINT
;;                          v
;;    +--------------------+--------------------+--------------------+
;;    |       BEFORE       |        GAP         |       AFTER        |
;;    +--------------------+--------------------+--------------------+
;;
;;     <----- bef-sz ----->|<----- gap-sz ----->|<----- aft-sz ----->
;;
;;     <-------------------|       usr-sz       |------------------->
;;
;;     <-------------------------- all-sz -------------------------->
;;
;; This diagram also shows how the different sizes are computed, and the
;; location of POINT.  Note that the user-visible buffer size `usr-sz' does
;; NOT include the GAP, while the allocation `all-sz' DOES.
;;
;; The consequence of this arrangement is that "moving point" is simply a
;; matter of kicking characters across the GAP, while insertion can be viewed
;; as filling up the gap, increasing `bef-sz' and decreasing `gap-sz'.  When
;; `gap-sz' falls below some threshold, we reallocate with a larger `all-sz'.
;;
;; In the implementation, we actually keep track of the AFTER start offset
;; `aft-ofs' since it is used more often than `gap-sz'.  In fact, most of the
;; variables in the diagram are for conceptualization only.
;;
;; A gap buffer port is a soft port (see Guile manual) that wraps a gap
;; buffer.  Character and string writes, as well as character reads, are
;; supported.  Flushing and closing are not supported.
;;
;; These procedures are exported:
;;   (gb? OBJ)
;;   (make-gap-buffer . INIT)
;;   (gb-point GB)
;;   (gb-point-min GB)
;;   (gb-point-max GB)
;;   (gb-insert-string! GB STRING)
;;   (gb-insert-char! GB CHAR)
;;   (gb-delete-char! GB COUNT)
;;   (gb-goto-char GB LOCATION)
;;   (gb->string GB)
;;   (gb-filter! GB STRING-PROC)
;;   (gb->lines GB)
;;   (gb-filter-lines! GB LINES-PROC)
;;   (make-gap-buffer-port GB)
;;
;; INIT is an optional port or a string.  COUNT and LOCATION are integers.
;; STRING-PROC is a procedure that takes and returns a string.  LINES-PROC is
;; a procedure that takes and returns a list of strings, each representing a
;; line of text (newlines are stripped and added back automatically).
;;
;; (The term and concept of "gap buffer" are borrowed from Emacs.  We will
;; gladly return them when libemacs.so is available. ;-)
;;
;; Notes:
;; - overrun errors are suppressed silently

;;; Code:

(define-module (ice-9 gap-buffer)
  :autoload (srfi srfi-13) (string-join)
  :export (gb?
           make-gap-buffer
           gb-point
           gb-point-min
           gb-point-max
           gb-insert-string!
           gb-insert-char!
           gb-delete-char!
           gb-erase!
           gb-goto-char
           gb->string
           gb-filter!
           gb->lines
           gb-filter-lines!
           make-gap-buffer-port))

(define gap-buffer
  (make-record-type 'gap-buffer
                    '(s                 ; the buffer, a string
                      all-sz            ; total allocation
                      gap-ofs           ; GAP starts, aka (1- point)
                      aft-ofs           ; AFTER starts
                      )))

(define gb? (record-predicate gap-buffer))

(define s:       (record-accessor gap-buffer 's))
(define all-sz:  (record-accessor gap-buffer 'all-sz))
(define gap-ofs: (record-accessor gap-buffer 'gap-ofs))
(define aft-ofs: (record-accessor gap-buffer 'aft-ofs))

(define s!       (record-modifier gap-buffer 's))
(define all-sz!  (record-modifier gap-buffer 'all-sz))
(define gap-ofs! (record-modifier gap-buffer 'gap-ofs))
(define aft-ofs! (record-modifier gap-buffer 'aft-ofs))

;; todo: expose
(define default-initial-allocation 128)
(define default-chunk-size 128)
(define default-realloc-threshold 32)

(define (round-up n)
  (* default-chunk-size (+ 1 (quotient n default-chunk-size))))

(define new (record-constructor gap-buffer '()))

(define (realloc gb inc)
  (let* ((old-s   (s: gb))
         (all-sz  (all-sz: gb))
         (new-sz  (+ all-sz inc))
         (gap-ofs (gap-ofs: gb))
         (aft-ofs (aft-ofs: gb))
         (new-s   (make-string new-sz))
         (new-aft-ofs (+ aft-ofs inc)))
    (substring-move! old-s 0 gap-ofs new-s 0)
    (substring-move! old-s aft-ofs all-sz new-s new-aft-ofs)
    (s! gb new-s)
    (all-sz! gb new-sz)
    (aft-ofs! gb new-aft-ofs)))

(define (make-gap-buffer . init)        ; port/string
  (let ((gb (new)))
    (cond ((null? init)
           (s! gb (make-string default-initial-allocation))
           (all-sz! gb default-initial-allocation)
           (gap-ofs! gb 0)
           (aft-ofs! gb default-initial-allocation))
          (else (let ((jam! (lambda (string len)
                              (let ((alloc (round-up len)))
                                (s! gb (make-string alloc))
                                (all-sz! gb alloc)
                                (substring-move! string 0 len (s: gb) 0)
                                (gap-ofs! gb len)
                                (aft-ofs! gb alloc))))
                      (v (car init)))
                  (cond ((port? v)
                         (let ((next (lambda () (read-char v))))
                           (let loop ((c (next)) (acc '()) (len 0))
                             (if (eof-object? c)
                                 (jam! (list->string (reverse acc)) len)
                                 (loop (next) (cons c acc) (1+ len))))))
                        ((string? v)
                         (jam! v (string-length v)))
                        (else (error "bad init type"))))))
    gb))

(define (gb-point gb)
  (1+ (gap-ofs: gb)))

(define (gb-point-min gb) 1)            ; no narrowing (for now)

(define (gb-point-max gb)
  (1+ (- (all-sz: gb) (- (aft-ofs: gb) (gap-ofs: gb)))))

(define (insert-prep gb len)
  (let* ((gap-ofs (gap-ofs: gb))
         (aft-ofs (aft-ofs: gb))
         (slack (- (- aft-ofs gap-ofs) len)))
    (and (< slack default-realloc-threshold)
         (realloc gb (round-up (- slack))))
    gap-ofs))

(define (gb-insert-string! gb string)
  (let* ((len (string-length string))
         (gap-ofs (insert-prep gb len)))
    (substring-move! string 0 len (s: gb) gap-ofs)
    (gap-ofs! gb (+ gap-ofs len))))

(define (gb-insert-char! gb char)
  (let ((gap-ofs (insert-prep gb 1)))
    (string-set! (s: gb) gap-ofs char)
    (gap-ofs! gb (+ gap-ofs 1))))

(define (gb-delete-char! gb count)
  (cond ((< count 0)                    ; backwards
         (gap-ofs! gb (max 0 (+ (gap-ofs: gb) count))))
        ((> count 0)                    ; forwards
         (aft-ofs! gb (min (all-sz: gb) (+ (aft-ofs: gb) count))))
        ((= count 0)                    ; do nothing
         #t)))

(define (gb-erase! gb)
  (gap-ofs! gb 0)
  (aft-ofs! gb (all-sz: gb)))

(define (point++n! gb n s gap-ofs aft-ofs) ; n>0; warning: reckless
  (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
  (gap-ofs! gb (+ gap-ofs n))
  (aft-ofs! gb (+ aft-ofs n)))

(define (point+-n! gb n s gap-ofs aft-ofs) ; n<0; warning: reckless
  (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
  (gap-ofs! gb (+ gap-ofs n))
  (aft-ofs! gb (+ aft-ofs n)))

(define (gb-goto-char gb new-point)
  (let ((pmax (gb-point-max gb)))
    (or (and (< new-point 1)    (gb-goto-char gb 1))
        (and (> new-point pmax) (gb-goto-char gb pmax))
        (let ((delta (- new-point (gb-point gb))))
          (or (= delta 0)
              ((if (< delta 0)
                   point+-n!
                   point++n!)
               gb delta (s: gb) (gap-ofs: gb) (aft-ofs: gb))))))
  new-point)

(define (gb->string gb)
  (let ((s (s: gb)))
    (string-append (substring s 0 (gap-ofs: gb))
                   (substring s (aft-ofs: gb)))))

(define (gb-filter! gb string-proc)
  (let ((new (string-proc (gb->string gb))))
    (gb-erase! gb)
    (gb-insert-string! gb new)))

(define (gb->lines gb)
  (let ((str (gb->string gb)))
    (let loop ((start 0) (acc '()))
      (cond ((string-index str #\newline start)
             => (lambda (w)
                  (loop (1+ w) (cons (substring str start w) acc))))
            (else (reverse (cons (substring str start) acc)))))))

(define (gb-filter-lines! gb lines-proc)
  (let ((new-lines (lines-proc (gb->lines gb))))
    (gb-erase! gb)
    (gb-insert-string! gb (string-join new-lines #\newline))))

(define (make-gap-buffer-port gb)
  (or (gb? gb)
      (error "not a gap-buffer:" gb))
  (make-soft-port
   (vector
    (lambda (c) (gb-insert-char! gb c))
    (lambda (s) (gb-insert-string! gb s))
    #f
    (lambda () (let ((gap-ofs (gap-ofs: gb))
                     (aft-ofs (aft-ofs: gb)))
                 (if (= aft-ofs (all-sz: gb))
                     #f
                     (let* ((s (s: gb))
                            (c (string-ref s aft-ofs)))
                       (string-set! s gap-ofs c)
                       (gap-ofs! gb (1+ gap-ofs))
                       (aft-ofs! gb (1+ aft-ofs))
                       c))))
    #f)
   "rw"))

;;; gap-buffer.scm ends here
Commit	Line	Data
c517e175 TTN	1	;;; gap-buffer.scm --- String buffer that supports point
c517e175 TTN	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