home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / gap-buffer.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  10.1 KB  |  284 lines
  1. ;;; gap-buffer.scm --- String buffer that supports point
  2.  
  3. ;;;    Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
  4. ;;;
  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 2.1 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
  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
  218.   (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
  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
  223.   (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
  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
  284.