;;
;; gap-buffer.scm --- String buffer that supports point
;;
;; 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.
;;
;; (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
;;
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;;
;;; 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.
;;;
;;; A full copy of the Lesser GPL license can be found at
;;; <http://www.gnu.org/licenses/>.
;;;



(module gap-buffer
	
	(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!

	 default-initial-allocation
	 default-chunk-size
	 default-realloc-threshold
	 )

	(import scheme chicken)
	(require-library srfi-13 data-structures)
	(import (only srfi-13 string-join string-index string-copy!)
		(only data-structures ->string))


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


	(define default-initial-allocation (make-parameter 128))
	(define default-chunk-size (make-parameter 128))
	(define default-realloc-threshold (make-parameter 32))

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

	(define (new) (make-gap-buffer* "" 0 '() '()))

	(define-inline (substring-move! str1 start1 end1 str2 start2)
	  (string-copy! str2 start2 str1 start1 end1))
	
	(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 (->string #\newline)))))
	
;;; gap-buffer.scm ends here
)