; -*- Scheme -*-
;
; $Id: conc-string.scm,v 1.1 1998/03/16 07:58:05 foner Exp $

; conc-string is a form of string that supports efficient concatenation.

; see conc-string.doc for more information
;
; Stephen J. Bevan <bevan@cs.man.ac.uk> 19920914

;------------

; The conc-string is implemented as a binary tree with some redundant
; information in it for efficiency reasons (though not justified by
; timing).  The following is a VDMish definition of the structure :-
;
; Conc-String = Leaf | Branch | Substring
;
; Leaf :: string : SchemeString
;         length : Int
; where
;   inv-Leaf(mk-Leaf(s,l)) =
;     l = length s
;
; Branch :: left      : Conc-String
;           right     : Conc-String
;           left-end  : Int
;           right-end : Int
; where
;   inv-Branch(mk-Branch(l,r,le,re)) =
;     le = conc-string-length l /\
;     re = conc-string-length r + le
;
; Substring :: string : Conc-String
;              start  : Int
;              end    : Int
; where
;   inv-Substring(mk-Substring(st,s,e)) =
;     0 <= s <= e < conc-string-length st
;
; conc-string-length(mk-Leaf(s,l)) = l
; conc-string-length(mk-Branch(l,r,le,re)) = re
; conc-string-length(mk-Substring(st,s,e)) = e - s + 1
;
;------------

(define conc-string::leaf?
  (lambda (obj)
    (eq? (vector-ref obj 0) 'conc-string::leaf)))

(define conc-string::leaf
  (lambda (str)
    (vector 'conc-string::leaf str (string-length str))))

(define conc-string::leaf:string (lambda (leaf) (vector-ref leaf 1)))
(define conc-string::leaf:length (lambda (leaf) (vector-ref leaf 2)))

;------------

(define conc-string::branch?
  (lambda (obj)
    (eq? (vector-ref obj 0) 'conc-string::branch)))

(define conc-string::branch
  (lambda (left right left-end right-end)
    (vector 'conc-string::branch left right left-end right-end)))

(define conc-string::branch:left (lambda (branch) (vector-ref branch 1)))
(define conc-string::branch:right (lambda (branch) (vector-ref branch 2)))
(define conc-string::branch:left-end (lambda (branch) (vector-ref branch 3)))
(define conc-string::branch:right-end (lambda (branch) (vector-ref branch 4)))

;------------

(define conc-string::substring?
  (lambda (obj)
    (eq? (vector-ref obj 0) 'conc-string::substring)))

;-----------

(define conc-string:substring
  (lambda (str start end)
    (if (<= end start)
	(conc-string:<-string "")
	(let ((len (conc-string:length str)))
	  (if (and (< start len) (<= end len))
	      (vector 'conc-string::substring str start end)
	      (conc-string:error:bounds str end))))))

;------------

(define conc-string::substring:string (lambda (str) (vector-ref str 1)))
(define conc-string::substring:start (lambda (str) (vector-ref str 2)))
(define conc-string::substring:end (lambda (str) (vector-ref str 3)))

;-------------

(define conc-string:<-string conc-string::leaf)

;-------------

(define conc-string:->string
  (lambda (str)
    (cond ((conc-string::leaf? str) (conc-string::leaf:string str))
	  ((conc-string::branch? str)
	   (string-append
	     (conc-string:->string (conc-string::branch:left str))
	     (conc-string:->string (conc-string::branch:right str))))
	  (else
	   (substring
	     (conc-string:->string (conc-string::substring:string str))
	     (conc-string::substring:start str)
	     (conc-string::substring:end str))))))

;-------------

(define conc-string:length
  (lambda (str)
    (cond ((conc-string::leaf? str)
	   (conc-string::leaf:length str))
	  ((conc-string::branch? str)
	   (conc-string::branch:right-end str))
	  (else
	   (- (conc-string::substring:end str)
	      (conc-string::substring:start str))))))

;------------

(define conc-string::left-end
  (lambda (str)
    (cond ((conc-string::leaf? str)
	   (conc-string::leaf:length str))
	  ((conc-string::branch? str)
	   (conc-string::branch:right-end str))
	  (else (conc-string::substring:end str)))))

(define conc-string:append:2
  (lambda (left right)
    (let ((right-end (conc-string:length right))
	  (left-end (conc-string::left-end left)))
      (conc-string::branch left right left-end (+ left-end right-end)))))

; could optimise this to merge adjacent substring nodes.

(define conc-string:append:n
  (lambda (string . other-strings)
    (let loop ((str string)
	       (right other-strings))
      (if (null? right)
	  str
	  (loop (conc-string:append:2 str (car right))
		(cdr right))))))

;------------

(define conc-string:error:bounds
  (lambda (str idx)
    (error 'conc-string:error:bounds "index out of bounds ~s" idx)))

;------------

(define conc-string:ref
  (lambda (string index)
    (if (< index (conc-string:length string))
	(conc-string::unsafe-ref string index)
	(conc-string:error:bounds string index))))

(define conc-string::unsafe-ref
  (lambda (str idx)
    (cond ((conc-string::leaf? str)
	   (string-ref (conc-string::leaf:string str) idx))
	  ((conc-string::branch? str)
	   (if (< idx (conc-string::branch:left-end str))
	       (conc-string::unsafe-ref (conc-string::branch:left str) idx)
	       (conc-string::unsafe-ref
		 (conc-string::branch:right str)
		 (- idx (conc-string::branch:left-end str)))))
	  (else
	   (conc-string::unsafe-ref
	     (conc-string::substring:string str)
	     (+ idx (conc-string::substring:start str)))))))

;------------

(define conc-string:for-all
  (lambda (string action arg)
    (conc-string::for-all-chunks
      string
      (lambda (str start end arg)
	(let leaf-loop ((i start) (arg arg))
	  (if (= i end)
	      arg
	      (leaf-loop (+ i 1) (action (string-ref str i) arg)))))
      arg)))

; Hopefully this is more efficient than a simple loop that uses
; conc-string:ref to access each element :-

(define conc-string::naive-for-all
  (lambda (str action arg)
    (let ((len (conc-string:length str)))
      (let loop ((i 0)
		 (arg arg))
	(if (= i len)
	    arg
	    (loop (+ i 1) (action (conc-string:ref str i) arg)))))))

;------------

(define conc-string:for-each
  (lambda (str action arg)
    (let ((len (conc-string:length str)))
      (let loop ((i 0)
		 (arg arg))
	(if (= i len)
	    arg
	    (action (conc-string:ref str i)
		    arg
		    (lambda (result) (loop (+ i 1) result))))))))

; XXX: update this to use the same method as for-all

;------------

(define conc-string:display
  (lambda (str . rest)
    (let ((port (if (null? rest) (current-output-port) (car rest))))
      (conc-string:for-all
        str
	(lambda (chr arg)
	  (display chr port))
	#t))))

; An alternative method would be use FOR-ALL-CHUNKS.
; This would allow whole strings to be displayed in one go if the
; bounds matched the start/end of the string.

;------------

(define conc-string:delete
  (lambda (string start end)
    (if (<= end start)
	string
	(let ((len (conc-string:length string)))
	  (if (and (< start len) (<= end len))
	      (conc-string:append:2
	        (conc-string:substring string 0 start)
		(conc-string:substring string end len))
	      (conc-string:error:bounds string end))))))

; Does deletion by appending together the two chunks that lie on
; either side of the chunk to delete.
; An alternative would be to add a "delete" type to the tree.  This
; makes the representation more complex, but it could be more
; efficient.  Implement it and see!

;-----------

(define conc-string:write
  (lambda (str . rest)
    (let ((port (if (null? rest) (current-output-port) (car rest))))
      (conc-string:for-all
        str
	(lambda (chr arg) (write-char chr port))
	#t))))

; same comment as conc-string:display

;------------

(define conc-string:insert
  (lambda (string at in-string)
    (let ((len (conc-string:length in-string)))
      (if (or (< at 0) (> at len))
	  (conc-string:error:bounds in-string at)
	  (conc-string:append:n
	    (conc-string:substring in-string 0 at)
	    string
	    (conc-string:substring in-string at len))))))

;------------

(define conc-string?
  (lambda (str)
    (and (vector? str)
	 (or (conc-string::branch? str)
	     (conc-string::leaf? str)
	     (conc-string::substring? str)))))

;------------

; conc-string x (string x integer x integer x a -> a) x a -> a

(define conc-string::for-all-chunks
  (lambda (string action arg)
    (let loop ((str string)
	       (arg arg)
	       (start 0)
	       (end (conc-string:length string)))
      (if (= start end)
	  arg
	  (cond ((conc-string::leaf? str)
		 (action (conc-string::leaf:string str) start end arg))
		((conc-string::branch? str) 
		 (let ((m (conc-string::branch:left-end str)))
		   (cond ((<= start end m)
			  (loop (conc-string::branch:left str) arg start end))
			 ((<= m start end)
			  (loop (conc-string::branch:right str)
				arg
				(- start m)
				(- end m)))
			  (else ; (and (< start m) (<= m end))
			   (loop (conc-string::branch:right str)
				 (loop (conc-string::branch:left str) arg start m)
				 0
				 (- end m))))))
		(else ; (conc-string::substring? str)
		 (let ((base (conc-string::substring:start str)))
		   (loop (conc-string::substring:string str)
			 arg
			 (+ base start)
			 (min (+ base end) (conc-string::substring:end str))))))))))

; The primitive iteration function.
; ACTION is applied to each conventional scheme string in the tree
; with the start and end bounds of the section of that string that
; should be manipulated by ACTION.

;------------
