diff --git a/s48/intsets/AUTHORS b/s48/intsets/AUTHORS new file mode 100644 index 0000000..100171c --- /dev/null +++ b/s48/intsets/AUTHORS @@ -0,0 +1 @@ +Michel Schinz diff --git a/s48/intsets/BLURB b/s48/intsets/BLURB new file mode 100644 index 0000000..c01f015 --- /dev/null +++ b/s48/intsets/BLURB @@ -0,0 +1 @@ +intsets: Sets of integers represented as sorted lists of intervals. diff --git a/s48/intsets/README b/s48/intsets/README new file mode 100644 index 0000000..d39d36c --- /dev/null +++ b/s48/intsets/README @@ -0,0 +1,87 @@ +Integer sets represented as lists of intervals + +1. Introduction + +This module provides functions to work with sets of integers +represented as sorted lists of intervals, which are pairs of bounds. +For example, the set + + { 1, 2, 3, 4, 10, 11, 12, 80 } + +is represented by the list + + ((1 . 4) (10 . 12) (80 . 80)) + +The functions provided here always ensure that the lists are valid and +in canonical form. + +A list is valid if each of its intervals is valid. An interval is +valid if its upper bound is greater or equal to its lower bound. + +A list is in canonical form if: + + * all its intervals are strictly disjoint, that is they neither + overlap nor touch, and + + * its intervals are sorted by increasing bounds. + +2. Functions + +Apart from the functions presented here, all functions working on +lists can be used, since the representation of integer sets is exposed +for that purpose. + +2.1. Constructors + +(intset-singleton element) -> integer-set + +Return an integer set containing only the given ELEMENT. + +(intset-range begin end) -> integer-set + +Return an integer set composed of the integers in the range +[BEGIN,END] (i.e. both BEGIN and END are included). + +2.2. Predicates + +(intset? thing) -> boolean + +Return true iff the given THING is a valid list of intervals in +canonical form, as defined above. + +(intset-contains? element set) -> boolean + +Return true iff SET contains ELEMENT. + +2.3. Set operations + +(intset-union set-1 set-2) -> integer-set + +Return the union of the integer sets SET-1 and SET-2. + +(intset-intersection set-1 set-2) -> integer-set + +Return the intersection of the integer sets SET-1 and SET-2. + +(intset-difference set-1 set-2) -> integer-set + +Return the difference of the integer sets SET-1 and SET-2, that is +SET-1 \ SET-2. + +(intset-adjoin element set) -> integer-set + +Return a set containing the same elements as SET plus ELEMENT. Note: +the "lset-adjoin" function in SRFI-1 takes the set as first argument +and the element(s) as rest arguments. Since this argument ordering is +not coherent with the other functions, I decided not to copy it. + +(intset-delete element set) -> integer-set + +Return a set containing the same elements as SET but ELEMENT. + +2.4. Iterators + +(intset-map f set) -> list + +Apply function F to the lower and upper bounds of all intervals in +SET, and return the list of all of F results. diff --git a/s48/intsets/interfaces.scm b/s48/intsets/interfaces.scm new file mode 100644 index 0000000..5aeef50 --- /dev/null +++ b/s48/intsets/interfaces.scm @@ -0,0 +1,11 @@ +(define-interface intsets-interface + (export intset? + intset-union + intset-intersection + intset-difference + intset-range + intset-singleton + intset-adjoin + intset-delete + intset-contains? + intset-map)) diff --git a/s48/intsets/intsets.scm b/s48/intsets/intsets.scm new file mode 100644 index 0000000..efdfcd2 --- /dev/null +++ b/s48/intsets/intsets.scm @@ -0,0 +1,175 @@ +;;; Functions to manipulate integer sets represented as lists of +;;; intervals. +;;; +;;; Sets are represented as lists of intervals, which are pairs (lower +;;; bound, upper bound), where both bounds are included. The lower +;;; bound must be an integer, the upper bound can either be an integer +;;; or the symbol 'max' to specify the maximum possible value of all +;;; intervals for the problem at hand. The specific value of this +;;; maximum is not known. +;;; +;;; The following implementation guarantees that sets are always in +;;; canonical form, that is their intervals are: +;;; - sorted in increasing order, +;;; - disjoint, and +;;; - non-contiguous (i.e. they do not touch each other). +;;; +;;; External dependencies: SRFI-1 (list library) and SRFI-23 (error). + +(define (pairwise f l) + (or (< (length l) 2) + (and (f (first l) (second l)) (pairwise f (cdr l))))) + +;;; Functions on bounds. + +(define (b-max? bound) (eq? bound 'max)) + +(define (b< b1 b2) + (and (not (b-max? b1)) (or (b-max? b2) (< b1 b2)))) + +(define (b<= b1 b2) + (or (eq? b1 b2) (b< b1 b2))) + +(define (bs<= . bounds) + (pairwise b<= bounds)) + +(define (b-pred bound) + (if (b-max? bound) (error "no predecessor to 'max'") (- bound 1))) + +(define (b-succ bound) + (if (b-max? bound) (error "no successor to 'max'") (+ bound 1))) + +;; Saturating successor. +(define (b-sat-succ bound) + (if (b-max? bound) bound (+ bound 1))) + +(define (b-min b1 b2) + (cond ((b-max? b1) b2) + ((b-max? b2) b1) + (else (min b1 b2)))) + +(define (b-max b1 b2) + (cond ((b-max? b1) b1) + ((b-max? b2) b2) + (else (max b1 b2)))) + +;;; Functions on individual intervals (pairs of bounds). + +(define i-make cons) +(define i-beg car) +(define i-end cdr) + +;; Beware: the following syntax leads to multiple evaluations of each +;; interval expression! +(define-syntax let-int + (syntax-rules () + ((let-int ((beg-1 end-1 int-1) rest ...) body ...) + (let ((beg-1 (i-beg int-1)) (end-1 (i-end int-1))) + (let-int (rest ...) body ...))) + ((let-int () body ...) + (begin body ...)))) + +(define (i-intersect? i1 i2) + (let-int ((b1 e1 i1) (b2 e2 i2)) + (or (bs<= b1 b2 e1) (bs<= b2 b1 e2)))) + +(define (i-contiguous? i1 i2) + (let-int ((b1 e1 i1) (b2 e2 i2)) + (or (bs<= b1 b2 (b-sat-succ e1)) (bs<= b2 b1 (b-sat-succ e2))))) + +;; Defined only for contiguous intervals. +(define (i-union i1 i2) + (let-int ((b1 e1 i1) (b2 e2 i2)) + (i-make (b-min b1 b2) (b-max e1 e2)))) + +(define (i-start-before? i1 i2) + (b< (i-beg i1) (i-beg i2))) + +(define (i-end-before? i1 i2) + (b< (i-end i1) (i-end i2))) + +;; Defined only for disjoint intervals. +(define i< i-start-before?) + +(define (i-intersection i1 i2) + (if (i-intersect? i1 i2) + (list (let-int ((b1 e1 i1) (b2 e2 i2)) + (i-make (b-max b1 b2) (b-min e1 e2)))) + '())) + +(define (i-difference i1 i2) + (if (i-intersect? i1 i2) + (let-int ((b1 e1 i1) (b2 e2 i2)) + (let ((il (if (b< b1 b2) (list (i-make b1 (b-pred b2))) '())) + (ir (if (b< e2 e1) (list (i-make (b-succ e2) e1)) '()))) + (append il ir))) + (list i1))) + +;;; Functions on sets (lists of individual intervals). + +(define (intset? thing) + ;; TODO check that intervals are disjoint and increasing + (and (list? thing) + (every (lambda (pair) + (and (pair? pair) + (number? (car pair)) + (or (number? (cdr pair)) (b-max? (cdr pair))) + (b< (car pair) (cdr pair)))) + thing))) + +(define (intset-union s1 s2) + (cond ((null? s1) s2) + ((null? s2) s1) + (else + (let ((h1 (car s1)) (t1 (cdr s1)) + (h2 (car s2)) (t2 (cdr s2))) + (cond ((i-contiguous? h1 h2) + (if (i-end-before? h1 h2) + (intset-union t1 (cons (i-union h1 h2) t2)) + (intset-union (cons (i-union h1 h2) t1) t2))) + ((i< h1 h2) + (cons h1 (intset-union t1 s2))) + (else ;(i< h2 h1) + (cons h2 (intset-union s1 t2)))))))) + +(define (intset-intersection s1 s2) + (if (or (null? s1) (null? s2)) + '() + (let ((h1 (car s1)) (t1 (cdr s1)) + (h2 (car s2)) (t2 (cdr s2))) + (if (i-end-before? h1 h2) + (append (i-intersection h1 h2) (intset-intersection t1 s2)) + (append (i-intersection h1 h2) (intset-intersection s1 t2)))))) + +(define (intset-difference s1 s2) + (if (or (null? s1) (null? s2)) + s1 + (let ((h1 (car s1)) (t1 (cdr s1)) + (h2 (car s2)) (t2 (cdr s2))) + (cond ((i-intersect? h1 h2) + (intset-difference (append (i-difference h1 h2) t1) s2)) + ((i< h1 h2) + (cons h1 (intset-difference t1 s2))) + (else + (intset-difference s1 t2)))))) + +(define (intset-range begin end) + `((,begin . ,end))) + +(define (intset-singleton elem) + (intset-range elem elem)) + +(define (intset-adjoin elem set) + (intset-union set (intset-singleton elem))) + +(define (intset-delete elem set) + (intset-difference set (intset-singleton elem))) + +(define (intset-contains? elem set) + (any (lambda (i) (bs<= (i-beg i) elem (i-end i))) set)) + +(define (intset-map f set) + (if (null? set) + '() + (let ((fst (car set))) + (cons (f (car fst) (cdr fst)) (intset-map f (cdr set)))))) diff --git a/s48/intsets/packages.scm b/s48/intsets/packages.scm new file mode 100644 index 0000000..b827d09 --- /dev/null +++ b/s48/intsets/packages.scm @@ -0,0 +1,5 @@ +(define-structure intsets intsets-interface + (open scheme + srfi-23 ;error + srfi-1) ;list library + (files intsets)) diff --git a/scsh/base64/AUTHORS b/scsh/base64/AUTHORS new file mode 100644 index 0000000..100171c --- /dev/null +++ b/scsh/base64/AUTHORS @@ -0,0 +1 @@ +Michel Schinz diff --git a/scsh/base64/BLURB b/scsh/base64/BLURB new file mode 100644 index 0000000..1658f6a --- /dev/null +++ b/scsh/base64/BLURB @@ -0,0 +1 @@ +base64: Base64 encoding/decoding functions. diff --git a/scsh/base64/README b/scsh/base64/README new file mode 100644 index 0000000..1650780 --- /dev/null +++ b/scsh/base64/README @@ -0,0 +1,40 @@ +Base64 encoding and decoding functions + +1. Introduction + +This module implements Base64 encoding and decoding as specified by +section 6.8 of RFC 2045. + +2. Functions + +2.1. Encoding + +(base64-encode-vector byte-vector [output-port]) -> port/string + +Encode the given BYTE-VECTOR, put the result on the OUTPUT-PORT, and +return it. If no OUTPUT-PORT is given, encoding is done in a string, +which is returned. + +(base64-encode-port input-port [output-port]) -> port/string + +Encode the contents of the INPUT-PORT and put the result on the +OUTPUT-PORT. If no OUTPUT-PORT is given, encoding is done in a string, +which is returned. + +2.2. Decoding + +(base64-decode-string string [output-port]) -> port/string + +Decode the contents of the STRING, and put the result on the +OUTPUT-PORT. If no OUTPUT-PORT is given, decoding is done in a string, +which is returned. + +(base64-decode-port input-port [output-port]) -> port/string + +Decode the contents of the INPUT-PORT, and put the result on the +OUTPUT-PORT. If no OUTPUT-PORT is given, decoding is done in a string, +which is returned. + +3. References + +RFC 2045 http://www.faqs.org/rfcs/rfc2045.html diff --git a/scsh/base64/base64.scm b/scsh/base64/base64.scm new file mode 100644 index 0000000..72150b1 --- /dev/null +++ b/scsh/base64/base64.scm @@ -0,0 +1,142 @@ +;; This module implements Base64 encoding and decoding as specified by +;; section 6.8 of RFC 2045. + +(define ash arithmetic-shift) + +(define-syntax when + (syntax-rules () + ((when cond body1 body2 ...) + (if cond (begin body1 body2 ...))))) + +(define-syntax unless + (syntax-rules () + ((unless cond body1 body2 ...) + (if (not cond) (begin body1 body2 ...))))) + +;; Return a procedure to write a character to port, and produce a new +;; line after a multiple of line-len characters have been output. +(define (char-writer port line-len) + (let ((col 0)) + (lambda (char) + (write-char char port) + (set! col (+ col 1)) + (when (>= col line-len) + (newline port) + (set! col 0))))) + +;; Take the first n bits of x. +(define (bits-take x n) + (bitwise-and x (- (ash 1 n) 1))) + +;; Drop the first n bits of x. +(define (bits-drop x n) + (ash x (- n))) + +;; The padding character +(define pad #\=) + +(define eof-object (read (make-string-input-port ""))) + +;;; Encoding +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define encoding-vector + '#(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P + #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f + #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v + #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/)) + +;; (base64-encode-vector vector [out-port]) +;; --> string or port +(define (base64-encode-vector vector . rest) + (let ((len (byte-vector-length vector)) (pos 0)) + (apply base64-encode-internal + (lambda () + (if (< pos len) + (let ((byte (byte-vector-ref vector pos))) + (set! pos (+ pos 1)) + byte) + eof-object)) + rest))) + +;; (base64-encode-port port [out-port]) +;; --> string or port +(define (base64-encode-port in-port . rest) + (apply base64-encode-internal (lambda () (read-byte in-port)) rest)) + +(define (base64-encode-internal fetch-byte . rest) + (let-optionals rest ((out-port (make-string-output-port))) + (let ((output-char (char-writer out-port 76))) + (let loop ((next-byte (fetch-byte)) (bits 0) (bits-count 0) (len 0)) + (cond ((>= bits-count 6) + ;; Enough bits to output a character: do so, iterate. + (let* ((carry-bits-count (- bits-count 6)) + (next-6bits (bits-drop bits carry-bits-count))) + (output-char (vector-ref encoding-vector next-6bits)) + (loop next-byte + (bits-take bits carry-bits-count) + carry-bits-count + len))) + ((not (eof-object? next-byte)) + ;; Need more bits: use next byte. + (loop (fetch-byte) + (bitwise-ior (ash bits 8) next-byte) + (+ bits-count 8) + (+ len 1))) + (else + ;; No data left: output remaining bits, if any, and padding. + (unless (zero? bits-count) + (output-char (vector-ref encoding-vector + (ash bits (- 6 bits-count))))) + (case (remainder len 3) + ((1) (output-char pad) (output-char pad)) + ((2) (output-char pad))))))) + ;; Return port/output string. + (if (null? rest) (string-output-port-output out-port) out-port))) + +;;; Decoding +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define decoding-vector + (let ((dec (make-vector 128 #f))) + (do ((enc (vector->list encoding-vector) (cdr enc)) + (i 0 (+ i 1))) + ((null? enc) dec) + (vector-set! dec (char->ascii (car enc)) i)))) + +(define (base64-decode-string str . rest) + (apply base64-decode-port (make-string-input-port str) rest)) + +;; (base64-decode in-port [out-port]) +;; --> string or port +(define (base64-decode-port in-port . rest) + (let-optionals rest ((out-port (make-string-output-port))) + (let loop ((bits 0) (bits-count 0)) + (let ((next-char (read-char in-port))) + (when (not (or (eof-object? next-char) (char=? next-char pad))) + (let ((next-6bits (vector-ref decoding-vector + (char->ascii next-char)))) + (if (not next-6bits) + ;; Non-encoding character, skip it. + (loop bits bits-count) + ;; Encoding character, handle it. + (let ((full-bits (bitwise-ior (ash bits 6) next-6bits)) + (full-bits-count (+ bits-count 6))) + (if (>= full-bits-count 8) + ;; Complete byte: output it, iterate. + (let* ((carry-bits-count (- full-bits-count 8)) + (byte (bits-drop full-bits carry-bits-count))) + (write-byte byte out-port) + (loop (bits-take full-bits carry-bits-count) + carry-bits-count)) + ;; No complete byte yet: iterate. + (loop full-bits full-bits-count)))))))) + ;; Return port/output string. + (if (null? rest) (string-output-port-output out-port) out-port))) + +;;; Tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; (define (test) +; (let ((empty (byte-vector))) + diff --git a/scsh/base64/interfaces.scm b/scsh/base64/interfaces.scm new file mode 100644 index 0000000..09a65fb --- /dev/null +++ b/scsh/base64/interfaces.scm @@ -0,0 +1,5 @@ +(define-interface base64-interface + (export base64-encode-vector + base64-encode-port + base64-decode-string + base64-decode-port)) diff --git a/scsh/base64/packages.scm b/scsh/base64/packages.scm new file mode 100644 index 0000000..e4c4fe1 --- /dev/null +++ b/scsh/base64/packages.scm @@ -0,0 +1,6 @@ +(define-structure base64 base64-interface + (open scheme-with-scsh + let-opt + byte-vectors + bytio) + (files base64))