gap-buffer.scm 9.6 KB

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