;;; Scheme Underground character-sets library			-*- Scheme -*-
;;;
;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom.
;;; - Massively rehacked & extended by Olin Shivers 6/98.

;;; This code, being (distantly) derived from MIT Scheme source, is
;;;     Copyright (c) 1988-1995 Massachusetts Institute of Technology
;;; The MIT Scheme license is a "free software" license. See the end of
;;; this file for the tedious details. 

;;; 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

;;; This is simple code, not great code. Char sets are represented as 256-char
;;; strings. If char I is ASCII 0, then it isn't in the set; if char I
;;; is ASCII 1, then it is in the set.
;;; - Should be rewritten to use bit strings, or at least byte vecs.
;;; - Is ASCII/Latin-1 specific. Would certainly have to be rewritten
;;;   for Unicode.
;;; - The standard character sets are not Latin-1 compliant, just ASCII.

;;; This code uses jar's DEFINE-RECORD-TYPE macro to define the char-set
;;; record type, because the scsh-standard DEFINE-RECORD form automatically
;;; defines a COPY-FOO function, which is not the one we want, being a shallow
;;; copy of the record fields.

;;; Exports:
;;; char-set? char-set= char-set<=
;;; char-set-for-each char-set-fold
;;; char-set-unfold char-set-unfold!
;;; char-set chars->char-set string->char-set 
;;; ascii-range->char-set predicate->char-set ->char-set
;;; char-set-size char-set-members char-set-contains?
;;; char-set-every char-set-any
;;; char-set-adjoin  char-set-delete char-set-adjoin! char-set-delete!
;;; char-set-invert  char-set-union  char-set-intersection  char-set-difference
;;; char-set-invert! char-set-union! char-set-intersection! char-set-difference!
;;; char-set-copy
;;; char-set:lower-case	char-set:upper-case	char-set:alphabetic
;;; char-set:numeric	char-set:alphanumeric	char-set:graphic
;;; char-set:printing	char-set:whitespace	char-set:blank
;;; char-set:control	char-set:punctuation	char-set:hex-digit
;;; char-set:ascii	char-set:empty		char-set:full
;;; char-lower-case?	char-upper-case?	char-alphabetic?
;;; char-numeric?	char-alphanumeric?	char-graphic?
;;; char-printing?	char-whitespace?	char-blank?
;;; char-control?	char-punctuation?	char-hex-digit?
;;; char-ascii?

;;; Imports
;;; This code has the following non-R5RS dependencies:
;;; - ERROR
;;; - EVERY
;;; - ASCII->CHAR CHAR->ASCII
;;; - Jonathan Rees' DEFINE-RECORD-TYPE record macro
;;; - DEPRECATED-PROC (Any code using this proc can simply be deleted)

;;; 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 (%string-copy s) (substring s 0 (string-length s)))

;;;; Character Sets

;(define-record char-set
;  s)	; 256-char string; each char is either ASCII 0 or ASCII 1.

;;; Use jar's record macro.
(define-record-type char-set :char-set
  (make-char-set s)
  char-set?
  (s char-set:s))

(define (char-set-copy cs)
  (check-arg char-set? cs char-set-copy)
  (make-char-set (%string-copy (char-set:s cs))))

;;; The = and <= code is ugly because it's n-ary.

(define (char-set= cs1 . rest)
  (let ((s1 (char-set:s cs1)))
    (every (lambda (cs) (string=? s1 (char-set:s cs)))
	   rest)))

(define (char-set<= cs1 . rest)
  (let lp ((s1 (char-set:s cs1))  (rest rest))
    (or (not (pair? rest))
	(let ((s2 (char-set:s (car rest)))
	      (rest (cdr rest)))
	  (if (eq? s1 s2) (lp s2 rest)		; Fast path
	      (let lp2 ((i 255))		; Real test
		(if (< i 0) (lp s2 rest)
		    (and (<= (char->ascii (string-ref s1 i))
			     (char->ascii (string-ref s2 i)))
			 (lp2 (- i 1))))))))))


(define (char-set-size cs)
  (check-arg char-set? cs char-set-size)
  (let ((s (char-set:s cs)))
    (let lp ((i 255) (size 0))
      (if (< i 0) size
	  (lp (- i 1)
	      (if (= 0 (char->ascii (string-ref s i))) size (+ size 1)))))))

(define (%set-char-set cs in? chars)
  (let ((s (%string-copy (char-set:s cs)))
	(val (if in? (ascii->char 1) (ascii->char 0))))
    (for-each (lambda (c) (string-set! s (char->ascii c) val))
	      chars)
    (make-char-set s)))

(define (%set-char-set! cs in? chars)
  (let ((s (char-set:s cs))
	(val (if in? (ascii->char 1) (ascii->char 0))))
    (for-each (lambda (c) (string-set! s (char->ascii c) val))
	      chars))
  cs)

(define (char-set-adjoin  cs . chars) (%set-char-set  cs #t chars))
(define (char-set-adjoin! cs . chars) (%set-char-set! cs #t chars))
(define (char-set-delete  cs . chars) (%set-char-set  cs #f chars))
(define (char-set-delete! cs . chars) (%set-char-set! cs #f chars))

(define (char-set-for-each proc cs)
  (check-arg char-set?  cs   char-set-for-each)
  (check-arg procedure? proc char-set-for-each)
  (let ((s (char-set:s cs)))
    (let lp ((i 255))
      (cond ((>= i 0)
	     (if (not (= 0 (char->ascii (string-ref s i))))
		 (proc (ascii->char i)))
	     (lp (- i 1)))))))

(define (char-set-fold kons knil cs)
  (check-arg char-set?  cs   char-set-fold)
  (check-arg procedure? kons char-set-fold)
  (let ((s (char-set:s cs)))
    (let lp ((i 255) (ans knil))
      (if (< i 0) ans
	  (lp (- i 1)
	      (if (= 0 (char->ascii (string-ref s i)))
		  ans
		  (kons (ascii->char i) ans)))))))

(define reduce-char-set (deprecated-proc char-set-fold 'char-set-fold
					 "Use char-set-fold instead."))


(define (char-set-every pred cs)
  (check-arg char-set?  cs   char-set-every)
  (check-arg procedure? pred char-set-every)
  (let ((s (char-set:s cs)))
    (let lp ((i 255))
      (or (< i 0)
	  (if (= 0 (char->ascii (string-ref s i)))
	      (lp (- i 1))
	      (and (pred (ascii->char i))
		   (lp (- i 1))))))))

(define (char-set-any pred cs)
  (check-arg char-set?  cs   char-set-any)
  (check-arg procedure? pred char-set-any)
  (let ((s (char-set:s cs)))
    (let lp ((i 255))
      (and (>= i 0)
	   (if (= 0 (char->ascii (string-ref s i)))
	       (lp (- i 1))
	       (or (pred (ascii->char i))
		   (lp (- i 1))))))))


(define (char-set-unfold p f g seed) 
  (let ((s (make-string 256 (ascii->char 0))))
    (%char-set-unfold! char-set-unfold p f g s seed)
    (make-char-set s)))

(define (char-set-unfold! p f g cset seed)
  (%char-set-unfold! char-set-unfold! p f g (char-set:s cset) seed)
  cset)

(define (%char-set-unfold! proc p f g s seed)
  (check-arg procedure? p proc)
  (check-arg procedure? f proc)
  (check-arg procedure? g proc)
  (let ((a1 (ascii->char 1)))
    (let lp ((seed seed))
      (if (not (p seed))				; P says we are done.
	  (begin
	    (string-set! s (char->ascii (f seed)) a1)	; Add (F SEED) to set.
	    (lp (g seed)))))))				; Loop on (G SEED).


(define (char-set . chars)
  (chars->char-set chars))

(define (chars->char-set chars)
  (let ((s (make-string 256 (ascii->char 0))))
    (for-each (lambda (char) 
		(string-set! s (char->ascii char) (ascii->char 1)))
	      chars)
    (make-char-set s)))

(define (string->char-set str)
  (check-arg string? str string->char-set)
  (let ((s (make-string 256 (ascii->char 0))))
    (do ((i (- (string-length str) 1) (- i 1)))
	((< i 0) (make-char-set s))
      (string-set! s (char->ascii (string-ref str i))
		   (ascii->char 1)))))

(define (ascii-range->char-set lower upper)
  (check-arg integer? lower ascii-range->char-set)
  (check-arg integer? upper ascii-range->char-set)
  (let ((s (make-string 256 (ascii->char 0)))
	(c (ascii->char 1)))
    (do ((index lower (+ index 1)))
	((>= index upper) s)
      (string-set! s index c))
    (make-char-set s)))

(define (predicate->char-set predicate)
  (check-arg procedure? predicate predicate->char-set)
  (let ((s (make-string 256)))
    (let lp ((i 255))
      (if (>= i 0)
	  (begin (string-set! s i (if (predicate (ascii->char i)) 
				      (ascii->char 1)
				      (ascii->char 0)))
		 (lp (- i 1)))))
    (make-char-set s)))


;;; {string, char, char-set, char predicate} -> char-set

(define (->char-set x)
  (cond ((char-set? x) x)
	((string? x) (string->char-set x))
	((char? x) (char-set x))
	((procedure? x) (predicate->char-set x))
	(else (error "->char-set: Not a charset, string, char, or predicate."
		     x))))


;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

(define (char-set-members cs)
  (check-arg char-set? cs char-set-members)
  (let ((s (char-set:s cs)))
    (let lp ((i 255) (ans '()))
      (if (< i 0) ans
	  (lp (- i 1)
	      (if (zero? (char->ascii (string-ref s i))) ans
		  (cons (ascii->char i) ans)))))))

;;; De-releasing CHAR-SET-MEMBER?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; No other way to do it. MIT Scheme defines it (c-s-m? cset char); scsh 0.3
;;; defined it (c-s-m? char cset). MIT Scheme's arg order is not consistent 
;;; with the MEMBER? procedure or common math notation, but they were here
;;; first, so I didn't want to just silently invert their arg order -- could
;;; break code. I ended up just choosing a new proc name that consistent with
;;; its arg order -- (CHAR-SET-CONTAINS? cset char).

(define (char-set-contains? cs char)
  (not (zero? (char->ascii (string-ref (char-set:s cs)
				       (char->ascii char))))))

;;; This actually isn't exported. Just CYA.
(define (char-set-member? . args)
  (error "CHAR-SET-MEMBER? is no longer provided. Use CHAR-SET-CONTAINS? instead."))


;;; Set algebra
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (char-set-invert cs)
  (check-arg char-set? cs   char-set-invert)
  (predicate->char-set (lambda (char)
			 (not (char-set-contains? cs char)))))

(define (char-set-union . csets)
  (if (pair? csets)
      (apply char-set-union! (char-set-copy (car csets)) (cdr csets))
      char-set:empty))

(define (char-set-intersection . csets)
  (if (pair? csets)
      (apply char-set-intersection! (char-set-copy (car csets)) (cdr csets))
      char-set:full))

(define (char-set-difference cs1 . csets)
  (if (pair? csets)
      (apply char-set-difference! (char-set-copy cs1) csets)
      cs1))


;;; Linear set-algebraic ops
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These guys are allowed, but not required, to side-effect their first
;;; argument when computing their result. In other words, you must use them
;;; as if they were completely functional, just like their non-! counterparts,
;;; and you must additionally ensure that their first arguments are "dead"
;;; at the point of call. In return, we promise a more efficient result, plus
;;; allowing you to always assume char-sets are unchangeable values.

;;; Apply P to each index and it's char in S: (P I C).
;;; Used by the intersection & difference.
(define (%string-iter p s)
  (let lp ((i (- (string-length s) 1)))
    (cond ((>= i 0)
	   (p i (string-ref s i))
	   (lp (- i 1))))))

(define (char-set-invert! cset)
  (check-arg char-set? cset char-set-invert!)
  (let ((s (char-set:s cset)))
    (%string-iter (lambda (i c)
		    (string-set! s i (ascii->char (- 1 (char->ascii c)))))
		  s))
  cset)

(define (char-set-union! cset1 . csets)
  (let ((s (char-set:s cset1)))
    (for-each (lambda (cset)
		(char-set-for-each (lambda (c)
				     (string-set! s (char->ascii c)
						  (ascii->char 1)))
				   cset))
	      csets))
  cset1)

(define (char-set-intersection! cset1 . csets)
  (let ((s (char-set:s cset1)))
    (for-each (lambda (cset)
		(%string-iter (lambda (i c)
				(if (zero? (char->ascii c))
				    (string-set! s i (ascii->char 0))))
			      (char-set:s cset)))
	      csets))
  cset1)

(define (char-set-difference! cset1 . csets)
  (let ((s (char-set:s cset1)))
    (for-each (lambda (cset)
		(char-set-for-each (lambda (c)
					  (string-set! s (char->ascii c)
						       (ascii->char 0)))
				   cset))
	      csets))
  cset1)



;;;; System Character Sets
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define %char:newline (ascii->char 13))
(define %char:tab     (ascii->char  9))
(define %char:vtab    (ascii->char 11))
(define %char:page    (ascii->char 12))
(define %char:return  (ascii->char 10))
(define %char:space   (ascii->char 32))

(define char-set:lower-case (ascii-range->char-set #x61 #x7B))
(define char-set:upper-case (ascii-range->char-set #x41 #x5B))
(define char-set:alphabetic
  (char-set-union char-set:upper-case char-set:lower-case))
(define char-set:numeric (ascii-range->char-set #x30 #x3A))
(define char-set:alphanumeric
  (char-set-union char-set:alphabetic char-set:numeric))
(define char-set:graphic  (ascii-range->char-set #x21 #x7F))
(define char-set:printing (ascii-range->char-set #x20 #x7F))
(define char-set:whitespace (char-set %char:tab  %char:newline %char:vtab
				      %char:page %char:return  %char:space))
(define char-set:blank (char-set %char:space %char:tab))
(define char-set:control (char-set-union (ascii-range->char-set 0 32)
					 (char-set (ascii->char 127))))
(define char-set:punctuation
  (string->char-set "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
(define char-set:ascii (ascii-range->char-set 0 128))
(define char-set:empty (char-set))
(define char-set:full (char-set-invert char-set:empty))


(define (%char-set->pred cs) (lambda (c) (char-set-contains? cs c)))

(define char-lower-case?	(%char-set->pred char-set:lower-case))
(define char-upper-case?	(%char-set->pred char-set:upper-case))
(define char-alphabetic?	(%char-set->pred char-set:alphabetic))
(define char-numeric?		(%char-set->pred char-set:numeric))
(define char-alphanumeric?	(%char-set->pred char-set:alphanumeric))
(define char-graphic?		(%char-set->pred char-set:graphic))
(define char-printing?		(%char-set->pred char-set:printing))
(define char-whitespace?	(%char-set->pred char-set:whitespace))
(define char-blank?		(%char-set->pred char-set:blank))
(define char-control?		(%char-set->pred char-set:control))
(define char-punctuation?	(%char-set->pred char-set:punctuation))
(define char-hex-digit?		(%char-set->pred char-set:hex-digit))
(define char-ascii?		(%char-set->pred char-set:ascii))


;;; Copyright notice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
;;; 
;;; This material was developed by the Scheme project at the Massachusetts
;;; Institute of Technology, Department of Electrical Engineering and
;;; Computer Science.  Permission to copy and modify this software, to
;;; redistribute either the original software or a modified version, and
;;; to use this software for any purpose is granted, subject to the
;;; following restrictions and understandings.
;;; 
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;; 
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions that
;;; they make, so that these may be included in future releases; and (b)
;;; to inform MIT of noteworthy uses of this software.
;;; 
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the usual
;;; standards of acknowledging credit in academic research.
;;; 
;;; 4. MIT has made no warrantee or representation that the operation of
;;; this software will be error-free, and MIT is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Massachusetts Institute of
;;; Technology nor of any adaptation thereof in any advertising,
;;; promotional, or sales literature without prior written consent from
;;; MIT in each case.