scsh-0.6/scsh/char-set.scm

198 lines
6.7 KiB
Scheme
Raw Normal View History

;;; -*-Scheme-*-
;;;
;;; Character Sets package
;;; ported from MIT Scheme runtime
;;; by Brian D. Carlstrom
;;; Sleazy code.
(define char:newline (ascii->char 13))
(define char:tab (ascii->char 9))
(define char:linefeed (ascii->char 13))
(define char:page (ascii->char 12))
(define char:return (ascii->char 10))
(define char:space (ascii->char 32))
(define (string-fill-range! str lower upper ch)
(do ((index lower (+ index 1)))
((>= index upper) str)
(string-set! str index ch)))
(define (char-ascii? char)
(let ((maybe-ascii (char->ascii char)))
(and (<= 0 maybe-ascii 127) maybe-ascii)))
;;;; Character Sets
(define (char-set? object)
(and (string? object)
(= (string-length object) 256)))
(define (char-set . chars)
(chars->char-set chars))
(define (chars->char-set chars)
(let ((char-set (make-string 256 (ascii->char 0))))
(for-each (lambda (char)
(string-set! char-set (char->ascii char) (ascii->char 1)))
chars)
char-set))
(define (string->char-set str)
(let ((char-set (make-string 256 (ascii->char 0))))
(do ((i (- (string-length str) 1) (- i 1)))
((< i 0) char-set)
(string-set! char-set (char->ascii (string-ref str i))
(ascii->char 1)))))
(define (ascii-range->char-set lower upper)
(let ((char-set (make-string 256 (ascii->char 0))))
(string-fill-range! char-set lower upper (ascii->char 1))
char-set))
(define (predicate->char-set predicate)
(let ((char-set (make-string 256)))
(let loop ((code 0))
(if (< code 256)
(begin (string-set! char-set code
(if (predicate (ascii->char code))
(ascii->char 1)
(ascii->char 0)))
(loop (+ 1 code)))))
char-set))
;;; {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 char-set)
(define (loop code)
(cond ((>= code 256) '())
((zero? (char->ascii (string-ref char-set code))) (loop (+ 1 code)))
(else (cons (ascii->char code) (loop (+ 1 code))))))
(loop 0))
;;; 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? char-set char)
(not (zero? (char->ascii (string-ref char-set (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."))
(define (char-set-invert char-set)
(predicate->char-set
(lambda (char) (not (char-set-contains? char-set char)))))
(define (char-set-union char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(or (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
(define (char-set-intersection char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
(define (char-set-difference char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(not (char-set-contains? char-set-2 char))))))
;;;; System Character Sets
(define char-set:upper-case (ascii-range->char-set #x41 #x5B))
(define char-set:lower-case (ascii-range->char-set #x61 #x7B))
(define char-set:numeric (ascii-range->char-set #x30 #x3A))
(define char-set:graphic (ascii-range->char-set #x20 #x7F))
(define char-set:not-graphic (char-set-invert char-set:graphic))
(define char-set:whitespace
(char-set char:newline char:tab char:linefeed
char:page char:return char:space))
(define char-set:not-whitespace (char-set-invert char-set:whitespace))
(define char-set:alphabetic
(char-set-union char-set:upper-case char-set:lower-case))
(define char-set:alphanumeric
(char-set-union char-set:alphabetic char-set:numeric))
(define char-set:standard
(char-set-union char-set:graphic (char-set char:newline)))
(define (char-upper-case? char)
(char-set-contains? char-set:upper-case char))
(define (char-lower-case? char)
(char-set-contains? char-set:lower-case char))
(define (char-numeric? char)
(char-set-contains? char-set:numeric char))
(define (char-graphic? char)
(char-set-contains? char-set:graphic char))
(define (char-whitespace? char)
(char-set-contains? char-set:whitespace char))
(define (char-alphabetic? char)
(char-set-contains? char-set:alphabetic char))
(define (char-alphanumeric? char)
(char-set-contains? char-set:alphanumeric char))
(define (char-standard? char)
(char-set-contains? char-set:standard char))
;;; Bullshit legalese
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;$Header: /home/flat/Dropbox/Hacks/scsh/scsh-cvs/scsh/scsh/Attic/char-set.scm,v 1.1 1999/09/14 13:32:00 marting Exp $
;Copyright (c) 1988 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 this software, to redistribute
;it, and to use it 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.