;;;;
;;;; srfi-14.stk        -- Implementation of SRFI-14
;;;;
;;;; Copyright © 2002-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file uses some work from the Olin Shivers implementation of
;;;; this SRFI. See the end of this file for the tedious details of the
;;;; original copyright
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 14-Jun-2002 21:36 (eg)
;;;;

;;;
;;; This implementation uses an integer set (srfi 217) to represent a
;;; character set.
;;;

(select-module (scheme charset))

(import (srfi 217))   ;; Integer sets

(export
   <char-set>
 
   ;; Predicates & comparison
   char-set? char-set= char-set<= char-set-hash

   ;; Iterating over character sets
   char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
   char-set-fold char-set-unfold char-set-unfold!
   char-set-for-each char-set-map

   ;; Creating character sets
   char-set-copy char-set

   list->char-set  string->char-set
   list->char-set! string->char-set!

   char-set-filter  ucs-range->char-set
   char-set-filter! ucs-range->char-set!
   ->char-set

   ;; Querying character sets
   char-set->list char-set->string
   char-set-size char-set-count char-set-contains?
   char-set-every char-set-any

   ;; Character-set algebra
   char-set-adjoin  char-set-delete
   char-set-adjoin! char-set-delete!

   char-set-complement  char-set-union  char-set-intersection
   char-set-complement! char-set-union! char-set-intersection!

   char-set-difference  char-set-xor  char-set-diff+intersection
   char-set-difference! char-set-xor! char-set-diff+intersection!

   ;; Standard character sets
   char-set:lower-case  char-set:upper-case  char-set:title-case
   char-set:letter      char-set:digit       char-set:letter+digit
   char-set:graphic     char-set:printing    char-set:whitespace
   char-set:iso-control char-set:punctuation char-set:symbol
   char-set:hex-digit   char-set:blank       char-set:ascii
   char-set:empty       char-set:full
 )


(%compile-time-define %valid-char-code?
                      %all-list %punctuations-list %symbols-list
                      %title-case-list %blanks-list)


(define-macro (%verify-char-set obj proc)
  `(unless (char-set? ,obj) (error ,proc "bad char-set ~S" ,obj)))

(define-macro (%verify-character obj proc)
  `(unless (char? ,obj) (error ,proc "bad character ~S" ',obj)))

(define-macro (%verify-char-sets lst proc)
  `(for-each (lambda(x) (%verify-char-set x ,proc)) ,lst))

(define-macro (%verify-proc obj proc)
  `(unless (procedure? ,obj) (error ,proc "bad procedure ~S" ',obj)))

(define-macro (%verify-char-set+proc obj1 obj2 proc)
  `(begin
     (%verify-char-set ,obj1 ,proc)
     (%verify-proc ,obj2 ,proc)))

(define (%char-set-add1 cs c)
  (if (%valid-char-code? c)
      (iset-adjoin cs c)
      cs))

(define (%empty-char-set)
  (%iset->char-set (iset)))


;;;; ======================================================================
;;;;
;;;;                    G E N E R A L   P R O C E D U R E S
;;;;
;;;; ======================================================================
(define char-set? (in-module (stklos itrie) %char-set?) )

(define (char-set= . rest)
  (%verify-char-sets rest 'char-set=)
  (apply iset=? rest))

(define (char-set<= . rest)
  (%verify-char-sets rest 'char-set<=)
  (apply iset<=? rest))

(define (char-set-hash cs :optional (bound 0))
  (%verify-char-set cs 'char-set-hash)
  (let ((h (hash-table-hash (iset->list cs))))
    (if (positive? bound)
        (modulo h bound)
        h)))

;;;; ======================================================================
;;;;
;;;;                            I T E R A T I O N
;;;;
;;;; ======================================================================
(define (%valid-cursor cursor proc)
  (unless cursor
    (error proc "end of char set"))
  (unless (and (integer? cursor) (>= cursor 0))
    (error proc "bad cursor ~S" cursor)))

(define (char-set-cursor cs)
  (%verify-char-set cs 'char-set-cursor)
  (and (not (iset-empty? cs)) (iset-min cs)))

(define (char-set-ref cset cursor)
  (%valid-cursor cursor 'char-set-cursor)
  (integer->char cursor))

(define (char-set-cursor-next cs cursor)
  (%valid-cursor cursor 'char-set-cursor-next)
  (let Loop ((i (+ cursor 1)))
    (cond
     ((> i (iset-max cs))   #f)
     ((iset-contains? cs i) i)
     (else                  (Loop (+ i 1))))))

(define (end-of-char-set? cursor)
  (not cursor))

(define (char-set-fold kons knil cs)
  (%verify-char-set+proc cs kons 'char-set-fold)
  (let ((max (iset-max cs)))
    (let Loop ((i (iset-min cs))
               (res knil))
      (if (> i max)
          res
          (Loop (+ i 1)
                (if (iset-contains? cs i)
                    (kons (integer->char i) res)
                    res))))))


(define (%char-set-unfold! proc p f g seed base-cs)
  (%verify-char-set base-cs proc)
  (%verify-proc p proc)
  (%verify-proc f proc)
  (%verify-proc g proc)
  (let Loop ((seed seed)
             (cs base-cs))
    (if (p seed)
        cs
        (Loop (g seed)
              (char-set-adjoin cs (f seed))))))


(define (char-set-unfold p f g seed :optional (base-set (%empty-char-set)))
  (%char-set-unfold! 'char-set-unfold p f g seed base-set))

(define (char-set-unfold! p f g seed base-set)
  (%char-set-unfold! 'char-set-unfold! p f g seed base-set))

(define (char-set-for-each proc cs)
   (%verify-char-set+proc cs proc 'char-set-for-each)
   (iset-for-each (lambda (x) (proc (integer->char x))) cs))

(define (char-set-map proc cs)
  (%verify-char-set+proc cs proc 'char-set-for-map)
  (%iset->char-set (iset-map (lambda (x) (char->integer (proc (integer->char x)))) cs)))

;;;; ======================================================================
;;;;
;;;;            C H A R A C T E R   S E T S   C R E A T I O N
;;;;
;;;; ======================================================================

(define (%char-set-filter! pred cs bs proc)
  (%verify-proc pred proc)  ;; FIXME: cs & bs
  (let ((max (iset-max cs)))
    (let Loop ((i (iset-min cs)))
      (if (> i max)
          bs
          (let ((char (integer->char i)))
            (when (and (iset-contains? cs i) (pred char))
              (set! bs (char-set-adjoin bs char)))
            (Loop (+ i 1)))))))


;;; Exported procedures
;;;
(define (char-set-copy cs)
  (%verify-char-set cs 'char-set-copy)
  (%iset->char-set (iset-copy cs)))
  
(define (char-set  . lst)
  (for-each (lambda (x) (%verify-character x 'char-set)) lst)
  (%iset->char-set (list->iset (map char->integer lst))))


(define (list->char-set lst :optional (base-set (%empty-char-set)))
  (%iset->char-set (apply iset-adjoin base-set (map char->integer lst))))

(define list->char-set! list->char-set)

(define (string->char-set str :optional (base-set #f base-set?))
  (if base-set?
      (list->char-set (string->list str) base-set)
      (list->char-set (string->list str))))

(define (string->char-set! str base-set)
  (list->char-set! (string->list str) base-set))

(define (char-set-filter predicate cs :optional (base-set (%empty-char-set)))
  (%char-set-filter! predicate cs base-set 'char-set-filter))

(define (char-set-filter! predicate cs base-set)
  (%char-set-filter! predicate cs base-set 'char-set-filter!))


(define (%ucs-range->char-set! lower upper error? base-set proc)
  (%verify-char-set base-set proc)
  (unless (and (integer? lower) (exact? lower) (>= lower 0))
    (error proc "bad lower bound" lower))
  (unless (and (integer? upper) (exact? upper) (> upper lower))
    (error proc "bad upper bound" lower))

  (let Loop ((i lower))
    (when (< i upper)
      (if (%valid-char-code? i)
          (set! base-set (%char-set-add1  base-set i))
          (when error?
            (error "character code ~s is invalid" i)))
      (Loop (+ i 1))))
  (%iset->char-set base-set))

(define (ucs-range->char-set! lower upper error? base-set)
  (%ucs-range->char-set! lower upper error? base-set 'ucs-range->char-set!))

(define (ucs-range->char-set lower upper
                             :optional (error? #f) (base-set #f base-set?))
  (let ((base-set (if base-set? base-set (%empty-char-set))))
    (%ucs-range->char-set! lower upper error? base-set 'ucs-range->char-set)))


(define (->char-set x)
  (cond
    ((char-set? x) x)
    ((string? x)   (string->char-set x))
    ((char? x)     (char-set x))
    (else          (error '->char-set "not a charset, string or char. ~S" x))))

;;;; ======================================================================
;;;;
;;;;            Q U E R Y I N G   C H A R A C T E R   S E T S
;;;;
;;;; ======================================================================
(define (char-set-size cs)
  (%verify-char-set cs 'char-set-size)
  (iset-size cs))


(define (char-set-count pred cs)
  (%verify-char-set+proc cs pred 'char-set-count)
  (let ((max (iset-max cs)))
    (let Loop ((i (iset-min cs))
               (count 0))
      (if (> i max)
          count
          (Loop (+ i 1)
                (if (and (iset-contains? cs i) (pred (integer->char i)))
                    (+ count 1)
                    count))))))

(define (char-set->list cs)
  (%verify-char-set cs 'char-set->list)
  (map integer->char (iset->list cs)))

(define (char-set->string cs)
  (%verify-char-set cs 'char-set->string)
  (list->string (char-set->list cs)))


(define (char-set-contains? cs char)
  (%verify-char-set cs 'char-set-contains?)
  (%verify-character char 'char-set-contains?)
  (iset-contains? cs (char->integer char)))

(define (char-set-every pred cs)
  (%verify-char-set+proc cs pred 'char-set-every)
  (let ((max (iset-max cs)))
    (let Loop ((i (iset-min cs)))
      (or (> i max)
          (and (or (not (iset-contains? cs i)) (pred (integer->char i)))
               (Loop (+ i 1)))))))

(define (char-set-any pred cs)
  (%verify-char-set+proc cs pred 'char-set-every)
  (let ((max (iset-max cs)))
    (let Loop ((i (iset-min cs)))
      (and (<= i max)
           (or (and (iset-contains? cs i) (pred (integer->char i)))
               (Loop (+ i 1)))))))


;;;; ======================================================================
;;;;
;;;;            C H A R A C T E R - S E T   A L G E B R A
;;;;
;;;; ======================================================================

(define (char-set-adjoin cs . chars)
  (%verify-char-set cs 'char-set-adjoin)
  (for-each (lambda (x)
              (%verify-character x 'char-set-adjoin)
              (set! cs (%char-set-add1 cs (char->integer x))))
            chars)
  (%iset->char-set cs))

(define (char-set-delete cs . chars)
  (%verify-char-set cs 'char-set-delete)
  (for-each (lambda (x)
              (%verify-character x 'char-set-delete)
              (set! cs (iset-delete cs (char->integer x))))
            chars)
  (%iset->char-set cs))


(define char-set-adjoin! char-set-adjoin)
(define char-set-delete! char-set-delete)

(define (char-set-complement cs)
  (%verify-char-set cs 'char-set-complement)
  (%iset->char-set (apply iset-delete
                          char-set:full
                          (map char->integer (char-set->list cs)))))

(define (char-set-union . lst)
  (for-each (lambda (x) (%verify-char-set x 'char-set-union)) lst)
  (%iset->char-set (apply iset-union lst)))


(define (char-set-intersection . lst)
  (%verify-char-sets lst 'char-set-intersection)
  (%iset->char-set (apply iset-intersection lst)))

(define (char-set-difference . lst)
  (%verify-char-sets lst 'char-set-difference)
  (%iset->char-set (apply iset-difference lst)))

(define (char-set-xor . lst)
  (%verify-char-sets lst 'char-set-xor)
  (%iset->char-set (apply iset-xor lst)))

(define (char-set-diff+intersection cs1 . cs)
  (values (apply char-set-difference cs1 cs)
          (char-set-intersection cs1 (apply char-set-union cs))))

(define char-set-complement!        char-set-complement)
(define char-set-union!             char-set-union)
(define char-set-intersection!      char-set-intersection)
(define char-set-difference!        char-set-difference)
(define char-set-xor!               char-set-xor)
(define char-set-diff+intersection! char-set-diff+intersection)

;;;; ======================================================================
;;;;
;;;;               S T A N D A R D   C H A R A C T E R   S E T S
;;;;
;;;; ======================================================================
(define char-set:empty (char-set))

(define char-set:full
  (if (%use-utf8?)
      (list->char-set (%all-list))
      ;; Not UTF-8: build the set [0 255]
      (let Loop ((lst '())
                 (i 255))
        (if (>= i 0)
            (Loop (cons (integer->char i) lst) (- i 1))
            (list->char-set lst)))))


(define char-set:lower-case
  (if (%use-utf8?)
      (list->char-set (%lowers-list))
      (let* ((a-z (ucs-range->char-set #x61 #x7B))
             (latin1 (ucs-range->char-set! #xdf #xf7  #t a-z))
             (latin2 (ucs-range->char-set! #xf8 #x100 #t latin1)))
        (char-set-adjoin latin2 (integer->char #xb5)))))

(define char-set:upper-case
  (if (%use-utf8?)
      (list->char-set (%uppers-list))
      (let ((A-Z (ucs-range->char-set #x41 #x5B)))
        ;; Add in the Latin-1 upper-case chars.
        (ucs-range->char-set! #xd8 #xdf #t
                              (ucs-range->char-set! #xc0 #xd7 #t A-Z)))))

(define char-set:title-case
  (if (%use-utf8?)
      (list->char-set (%title-case-list))
      char-set:empty))

(define char-set:letter
  (if (%use-utf8?)
      (list->char-set (%letters-list))
      (let ((u/l (char-set-union char-set:upper-case char-set:lower-case)))
        (char-set-adjoin u/l
                         (integer->char #xaa)      ; FEMININE ORDINAL INDICATOR
                         (integer->char #xba)))))  ; MASCULINE ORDINAL INDICATOR

(define char-set:digit
  (if (%use-utf8?)
      (list->char-set (%digits-list))
      (string->char-set "0123456789")))

(define char-set:letter+digit
  (char-set-union char-set:letter char-set:digit))

(define char-set:whitespace
  (list->char-set (map integer->char '(#x09 ; HORIZONTAL TABULATION
                                       #x0A ; LINE FEED
                                       #x0B ; VERTICAL TABULATION
                                       #x0C ; FORM FEED
                                       #x0D ; CARRIAGE RETURN
                                       #x20 ; SPACE
                                       #xA0))))

(define char-set:iso-control
  (ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32)))

(define char-set:punctuation
  (if (%use-utf8?)
      (list->char-set (%punctuations-list))
      (let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
            (latin-1-chars (map integer->char
                                '(#xA1 ; INVERTED EXCLAMATION MARK
                                  #xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
                                  #xAD ; SOFT HYPHEN
                                  #xB7 ; MIDDLE DOT
                                  #xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
                                  #xBF)))) ; INVERTED QUESTION MARK
        (list->char-set! latin-1-chars ascii))))

(define char-set:symbol
  (if (%use-utf8?)
      (list->char-set (%symbols-list))
      (let ((ascii (string->char-set "$+<=>^`|~"))
            (latin-1-chars (map integer->char '(#x00A2 ; CENT SIGN
                                                #x00A3 ; POUND SIGN
                                                #x00A4 ; CURRENCY SIGN
                                                #x00A5 ; YEN SIGN
                                                #x00A6 ; BROKEN BAR
                                                #x00A7 ; SECTION SIGN
                                                #x00A8 ; DIAERESIS
                                                #x00A9 ; COPYRIGHT SIGN
                                                #x00AC ; NOT SIGN
                                                #x00AE ; REGISTERED SIGN
                                                #x00AF ; MACRON
                                                #x00B0 ; DEGREE SIGN
                                                #x00B1 ; PLUS-MINUS SIGN
                                                #x00B4 ; ACUTE ACCENT
                                                #x00B6 ; PILCROW SIGN
                                                #x00B8 ; CEDILLA
                                                #x00D7 ; MULTIPLICATION SIGN
                                                #x00F7)))) ; DIVISION SIGN
        (list->char-set! latin-1-chars ascii))))

(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))

(define char-set:blank
  (if (%use-utf8?)
      (char-set-adjoin (list->char-set (%blanks-list))
                       #\tab)
      (list->char-set (map integer->char '(#x09     ; HORIZONTAL TABULATION
                                           #x20     ; SPACE
                                           #xA0))))); NO-BREAK SPACE

(define char-set:ascii (ucs-range->char-set 0 128))


(define char-set:graphic
  (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))

(define char-set:printing (char-set-union char-set:whitespace char-set:graphic))

;;;
;;; External reading of char-sets (SRFI 10)
;;;
(define-reader-ctor 'char-set char-set)


;;;
;;; OO support
;;;
(define-class <char-set> (<top>) ())

;; NOTE: this is a bit "hacky": isets had already defined their class as the
;; class <iset> with `%user-type-proc-set!`.
;; We are sure that this class is loaded before us, since it is imported. So,
;; now, we change the class-of to a function which can discriminate char-sets
;; and isets
(%user-type-proc-set! 'iset 'class-of (lambda (o)
                                        (if (char-set? o)
                                            <char-set>
                                            <iset>)))

;; Describe procedure.
;; Same thing, we overwrite the procedure associated to iset
(let ((iset-describe (%user-type-proc 'iset 'describe))) ;; get the old one
  (%user-type-proc-set! 'iset 'describe
                        (lambda (x port)
                          (if (char-set? x)
                              ;; char-set
                              (let ((sz (iset-size x)))
                                (format port "a char-set, with ~a element~a"
                                        sz
                                        (if (> sz 1) "s" "")))
                              ;; iset
                              (iset-describe x port))
                          (void))))


(provide "scheme/charset")

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






#|
For tests
(define cs1 (make-char-set #\a #\b #\d))
(define cs2 (make-char-set #\a #\b #\d #\e))
(define cs3 (make-char-set #\a #\b))
(define cs4 (make-char-set #\x #\y))
(define cs5 (string->char-set
             "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define cs6 (make-char-set #\A #\B #\space))

(char-set->list (char-set-filter! char-upper-case? cs5 cs2))
|#
