*** empty log message ***

s48/intsets/AUTHORS

@@ -0,0 +1 @@
+Michel Schinz

s48/intsets/BLURB

@@ -0,0 +1 @@
+intsets: Sets of integers represented as sorted lists of intervals.

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.

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

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

s48/intsets/packages.scm

@@ -0,0 +1,5 @@
+(define-structure intsets intsets-interface
+  (open scheme
+        srfi-23                         ;error
+        srfi-1)                         ;list library
+  (files intsets))

scsh/base64/AUTHORS

@@ -0,0 +1 @@
+Michel Schinz

scsh/base64/BLURB

@@ -0,0 +1 @@
+base64: Base64 encoding/decoding functions.

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

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)))
+

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

scsh/base64/packages.scm

@@ -0,0 +1,6 @@
+(define-structure base64 base64-interface
+  (open scheme-with-scsh
+        let-opt
+        byte-vectors
+        bytio)
+  (files base64))