;;; Scheme Underground char->char partial maps library		-*- Scheme -*-
;;;
;;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
;;; this code as long as you do not remove this copyright notice or
;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;;;     -Olin

;;; SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT
;;; This is *draft* code for a SRFI proposal. If you see this notice in 
;;; production code, you've got obsolete, bad source -- go find the final 
;;; non-draft code on the Net.
;;; SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT

;;; CCPs are an efficient data structure for doing simple string transforms,
;;; similar to the kinds of things you would do with the tr(1) program.

;;; Exports:
;;; ccp:0 ccp:1 ccp:upcase ccp:downcase
;;; ccp? ccp= ccp<=
;;; ccp-domain ccp->alist
;;; ccp-copy
;;; ccp-restrict  ccp-delete  ccp-adjoin  ccp-extend
;;; ccp-restrict! ccp-delete! ccp-adjoin! ccp-extend! 
;;; alist->ccp  proc->ccp  constant-ccp  extend-ccp/mappings  construct-ccp
;;; alist->ccp! proc->ccp! constant-ccp! extend-ccp/mappings! construct-ccp!
;;; ccp-compose ccp/mappings ccp-unfold ccp-unfold!
;;; ccp-tr ccp-map ccp-map! ccp-app ccp-fold ccp-for-each

;;; Imports
;;; This code has the following non-R5RS dependencies:
;;; - DEFINE-RECORD record macro
;;; - LET-OPTIONALS and :OPTIONAL macros for handling optional arguments
;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro
;;; - ASCII->CHAR CHAR->ASCII
;;; - Imports from the char-set library
;;; - List procs: EVERY FOLDL 
;;; - String procs: STRING-FOLDL STRING-MAP STRING-MAP!
;;; - ERROR
;;; - The (CHECK-ARG pred val proc) arg-checking procedure.
;;; - Calls to a parameter-checking procedure check-arg:
;;;   (define (check-arg pred val caller)
;;;     (let lp ((val val))
;;;       (if (pred val) val (lp (error "Bad argument" val pred caller)))))

;;; This code is tuned for a 7- or 8-bit character type. Large, 16-bit
;;; character types would need a more sophisticated data structure, tuned
;;; for sparseness. I would suggest something like this:
;;;     (define-record ccp
;;; 	    domain		; The domain char-set
;;; 	    map			; Sorted vector of (char . string) pairs 
;;; 				;   specifying the map.
;;; 	    id?)		; If true, mappings not specified by MAP are 
;;; 	    			;   identity mapping. If false, MAP must 
;;; 				;   specify a mapping for every char in DOMAIN.
;;; 
;;; A (char . string) elements in MAP specifies a mapping for the contiguous
;;; sequence of L chars beginning with CHAR (in the sequence of the underlying
;;; char type representation), where L is the length of STRING. These MAP elements
;;; are sorted by CHAR, so that binary search can be used to get from an input
;;; character C to the right MAP element quickly.
;;; 
;;; This representation should be reasonably compact for standard mappings on,
;;; say, a Unicode CCP. An implementation would probably want to store the
;;; Latin-1 subset of the map in a dense format, and keep the remainder in a 
;;; sparse format.

;;; Note that this code is, of course, dependent upon standard bindings for
;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
;;; to the procedure that takes the car of a list. If your Scheme 
;;; implementation allows user code to alter the bindings of these procedures
;;; in a manner that would be visible to these definitions, then there might
;;; be trouble. You could consider horrible kludgery along the lines of
;;;    (define fact 
;;;      (let ((= =) (- -) (* *))
;;;        (letrec ((real-fact (lambda (n) 
;;;                              (if (= n 0) 1 (* n (real-fact (- n 1)))))))
;;;          real-fact)))
;;; Or you could consider shifting to a reasonable Scheme system that, say,
;;; has a module system protecting code from this kind of lossage.

;;; This code does a fair amount of run-time argument checking. If your
;;; Scheme system has a sophisticated compiler that can eliminate redundant
;;; error checks, this is no problem. However, if not, these checks incur
;;; some performance overhead -- and, in a safe Scheme implementation, they
;;; are in some sense redundant: if we don't check to see that the PROC 
;;; parameter is a procedure, we'll find out anyway three lines later when
;;; we try to call the value. It's pretty easy to rip all this argument 
;;; checking code out if it's inappropriate for your implementation -- just
;;; nuke every call to CHECK-ARG.
;;;
;;; On the other hand, if you *do* have a sophisticated compiler that will
;;; actually perform soft-typing and eliminate redundant checks (Rice being
;;; the only possible candidate of which I'm aware), leaving these checks 
;;; in can *help*, since their presence can be elided in redundant cases,
;;; and in cases where they are needed, performing the checks early, at
;;; procedure entry, can "lift" a check out of a loop. 
;;;
;;; Finally, I have only checked the properties that can portably be checked
;;; with R5RS Scheme -- and this is not complete. You may wish to alter
;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
;;; checks, such as procedure arity for higher-order values.


(define num-chars (char-set-size char-set:full)) ; AKA 256.

(define-record ccp
  domain		; The domain char-set
  dshared?		; Is the domain value shared or linear?
  map			; 256-elt string
  mshared?)		; Is the map string shared or linear?


;;; Accessors and setters that manage the linear bookkeeping
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ccp-domain ccp)
  (set-ccp:dshared? ccp #t)
  (ccp:domain ccp))

;;; CCP is a linear ccp. PROC is a domain->domain function; it must be
;;; linear in its parameter and result.
;;;
;;; Updates the domain of the CCP with PROC, returns the resulting
;;; CCP; reuses the old one to construct the new one.

(define (restrict-linear-ccp-domain ccp proc)
  (let ((new-d (proc (if (ccp:dshared? ccp)
			 (begin (set-ccp:dshared? ccp #f)
				(char-set-copy (ccp:domain ccp)))
			 (ccp:domain ccp)))))
    (set-ccp:domain ccp new-d)
    ccp))

;;; CCP is a linear CCP. PROC is a domain x cmap -> domain function.
;;; It is passed a linear domain and cmap string. It may side-effect
;;; the cmap string, and returns the resulting updated domain.
;;; We return the resulting CCP, reusing the parameter to construct it.

(define (linear-update-ccp ccp proc)
  (let* ((cmap (if (ccp:mshared? ccp)
		   (begin (set-ccp:mshared? ccp #f)
			  (string-copy (ccp:map ccp)))
		   (ccp:map ccp)))

	 (new-d (proc (if (ccp:dshared? ccp)
			  (begin (set-ccp:dshared? ccp #f)
				 (char-set-copy (ccp:domain ccp)))
			  (ccp:domain ccp))
		      cmap)))
    (set-ccp:domain ccp new-d)
    ccp))



;;; Return CCP's map field, and mark it as shared. CCP functions that
;;; restrict a ccp's domain share map strings, so they use this guy.
(define (ccp:map/shared ccp)
  (set-ccp:mshared? ccp #t)
  (ccp:map ccp))

(define (ccp-copy ccp)
  (check-arg ccp? ccp ccp-copy)
  (make-ccp (char-set-copy (ccp:domain ccp)) #f
	    (string-copy (ccp:map ccp))      #f))

;;; N-ary equality relation for partial maps

(define (ccp= ccp1 . rest)
  (let ((domain (ccp:domain ccp1))
	(cmap (ccp:map ccp1)))
    (every (lambda (ccp2)
	     (and (char-set= domain (ccp:domain ccp2))
		  (let ((cmap2 (ccp:map ccp2)))
		    (or (eq? cmap2 cmap)	; Fast path.
			(char-set-every (lambda (c)
					  (let ((i (char->ascii c)))
					    (char=? (string-ref cmap  i)
						    (string-ref cmap2 i))))
					domain)))))
	    rest)))


;;; N-ary subset relation for partial maps

(define (ccp<= ccp1 . rest)
  (let lp ((domain1 (ccp:domain ccp1))
	   (cmap1 (ccp:map ccp1))
	   (rest rest))
    (or (not (pair? rest))
	(let* ((ccp2 (car rest))
	       (domain2 (ccp:domain ccp2))
	       (cmap2   (ccp:map    ccp2))
	       (rest (cdr rest)))
	  (and (char-set<= domain1 domain2)
	       (or (eq? cmap1 cmap2)			; Fast path
		   (char-set-every (lambda (c)		; Real test
				     (let ((i (char->ascii c)))
				       (char=? (string-ref cmap1 i)
					       (string-ref cmap2 i))))
				   domain1))
	       (lp domain2 cmap2 rest))))))


;;; CCP iterators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ccp-fold kons knil ccp)
  (check-arg procedure? kons ccp-fold)
  (check-arg ccp? ccp ccp-fold)
  (let ((cmap (ccp:map ccp)))
    (char-set-fold (lambda (c v) (kons c (string-ref cmap (char->ascii c)) v))
		   knil
		   (ccp:domain ccp))))

(define (ccp-for-each proc ccp)
  (check-arg procedure? proc ccp-for-each)
  (check-arg ccp? ccp ccp-for-each)
  (let ((cmap (ccp:map ccp)))
    (char-set-for-each (lambda (c) (proc c (string-ref cmap (char->ascii c))))
		       (ccp:domain ccp))))

(define (ccp->alist ccp)
  (check-arg ccp? ccp ccp->alist)
  (ccp-fold (lambda (from to alist) (cons (cons from to) alist))
	    '()
	    ccp))


;;; CCP-RESTRICT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Restrict a ccp's domain.

(define (ccp-restrict ccp cset)
  (check-arg ccp?      ccp  ccp-restrict)
  (check-arg char-set? cset ccp-restrict)
  (make-ccp (char-set-intersection cset (ccp:domain ccp))
	    #f
	    (ccp:map/shared ccp)
	    #t))

(define (ccp-restrict! ccp cset)
  (check-arg ccp?      ccp  ccp-restrict!)
  (check-arg char-set? cset ccp-restrict!)
  (restrict-linear-ccp-domain ccp (lambda (d) (char-set-intersection! d cset))))
					      

;;; CCP-ADJOIN ccp from-char1 to-char1 ... 
;;; CCP-DELETE ccp char1 ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Add & delete mappings to/from a ccp.

(define (ccp-delete ccp . chars)
  (check-arg ccp? ccp ccp-delete)
  (make-ccp (apply char-set-delete (ccp:domain ccp) chars)
	    #f
	    (ccp:map/shared ccp)
	    #t))

(define (ccp-delete! ccp . chars)
  (check-arg ccp? ccp ccp-delete!)
  (restrict-linear-ccp-domain ccp (lambda (d) (apply char-set-delete! d chars))))


(define (ccp-adjoin ccp . chars)
  (check-arg ccp? ccp ccp-adjoin)
  (let ((cmap (string-copy (ccp:map ccp))))
    (make-ccp (install-ccp-adjoin! cmap (char-set-copy (ccp:domain ccp)) chars)
	      #f
	      cmap
	      #f)))

(define (ccp-adjoin! ccp . chars)
  (check-arg ccp? ccp ccp-adjoin!)
  (linear-update-ccp ccp (lambda (d cmap) (install-ccp-adjoin! cmap d chars))))

(define (install-ccp-adjoin! cmap domain chars)
  (let lp ((chars chars) (d domain))
    (if (pair? chars)
	(let ((from  (car  chars))
	      (to    (cadr chars))
	      (chars (cddr chars)))
	  (string-set! cmap (char->ascii from) to)
	  (lp chars (char-set-adjoin! d from)))
	d)))


;;; CCP-EXTEND ccp1 ...
;;; CCP-EXTEND! ccp1 ccp2 ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extend ccp1 with ccp2, etc.

(define (ccp-extend . ccps)
  (if (pair? ccps)
      (let ((ccp0 (car ccps))
	    (ccps (cdr ccps)))
	(if (pair? ccps)
	    (let ((cmap (string-copy (ccp:map ccp0)))) ; Copy cmap.
	      ;; The FOLDL installs each ccp in CCPS into CMAP and produces
	      ;; the new domain.
	      (make-ccp (foldl (lambda (ccp d)
				 (install-ccp-extension! cmap d ccp))
			       (char-set-copy (ccp:domain ccp0))
			       ccps)
			#f cmap #f))

	    ccp0))	; Only 1 parameter

      ccp:0))	; 0 parameters

(define (ccp-extend! ccp0 . ccps)
  (check-arg ccp? ccp0 ccp-extend!)
  (linear-update-ccp ccp0
    (lambda (domain cmap)
      (foldl (lambda (ccp d) (install-ccp-extension! cmap d ccp))
	     domain
	     ccps))))


;;; Side-effect CMAP, linear-update and return DOMAIN.
(define (install-ccp-extension! cmap domain ccp)
  (let ((cmap1 (ccp:map ccp))
	(domain1 (ccp:domain ccp)))
    (char-set-for-each (lambda (c)
			 (let ((i (char->ascii c)))
			   (string-set! cmap i (string-ref cmap1 i))))
		       domain1)
    (char-set-union! domain domain1)))


;;; Compose the CCPs. 0-ary case: (ccp-compose) = ccp:1.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; For each character C-IN in the original domain, we push it
;;; through the pipeline of CCPs. If we ever land outside the
;;; domain of a ccp, we punt C-IN. If we push it all the way
;;; through, we add C-IN to our result domain, and add the mapping
;;; into the cmap we are assembling.
;;;
;;; Looping this way avoids building up intermediate temporary
;;; CCPs.  If CCP's were small bitsets, we might be better off
;;; slicing the double-nested loops the other way around.

(define (ccp-compose . ccps)
  (cond ((not (pair? ccps))       ccp:1)	; 0 args => ccp:1
	((not (pair? (cdr ccps))) (car ccps))	; 1 arg
	(else
	 (let* ((v (list->vector ccps))
		(vlen-2 (- (vector-length v) 2))
		(cmap (make-string num-chars))
		(d1 (ccp:domain (vector-ref v (+ vlen-2 1))))
		(d (char-set-fold (lambda (c-in d)
				    (let lp ((c c-in) (i vlen-2))
				      (if (>= i 0)
					  (let ((ccp (vector-ref v i)))
					    (if (char-set-contains? (ccp:domain ccp) c)
						(lp (string-ref (ccp:map ccp)
								(char->ascii c))
						    (- i 1))

						;; Lose: remove c-in from d.
						(char-set-delete! d c-in)))

					  ;; Win: C-IN -> C
					  (begin (string-set! cmap
							      (char->ascii c-in)
							      c)
						 d))))
				  (char-set-copy d1)
				  d1)))
	   (make-ccp d #f cmap #f)))))



;;; ALIST->CPP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (alist->ccp cc-alist . maybe-base-ccp)
  (let ((base (:optional maybe-base-ccp ccp:0)))
    (if (pair? cc-alist)
	(let ((cmap (string-copy (ccp:map base))))
	  (make-ccp (install-ccp-alist! cmap
					(char-set-copy (ccp:domain base))
					cc-alist)
		    #f cmap #f))
	base)))

(define (alist->ccp! alist base)
  (check-arg ccp? base alist->ccp!)
  (linear-update-ccp base (lambda (d cmap) (install-ccp-alist! cmap d alist))))

;;; Side-effect CMAP, linear-update and return DOMAIN.
(define (install-ccp-alist! cmap domain alist)
  (foldl (lambda (from/to d) (let ((from (car from/to))
				   (to (cdr from/to)))
			       (string-set! cmap (char->ascii from) to)
			       (char-set-adjoin! domain from)))
	 domain
	 alist))


;;; PROC->CCP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (proc->ccp proc [domain base-ccp])

(define (proc->ccp proc . args)
  (check-arg procedure? proc proc->ccp)
  (let-optionals args ((proc-domain char-set:full)
		       (base ccp:0))
    (let ((cmap (string-copy (ccp:map base))))
      (make-ccp (install-ccp-proc! cmap (char-set-copy (ccp:domain base))
				   proc proc-domain)
		#f cmap #f))))

(define (proc->ccp! proc proc-domain base)
  (check-arg procedure? proc proc->ccp!)
  (linear-update-ccp base
    (lambda (d cmap) (install-ccp-proc! cmap d proc proc-domain))))

(define (install-ccp-proc! cmap domain proc proc-domain)
  (char-set-for-each (lambda (c) (string-set! cmap (char->ascii c) (proc c)))
		     proc-domain)
  (char-set-union! domain proc-domain))


;;; CONSTANT-CCP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (constant-ccp char [domain base-ccp])
;;; Extend BASE-CCP with the a map taking every char in DOMAIN to CHAR.
;;; DOMAIN defaults to char-set:full. BASE-CCP defaults to CCP:0.

(define (constant-ccp char . args)
  (check-arg char? char constant-ccp)
  (let-optionals args ((char-domain char-set:full) (base ccp:0))
    (let ((cmap (string-copy (ccp:map base))))
      (make-ccp (install-constant-ccp! cmap (char-set-copy (ccp:domain base))
				       char char-domain)
		#f cmap #f))))

(define (constant-ccp! char char-domain base)
  (check-arg char?     char        constant-ccp)
  (check-arg char-set? char-domain constant-ccp)
  (check-arg ccp?      base        constant-ccp)
  (linear-update-ccp base
    (lambda (d cmap) (install-constant-ccp! cmap d char char-domain))))

;;; Install the constant mapping into CMAP0 by side-effect,
;;; linear-update & return DOMAIN0 with the constant-mapping's domain.
(define (install-constant-ccp! cmap0 domain0 char char-domain)
  (char-set-for-each (lambda (c) (string-set! cmap0 (char->ascii c) char))
		     char-domain)
  (char-set-union! domain0 char-domain))


;;; CCP/MAPPINGS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (ccp/mappings from1 to1 from2 to2 ...) -> ccp
;;; (extend-ccp/mappings  base-ccp from1 to1 from2 to2 ...) -> ccp
;;; (extend-ccp/mappings! base-ccp from1 to1 from2 to2 ...) -> ccp
;;; Each FROM element is either a string or a (lo-char . hi-char) range.
;;; Each TO element is either a string or a lo-char. Strings are replicated
;;;     to match the length of the corresponding FROM element.
;;; CCP/MAPPINGS's base CCP is CCP:0
;;;
;;; Tedious code.

;;; Internal utility.
;;; Install the FROM->TO mapping pair into DOMAIN & CMAP by side-effect.
;;; Return the new domain.

(define (install-ccp-mapping-pair! cmap domain from to)
  ;; Tedium -- four possibilities here:
  ;;   str->str, str->lo-char,
  ;;   range->str, range->lo-char.
  (if (string? from)
      (if (string? to)
	  ;; "abc" -> "ABC"
	  (let ((len1 (string-length from))
		(len2 (string-length to)))
	    (let lp2 ((i (- len1 1))
		      (j (modulo (- len2 1) len1))
		      (d domain))
	      (if (>= i 0)
		  (let ((c (string-ref from i)))
		    (string-set! cmap
				 (char->ascii c)
				 (string-ref to i))
		    (lp2 (- i 1)
			 (- (if (> j 0) j len2) 1)
			 (char-set-adjoin! d c)))
		  d)))

	  ;; "abc" -> #\A
	  (let lp2 ((i (- (string-length from) 1))
		    (j (char->ascii to))
		    (d domain))
	    (if (>= i 0)
		(let ((c (string-ref from i)))
		  (string-set! cmap
			       (char->ascii c)
			       (ascii->char j))
		  (lp2 (- i 1)
		       (- j 1)
		       (char-set-adjoin! d c)))
		d)))

      (let ((from-start (char->ascii (car from)))
	    (from-end   (char->ascii (cdr from))))
	(if (string? to)
	    (let ((len2-1 (- (string-length to) 1)))
	      ;; (#\a . #\c) -> "ABC"
	      (let lp2 ((i from-start) (j 0) (d domain))
		(if (<= i from-end)
		    (let ((c (string-ref to j)))
		      (string-set! cmap i c)
		      (lp2 (+ i 1)
			   (if (= j len2-1) 0 (+ j 1))
			   (char-set-adjoin! d c)))
		    d)))
				  
	    ;; (#\a . #\c) -> #\A
	    (do ((i from-start       (+ i 1))
		 (j (char->ascii to) (+ j 1))
		 (d domain (begin (string-set! cmap i (ascii->char j))
				  (char-set-adjoin d (ascii->char i)))))
		((> i from-end) d))))))

;;; Internal utility -- side-effects CMAP; linear-updates & returns DOMAIN.
(define (install-mapping-pairs cmap domain args)
  (let lp ((domain domain) (args args))
    (if (pair? args)
	(lp (install-ccp-mapping-pair! cmap domain (car args) (cadr args))
	    (cddr args))
	domain)))

(define (ccp/mappings . args)
  (let ((cmap (make-string num-chars)))
    (make-ccp (install-mapping-pairs (make-string num-chars)
				     (char-set-copy char-set:empty)
				     args)
	      #f cmap #f)))

(define (extend-ccp/mappings base . args)
  (check-arg ccp? base extend-ccp/mappings)
  (let ((cmap (string-copy (ccp:map base))))
    (make-ccp (install-mapping-pairs cmap (char-set-copy (ccp:domain base)) args)
	      #f cmap #f)))

(define (extend-ccp/mappings! base . args)
  (check-arg ccp? base extend-ccp/mappings!)
  (linear-update-ccp base (lambda (d cmap) (install-mapping-pairs cmap d args))))
  

;;; CONSTRUCT-CCP! ccp elt ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The kitchen-sink constructor; static typing be damned. 
;;; ELTS are interpreted as follows:
;;;	(lo-char . hi-char) to-string|lo-char		; ccp/range
;;; 	from-string to-string|lo-char			; ccp/range
;;; 	ccp						; ccp-extend
;;; 	alist						; alist->ccp
;;; 	domain char					; ccp-constant
;;; 	domain proc					; proc->ccp

(define (construct-ccp! ccp . elts)
  (check-arg ccp? ccp construct-ccp!)
  (linear-update-ccp ccp (lambda (d cmap) (install-ccp-construct! cmap d elts))))

(define (construct-ccp base . elts)
  (check-arg ccp? base construct-ccp)
  (let ((cmap (string-copy (ccp:map base))))
    (make-ccp (install-ccp-construct! cmap (char-set-copy (ccp:domain base)) elts)
	      #f cmap #f)))

;;; Install the mappings into CMAP by side-effect,
;;; linear-update & return DOMAIN with the final domain.

(define (install-ccp-construct! cmap domain elts)
  (let lp ((d domain) (elts elts))
    ;(format #t "d=~s elts=~s\n" d elts)
    (if (not (pair? elts)) d
	(let ((elt (car elts))
	      (elts (cdr elts)))
	  (cond ((pair? elt)
		 (cond ((pair? (car elt)) ; ELT is an alist.
			(lp (install-ccp-alist! cmap d elt) elts))
		       ((char? (car elt)) ; ELT is (lo-char . hi-char) range.
			(lp (install-ccp-mapping-pair! cmap d elt (car elts))
			    (cdr elts)))
		       (else (error "Illegal elt to construct-ccp" elt))))

		((string? elt)
		 (lp (install-ccp-mapping-pair! cmap d elt (car elts))
		     (cdr elts)))

		((ccp? elt) (lp (install-ccp-extension! cmap d elt) elts))

		((char-set? elt)
		 (let ((elt2 (car elts))
		       (elts (cdr elts)))
		   (lp (cond ((char? elt2)
			      (install-constant-ccp! cmap d elt2 elt))
			     ((procedure? elt2)
			      (install-ccp-proc! cmap d elt2 elt))
			     (else (error "Illegal elt-pair to construct-ccp"
					  elt elt2)))
		       elts)))

		(else (error "Illegal elt to construct-ccp" elt)))))))


;;; CCP unfold

(define (ccp-unfold! p f g ccp seed)
  (check-arg procedure? p ccp-unfold!)
  (check-arg procedure? f ccp-unfold!)
  (check-arg procedure? g ccp-unfold!)
  (check-arg ccp? ccp ccp-unfold!)
  (linear-update-ccp ccp
    (lambda (domain cmap) (%ccp-unfold! p f g domain cmap seed))))

(define (ccp-unfold p f g seed)
  (check-arg procedure? p ccp-unfold)
  (check-arg procedure? f ccp-unfold)
  (check-arg procedure? g ccp-unfold)
  (let ((domain (char-set-copy char-set:empty))
	(cmap (make-string 256 (ascii->char 0))))
    (make-ccp (%ccp-unfold! p f g domain cmap seed) #f cmap #f)))

(define (%ccp-unfold! p f g domain cmap seed)
  (let lp ((seed seed) (domain domain))
    (if (not (p seed)) domain
	(receive (from to) (f seed)
	  (string-set! cmap (char->ascii from) to)
	  (lp (g seed) (char-set-adjoin! domain from))))))
      


;;; Using CCPs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CCP-TR   ccp string [start end] -> string
;;; CCP-MAP  ccp string [start end] -> string
;;; CCP-MAP! ccp string [start end] -> undefined
;;; CCP-APP  ccp char -> char or false

;;; If a char in S is not in CCP's domain, it is dropped from the result.
;;; You can use this to map and delete chars from a string.

(define (ccp-tr ccp s . maybe-start+end)
  (check-arg ccp?    ccp ccp-tr)
  (check-arg string? s   ccp-tr)
  (let-optionals maybe-start+end ((start 0) (end (string-length s)))
    ;; Count up the chars in S that are in the domain,
    ;; and allocate the answer string ANS:
    (let* ((len (- end start))
	   (domain (ccp:domain ccp))
	   (ans-len (string-foldl (lambda (c numchars)
				    (if (char-set-contains? domain c)
					(+ numchars 1)
					numchars))
				  0 s start end))
	   (ans (make-string ans-len)))

      ;; Apply the map, installing the resulting chars into ANS:
      (string-foldl (lambda (c i) (cond ((ccp-app ccp c) =>
					 (lambda (c)
					   (string-set! ans i c)
					   (+ i 1)))
					(else i))) ; Not in domain -- drop it.
		    0 s start end)
      ans)))

(define (ccp-map  ccp s . maybe-start+end)
  (check-arg ccp?    ccp ccp-map)
  (check-arg string? s   ccp-map)
  (apply string-map (lambda (c) (ccp-app ccp c)) s maybe-start+end))

(define (ccp-map! ccp s . maybe-start+end)
  (check-arg ccp?    ccp ccp-map!)
  (check-arg string? s   ccp-map!)
  (apply string-map! (lambda (c) (ccp-app ccp c)) s maybe-start+end))

(define (ccp-app ccp char)
  (check-arg ccp?  ccp  ccp-app)
  (check-arg char? char ccp-app)
  (and (char-set-contains? (ccp:domain ccp) char)
       (string-ref (ccp:map ccp) (char->ascii char))))


;;; Primitive CCPs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define id-cmap
  (let ((m (make-string num-chars)))
    (do ((i (- num-chars 1) (- i 1)))
	((< i 0))
      (string-set! m i (ascii->char i)))
    m))
  
(define ccp:0 (make-ccp char-set:empty #t id-cmap #t))
(define ccp:1 (make-ccp char-set:full  #t id-cmap #t))

(define ccp:upcase   (proc->ccp char-upcase  char-set:full))
(define ccp:downcase (proc->ccp char-downcase char-set:full))