Revision 01 October 29, 1997 This software is copyrighted by its respective authors. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. This collection of DSSSL procedures was collected from postings to the DSSSList, the DSSSL Users' Mailing List, and from people's direct contributions. Thanks go to the following people for contributing procedures: Vivek Agrawala Tony Graham G. Ken Holman Dave Love Chris Maden Norman Walsh and to the following people for contributing markup: Vivek Agrawala Tony Graham NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022. Replaces version submitted by Dave Love. (assoc obj alist) Returns the pair from the alist associative list that has obj as its car, otherwise returns #f if no such pair exists. (define (assoc obj alist) ;; Given an associative list, returns the pair that has obj as a car ;; or #f if no such pair exists ;; (("a" "b") ("c" "d")), "a" => ("a" "b") (let loop ((al alist)) (if (null? al) #f (if (equal? obj (car (car al))) (car al) (loop (cdr al)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (caddr xs) Returns the car of the cdr of the cdr of xs. (define (caddr xs) (list-ref xs 2)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (cadr xs) Returns the car of the cdr of xs. (define (cadr xs) (list-ref xs 1)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (cddr xs) Returns the cdr of the cdr of xs. (define (cddr xs) (cdr (cdr xs))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (even? n) Returns #t if n is even, #f otherwise. (define (even? n) (zero? (remainder n 2))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (expt b n) Returns b raised to the n power. (define (expt b n) ; safe for -ve n, c.f. Bosak (letrec ((expt1 (lambda (n) (if (zero? n) 1 (* b (expt1 (- n 1))))))) (if (< n 1) (/ (expt1 (- n))) (expt1 n)))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (list->string cs) Returns a string of the characters in cs. (define (list->string cs) (apply string cs)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (map f xs) Returns a list of results from applying procedure f to corresponding elements of the lists making up the remainder of the arguments to the map procedure. The lists must be of the same length, and f must accept as many arguments as there are lists. (define (map f #!rest xs) (let ((map1 (lambda (f xs) ; bootstrap version for unary F (let loop ((xs xs)) (if (null? xs) '() (cons (f (car xs)) (loop (cdr xs)))))))) (cond ((null? xs) '()) ((null? (cdr xs)) (map1 f (car xs))) (else (let loop ((xs xs)) (if (null? (car xs)) '() (cons (apply f (map1 car xs)) (loop (map1 cdr xs))))))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (odd? n) Returns #t if n is odd, #f otherwise. (define (odd? n) (not (even? n))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (string->list s) Returns a list of the characters in s. (define (string->list s) (let ((l (string-length s))) (let loop ((i 0)) (if (= i l) '() (cons (string-ref s i) (loop (+ i 1))))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (zero? n) Returns #t if n is zero, #f otherwise. (define (zero? n) (equal? 0 n)) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (ifollow nl) Returns the node immediately following the nl node list. (define (ifollow nl) (node-list-map (lambda (snl) (let loop ((rest (siblings snl))) (cond ((node-list-empty? rest) (empty-node-list)) ((node-list=? (node-list-first rest) snl) (node-list-first (node-list-rest rest))) (else (loop (node-list-rest rest)))))) nl)) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (ipreced nl) Returns the node immediately preceding the nl node list. (define (ipreced nl) (node-list-map (lambda (snl) (let loop ((prev (empty-node-list)) (rest (siblings snl))) (cond ((node-list-empty? rest) (empty-node-list)) ((node-list=? (node-list-first rest) snl) prev) (else (loop (node-list-first rest) (node-list-rest rest)))))) nl)) WilliamLindsay 1.0 19970728 (ipreced nl) Returns the preceding sibling element or empty node list if this is the first child. (define (ipreced nl) (node-list-map (lambda (snl) (let loop ((prev (empty-node-list)) (rest (siblings snl))) (cond ((node-list-empty? rest) (empty-node-list)) ((node-list=? (node-list-first rest) snl) prev) (else (loop (node-list-first rest) (node-list-rest rest)))))) nl)) ChrisMaden 1.0 19971021 Chris Maden crism@ora.com Copied from author's DSSSList post of 19971017 (node-list-filter proc nl) This procedure is defined in the DSSSL standard. Returns a node-list containing just those members of nl for which proc applied to a singleton node-list containing just that member does not return #f. The DSSSL standard (ISO/IEC 10179) implementation of node-list-filter reverses the order of the nodes passed to it. This altered version keeps the nodes in order. ;; (node-list-filter) from ISO/IEC 10179 with small change to avoid ;; reversing the order of nodes (define (node-list-filter proc nl) (node-list-reduce nl (lambda (result snl) (if (proc snl) (node-list result snl) result)) (empty-node-list))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (node-list-last nl) Returns the last node in the nl node list. (define (node-list-last nl) (node-list-ref nl (- (node-list-length nl) 1))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (node-list-length nl) Returns the number of nodes in the nl node list. (define (node-list-length nl) (node-list-reduce nl (lambda (result snl) (+ result 1)) 0)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (node-list-reduce nl combine init) If the node-list nl is empty, returns init. If not, returns the result of applying node-list-reduce to: a node-list containing all but the first member of nl combine, and the result of applying combine to init and the first member of nl. (define (node-list-reduce nl combine init) (if (node-list-empty? nl) init (node-list-reduce (node-list-rest nl) combine (combine init (node-list-first nl))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (node-list-reduce nl proc init) (define (node-list-reduce nl proc init) (if (node-list-empty? nl) init (node-list-reduce (node-list-rest nl) proc (proc init (node-list-first nl))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (node-list-some? proc nl) Returns the node-list comprising the elements of node-list nl for which procedure proc returns #t. (define (node-list-some? proc nl) (node-list-reduce nl (lambda (result snl) (if (or result (proc snl)) #t #f)) #f)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (any? pred? xs) Returns #t if predicate pred? returns true when applied to any element of the list xs. ;; Return #t if predicate `pred?' returns #t when applied to any ;; element of the `xs'. (define (any? pred? xs) (let loop ((xs xs)) (and (not (null? xs)) (or (pred? (car xs)) (loop (cdr xs)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (assoc-objs alist) Returns a list of the objects in alist as an associative list. (define (assoc-objs alist) ;; Returns a list of the objects in an associative list. ;; (("a" "b") ("c" "d")) => ("a" "c") (let loop ((result '()) (al alist)) (if (null? al) result (loop (append result (list (car (car al)))) (cdr al))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (break test? xs) Returns ;; Like `span', but with the sense of the test reversed. (define (break test? xs) (span (compose not test?) xs)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (drop x xs) Returns the list xs less the first n elements. ;; Return list `xs' less the first `n' elements. (define (drop n xs) (list-tail xs n)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (dropwhile test? xs) Remove leading elements of list xs for which test? returns true. ;; Remove leading elements of list `xs' for which `test?' returns ;; true. (define (dropwhile test? xs) (cond ((null? xs) '()) ((test? (car xs)) (dropwhile test? (cdr xs))) (else xs))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (list-member-find element element-list) Returns the offset within element-list of element, or -1 if element is not a member of element-list. The offset of the first element in element-list is 0. Occurence of element is tested with equal?, so the elements may be objects of any time for which equal? will work. (define (list-member-find element element-list) ;; Finds element in element-list and returns the index of its location. ;; The first element in a list has index 0. (let loop ((elemlist element-list) (count 0)) (if (null? elemlist) -1 (if (equal? element (car elemlist)) count (loop (cdr elemlist) (+ count 1)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (list-member-get element-list count) Returns the element at offset count within element-list, or #f if element-list does not contain count elements. (define (list-member-get element-list count) ;; Returns the count'th element from element-list. ;; The first element in a list has index 0. (let loop ((elemlist element-list) (idx count)) (if (null? elemlist) #f (if (= idx 0) (car elemlist) (loop (cdr elemlist) (- idx 1)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (remove x ys) Returns list ys without any elements equalling x. ;; Remove any occurrences of `x' from list `ys'. (define (remove x ys) (cond ((null? ys) ys) ((equal? x (car ys)) (remove x (cdr ys))) (else (cons (car ys) (remove x (cdr ys)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (remove-if pred? ys) Returns list ys without any elements for which predicate pred? returns #t. ;; Remove any elements `x' from that answer #t to `pred?'. (define (remove-if pred? ys) (cond ((null? ys) ys) ((pred? (car ys)) (remove-if pred? (cdr ys))) (else (cons (car ys) (remove-if pred? (cdr ys)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (sort <= l) Returns list l sorted using comparison function <=. ;; O'Keefe's smooth applicative merge sort: sort list `l' using ;; comparison function `<='. (define (sort <= l) (letrec ((merge (lambda (xs ys) (cond ((null? xs) ys) ((null? ys) xs) (else (if (<= (car xs) (car ys)) (cons (car xs) (merge (cdr xs) ys)) (cons (car ys) (merge xs (cdr ys)))))))) (mergepairs (lambda (l k) (if (null? (cdr l)) l (if (= 1 (modulo k 2)) l (mergepairs (cons (merge (car l) (cadr l)) (cddr l)) (quotient k 2)))))) (sorting (lambda (l a k) (if (null? l) (car (mergepairs a 0)) (sorting (cdr l) (mergepairs (cons (list (car l)) a) (+ k 1)) (+ k 1)))))) (cond ((not (list? l)) (error "sort: second arg not a list")) ((not (procedure? <=)) (error "sort: first arg not a procedure")) ((null? l) '()) (else (sorting l '() 0))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (span test? xs) Returns a pair of lists, one is the leading elements of the list xs for which test? returns #t, and the other is the rest of the elements of xs. ;; From the list `xs', return a pair of lists comprising the leading ;; elements of `xs' for which `test?' returns true and the rest of ;; `xs'. After the Haskell prelude. (define (span test? xs) (if (null? xs) (cons '() '()) (let ((x (car xs)) ; split the xs into head (xss (cdr xs))) ; and tail (if (test? x) (let* ((spanned (span test? xss)) ;; and split the result of span into head and tail (ys (car spanned)) (zs (cdr spanned))) (cons (cons x ys) zs)) (cons '() xs))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (take n xs) Returns the first n elements of list xs. (define (take n xs) (let loop ((i 1) (xs xs)) (if (or (> i n) (null? xs)) '() (cons (car xs) (loop (+ 1 i) (cdr xs)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 ;; List zipping with the given `zipper' function. Like `map', but the ;; list args can be unequal lengths. (define (zip-with zipper #!rest xs) (if (any? null? xs) '() (cons (apply zipper (map car xs) ) (apply zip-with zipper (map cdr xs))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-down-char ch) Returns the lowercase form of ch if ch is a member of the uppercase-list list, otherwise returns ch. (define (case-fold-down-char ch) ;; Returns the lowercase form of ch or ch if ch is not an uppercase form (let ((idx (list-member-find ch uppercase-list))) (if (> idx 0) (list-member-get lowercase-list idx) ch))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-down-charlist charlist) Returns charlist with all uppercase characters converted to lowercase. (define (case-fold-down-charlist charlist) ;; Shifts all characters in charlist to lowercase (if (null? charlist) '() (cons (case-fold-down-char (car charlist)) (case-fold-down-charlist (cdr charlist))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-up-char ch) Returns the uppercase form of ch if ch is a member of the lowercase-list list, otherwise returns ch. (define (case-fold-up-char ch) ;; Returns the uppercase form of ch or ch if ch is not a lowercase form (let ((idx (list-member-find ch lowercase-list))) (if (> idx 0) (list-member-get uppercase-list idx) ch))) (define uppercase-list '(#\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)) (define lowercase-list '(#\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)) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-up-charlist charlist) Returns charlist with all lowercase characters converted to uppercase. (define (case-fold-up-charlist charlist) ;; Shifts all characters in charlist to uppercase (if (null? charlist) '() (cons (case-fold-up-char (car charlist)) (case-fold-up-charlist (cdr charlist))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-down str) Returns str with all uppercase characters converted to lowercase. (define (case-fold-down str) ;; Returns str shifted to lowercase (apply string (case-fold-down-charlist (string-to-list str)))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (case-fold-up str) Returns str with all lowercase characters converted to uppercase. (define (case-fold-up str) ;; Returns str shifted to uppercase (apply string (case-fold-up-charlist (string-to-list str)))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (copy-string string num) Returns the string that is the concatenation of num occurrences of string. (define (copy-string string num) ;; Return string copied num times ;; (copy-string "x" 3) => "xxx" (if (<= num 0) "" (let loop ((str string) (count (- num 1))) (if (<= count 0) str (loop (string-append str string) (- count 1)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (directory-depth pathname) Returns the number of directory levels in the pathname string when the string is interpreted as a Unix-style pathname. (define (directory-depth pathname) ;; Return the number of directory levels in pathname ;; "filename" => 0 ;; "foo/filename" => 1 ;; "foo/bar/filename => 2 ;; "foo/bar/../filename => 1 (let loop ((count 0) (pathlist (match-split pathname "/"))) (if (null? pathlist) (- count 1) ;; pathname should always end in a filename (if (or (equal? (car pathlist) "/") (equal? (car pathlist) ".")) (loop count (cdr pathlist)) (if (equal? (car pathlist) "..") (loop (- count 1) (cdr pathlist)) (loop (+ count 1) (cdr pathlist))))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (find-first-char string skipchars findchars pos) Returns the first character in string that is in findchars and not in skipchars. findchars and skipchars are both strings. If pos is supplied, the search begins at offset pos within string, otherwise the search begins at offset 0. (define (find-first-char string skipchars findchars #!optional (pos 0)) ;; Finds first character in string that is in findchars, skipping all ;; occurances of characters in skipchars. Search begins at pos. If ;; no such characters are found, returns -1. ;; ;; If skipchars is empty, skip anything not in findchars ;; If skipchars is #f, skip nothing ;; If findchars is empty, the first character not in skipchars is matched ;; It is an error if findchars is not a string. ;; It is an error if findchars is empty and skipchars is not a non-empty ;; string. ;; (let ((skiplist (if (string? skipchars) (string-to-list skipchars) '())) (findlist (string-to-list findchars))) (if (and (null? skiplist) (null? findlist)) ;; this is an error -2 (if (or (>= pos (string-length string)) (< pos 0)) -1 (let ((ch (string-ref string pos))) (if (null? skiplist) ;; try to find first (if (member ch findlist) pos (if (string? skipchars) (find-first-char string skipchars findchars (+ 1 pos)) -1)) ;; try to skip first (if (member ch skiplist) (find-first-char string skipchars findchars (+ 1 pos)) (if (or (member ch findlist) (null? findlist)) pos -1)))))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (initial-substring? a b) Returns #t if a matches the initial substring of b. ;; Is `a' an initial substring of `b'? (define (initial-substring? a b) (string=? a (substring b 0 (string-length a)))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (match-split string target) Returns a list of strings. The strings are string split at every occurrence of target, and the list includes the occurrences of target. (define (match-split string target) ;; Splits string at every occurrence of target and returns the result ;; as a list. "this is a test" split at "is" returns ;; ("th" "is" " " "is" " a test") (let loop ((result '()) (current "") (rest string)) (if (< (string-length rest) (string-length target)) (append result (if (equal? (string-append current rest) "") '() (list (string-append current rest)))) (if (equal? target (substring rest 0 (string-length target))) (loop (append result (if (equal? current "") '() (list current)) (list target)) "" (substring rest (string-length target) (string-length rest))) (loop result (string-append current (substring rest 0 1)) (substring rest 1 (string-length rest))))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (match-split-string-list string-list target) Returns a list of strings. The strings are the each of the strings in string-list split at every occurrence of target, and the list includes the occurrences of target. (define (match-split-string-list string-list target) ;; Splits each string in string-list at target with match-split, ;; concatenates the results and returns them as a single list (let loop ((result '()) (sl string-list)) (if (null? sl) result (loop (append result (match-split (car sl) target)) (cdr sl))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (match-split-list string target-list) Returns a list of strings. The strings are string split at every occurrence of each of the strings in target-list, and the list includes the occurrences of the target strings. (define (match-split-list string target-list) ;; Splits string at every target in target-list with match-split, ;; returning the whole collection of strings as a list (let loop ((result (list string)) (tlist target-list)) (if (null? tlist) result (loop (match-split-string-list result (car tlist)) (cdr tlist))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (match-substitute-sosofo string assoc-list) Returns the sosofo, from the assoc-list associative list of string and sosofo pairs, that matches string, otherwise returns the sosofo of string as a literal string if there is no match. (define (match-substitute-sosofo string assoc-list) ;; Given a string and an associative list of strings and sosofos, ;; return the sosofo of the matching string, or return the literal ;; string as a sosofo. (if (assoc string assoc-list) (car (cdr (assoc string assoc-list))) (literal string))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (pad-string string length padchar) Returns string padded in front with the padchar string until it is at least length characters. If string is longer than or the same length as length characters, then string is returned without modification. Note the padchar may be more than a single-character string. (define (pad-string string length padchar) ;; Returns string, padded in front with padchar to at least length (let loop ((s string)) (if (>= (string-length s) length) s (loop (string-append padchar s))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-substring? string target pos) Returns #t if target occurs in string at offset pos. (define (repl-substring? string target pos) ;; Returns true if target occurs in string at pos (let* ((could-match (<= (+ pos (string-length target)) (string-length string))) (match (if could-match (substring string pos (+ pos (string-length target))) ""))) (and could-match (string=? match target)))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-substring string target repl pos) Returns string with substring target replaced by repl if target occurs at character offset pos, otherwise returns string unaltered. (define (repl-substring string target repl pos) ;; Replace target with repl in string at pos (let ((matches (repl-substring? string target pos))) (if matches (string-append (substring string 0 pos) repl (substring string (+ pos (string-length target)) (string-length string))) string))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-string-list? string replace-list pos) Returns #t if any of the target strings in the sequence of target–replacement pairs of strings in replace-list occurs at character offset pos within string. (define (repl-substring-list? string replace-list pos) ;; Given replace-list, a list of target, replacement pairs, return ;; true if any occurance of target occurs at pos ;; (repl-substring-list? "this is it" ("was" "x" "is" "y") 2) ;; returns true ("is" could be replaced by "y") (let loop ((list replace-list)) (let ((target (car list)) (repl (car (cdr list))) (rest (cdr (cdr list)))) (if (repl-substring? string target pos) #t (if (null? rest) #f (loop rest)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-substring-list-target string replace-list pos) Returns the target string that would be replaced if repl-substring-list were called with the same arguments. (define (repl-substring-list-target string replace-list pos) ;; Given replace-list, a list of target, replacement pairs, return ;; the target that would be replaced if repl-substring-list was ;; called with the same arguments. (let loop ((list replace-list)) (let ((target (car list)) (repl (car (cdr list))) (rest (cdr (cdr list)))) (if (repl-substring? string target pos) target (if (null? rest) #f (loop rest)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-string-list-repl string replace-list pos) Returns the replacement string that would be inserted if repl-substring-list were called with the same arguments. (define (repl-substring-list-repl string replace-list pos) ;; Given replace-list, a list of target, replacement pairs, return ;; the replacement that would be used if repl-substring-list was ;; called with the same arguments. (let loop ((list replace-list)) (let ((target (car list)) (repl (car (cdr list))) (rest (cdr (cdr list)))) (if (repl-substring? string target pos) repl (if (null? rest) #f (loop rest)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (repl-substring-list string replace-list pos) Returns string with the first target from the sequence of target–replacement pairs in replace-list that occurs at character offset pos substituted by its replacement. (define (repl-substring-list string replace-list pos) ;; Replace any single target in string at pos (the first one in ;; replace-list that matches). (if (repl-substring-list? string replace-list pos) (let ((target (repl-substring-list-target string replace-list pos)) (repl (repl-substring-list-repl string replace-list pos))) (repl-substring string target repl pos)) string)) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (string-list-sosofo string-list assoc-list) Returns a sosofo that is each of the sosofos from matching each of the strings in string-list with the string–sosofo pairs in the assoc-list associative list appended together. Strings from string-list that do not have a match in assoc-list are included as literal sosofos. (define (string-list-sosofo string-list assoc-list) ;; Take a list of strings and an associative list that maps strings ;; to sosofos and return an appended sosofo. ;; Given the string list ("what is " "1" " " "+" " " "1") ;; and the associative list ;; (("1" (literal "one")) ("2" (literal "two")) ("+" (literal "plus"))) ;; string-list-sosofo returns the equivalent of the sosofo ;; (literal "what is one plus one") (if (null? string-list) (empty-sosofo) (sosofo-append (match-substitute-sosofo (car string-list) assoc-list) (string-list-sosofo (cdr string-list) assoc-list)))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (string-replace string target repl) Returns string with all occurrences of target replaced by repl. Any occurrences of target within repl are not themselves replaced. (define (string-replace string target repl) ;; Replace all occurances of target with repl in string. If the ;; target occurs in repl, that occurance will _not_ be replaced. (let loop ((str string) (pos 0)) (if (>= pos (string-length str)) str (loop (repl-substring str target repl pos) (if (repl-substring? str target pos) (+ (string-length repl) pos) (+ 1 pos)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (string-replace-list string replace-list) Returns string with every occurrence of every target string in the sequence of target–replacement pairs in replace-list substituted by its replacement. (define (string-replace-list string replace-list) ;; Given replace-list, replace all occurances of every target in string ;; with its replacement. (let loop ((str string) (pos 0)) (if (>= pos (string-length str)) str (loop (repl-substring-list str replace-list pos) (if (repl-substring-list? str replace-list pos) (+ (string-length (repl-substring-list-repl str replace-list pos)) pos) (+ 1 pos)))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (string-to-list string) Returns a list of the characters in string. (define (string-to-list string) ;; Returns a list of the characters of string (let ((length (string-length string))) (let loop ((i 0)) (if (= i length) '() (cons (string-ref string i) (loop (+ i 1))))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (string-with-space string) Returns string with an appended blank, unless string is an empty string, in which case it returns an empty string. (define (string-with-space string) ;; Returns string with an appended blank if string is not the empty ;; string. Returns the empty string if string is the empty string. (if (equal? string "") "" (string-append string " "))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (define whitespaced-words (curry words char-whitespace?)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (words pred? s) Returns a list of the “words” split from string s. The word delimiters are characters for which predicate pred? returns #t. ;; Split string `s' into words delimited by characters answering #t to ;; predicate `pred?'. After the Haskell prelude. See also Bird and ;; Wadler. (define (words pred? s) (letrec ((words (lambda (s) (let ((dropped (dropwhile pred? s))) (if (null? dropped) '() (let ((broken (break pred? dropped))) (cons (car broken) (words (cdr broken))))))))) (map list->string (words (string->list s))))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (parse-measurement measure) Returns a two-item list of the magnitude and units components of measure. If measure is not correctly formed, one or both of the magnitude and units will be returned as #f. (define (parse-measurement measure) ;; Parses measurement and returns '(magnitude units). Either may be #f ;; if measure is not a correctly formatted measurement. Leading and ;; trailing spaces are skipped. (let* ((magstart (find-first-char measure " " "0123456789.")) (unitstart (find-first-char measure " 0123456789." "")) (unitend (find-first-char measure "" " " unitstart)) (magnitude (if (< magstart 0) #f (if (< unitstart 0) (substring measure magstart (string-length measure)) (substring measure magstart unitstart)))) (unit (if (< unitstart 0) #f (if (< unitend 0) (substring measure unitstart (string-length measure)) (substring measure unitstart unitend))))) (list magnitude unit)) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (measurement-to-length measure) Returns a length object converted from the value of the measure string. (define unit-conversion-alist (list '("default" 1pi) '("mm" 1mm) '("cm" 1cm) '("in" 1in) '("pi" 1pi) '("pc" 1pi) '("pt" 1pt) '("px" 1px) '("barleycorn" 2pi))) (define (measurement-to-length measure) ;; Converts the string measure into a DSSSL length (let* ((pm (car (parse-measurement measure))) (pu (car (cdr (parse-measurement measure)))) (magnitude (if pm pm "1")) (units (if pu pu (if pm "pt" "default")) (unitconv (assoc units unit-conversion-alist)) (factor (if unitconv (car (cdr unitconv)) 1pt))) (* (string->number magnitude) factor))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (absolute-child-number snl) Returns one plus the number of nodes preceding snl. This is similar to child-number, but it also counts siblings with a GI different from that of snl. ;; -- Similar to child-number, but also counts siblings with a GI ;; -- different than that of 'snl'. (define (absolute-child-number snl) (+ 1 (node-list-length (preced snl))) ) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (ancestor-member snl gilist) Returns the node that is the first ancestor of snl (including snl itself) whose GI is in the gilist list of strings, otherwise returns an empty node list. (define (ancestor-member snl gilist) ;; Return the first ancestor of nd whose GI is in gilist (if (node-list-empty? snl) (empty-node-list) (if (member (gi snl) gilist) nd (ancestror-member (parent snl) gilist)))) G. KenHolman 1.0 19971021 G. Ken Holman gkholman@CanadaMail.com Copied from Ken's DSSSList post of 19971017 (ancestors nl) Returns a node-list containing all ancestors of nl. The DSSSL standard has a typo in the definition of the function ancestors. The following is the corrected logic -- the third last line used to read "(loop (parent snl)" which caused an infinite loop. (define (ancestors nl) (node-list-map (lambda (snl) (let loop ((cur (parent snl)) (result (empty-node-list))) (if (node-list-empty? cur) result (loop (parent cur) (node-list cur result))))) nl)) VivekAgrawala 1.0 19971022 Vivek Agrawala vivek@scr.siemens.com (get-str-attr attr-nm osnl) Returns the string value of attribute attr-nm of node osnl. Returns "ERROR: ..." if attr-nm is not defined at osnl. (define (get-string-attr attr-nm #!optional (osnl (current-node))) (or (attribute-string attr-nm osnl) (string-append "ERROR: No Attr " attr-nm) )) VivekAgrawala 1.0 19971022 Vivek Agrawala vivek@scr.siemens.com (get-str-attr-no-err attr-nm osnl) Returns the string value of attribute attr-nm of node osnl. Returns an empty string if attr-nm is not defined at osnl. (define (get-str-attr-no-err attr-nm #!optional (osnl (current-node))) (or (attribute-string attr-nm osnl) "") ) VivekAgrawala 1.0 19971022 Vivek Agrawala vivek@scr.siemens.com (get-numeric-attr attr-nm osnl) Returns the numeric value of attribute attr-nm of node osnl. Returns -1 if attr-nm is not defined at osnl. (define (get-numeric-attr attr-nm #!optional (osnl (current-node))) (let ((a-str (attribute-string attr-nm osnl))) (if a-str (string->number a-str) -1) )) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (has-ancestor-member? nd gilist) Returns #t if the nd node has an ancestor whose GI is included in the gilist list of strings. (define (has-ancestor-member? nd gilist) ;; Return #t if nd has an ancestor in gilist (node-list-empty? (ancestor-member nd gilist))) VivekAgrawala 1.0 19971022 Vivek Agrawala vivek@scr.siemens.com (has-child? gi snl) Returns #t if snl has a child node with GI gi. Returns #f otherwise. (define (has-child? gi snl) (not (node-list-empty? (select-elements gi (children snl)))) ) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (map-node-list->list f nl) Returns a list that is the result of mapping procedure f over node-list nl. ;; Map function `f' over node list `nl', returning an ordinary list. ;; (No node list constructor in Jade.) (define (map-node-list->list f nl) (if (node-list-empty? nl) '() (cons (f (node-list-first nl)) (map-node-list->list f (node-list-rest nl))))) VivekAgrawala 1.0 19971022 Vivek Agrawala vivek@scr.siemens.com (match-element? pattern snl) This is a standard DSSSL procedure not currently available in Jade. See section 10.2.5 of the DSSSL standard for complete semantics of this function. (define (match-element? pattern snl) (if (node-list-empty? (select-elements snl pattern)) #f #t) ) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (match-siblings osnl) Returns a node-list of siblings of osnl, or of the current node if osnl is not specified, with the same GI as the node. ;; Node list of siblings with the same GI as node (define (matching-siblings #!optional (node (current-node))) (select-elements (siblings node) (gi node))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (next-matching-node osnl) Returns either the following sibling with the same GI as osnl (or of the current node if osnl is not supplied) or an empty node-list if there is no following matching sibling. ;; Return the following sibling with the same GI as `node' (or the ;; empty node list if none found). (define (next-matching-node #!optional (node (current-node))) (node-list-ref (matching-siblings) (child-number))) NormanWalsh 1.0 19971022 Norman Walsh norm@berkshire.net Submitted in private mail 19971022 (node-list-filter-by-gi nodelist gilist) Returns the node list of the elements in the node-list node list whose GI is included in the gilist list of strings. (define (node-list-filter-by-gi nodelist gilist) ;; Returns the node-list that contains every element of the original ;; nodelist whose gi is in gilist (let loop ((result (empty-node-list)) (nl nodelist)) (if (node-list-empty? nl) result (if (member (gi (node-list-first nl)) gilist) (loop (node-list result (node-list-first nl)) (node-list-rest nl)) (loop result (node-list-rest nl)))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (prev-matching-node osnl) Returns either the previous sibling with the same GI as osnl (or of the current node if osnl is not supplied) or an empty node-list if there is no previous matching sibling. ;; Return the preceding sibling with the same GI as `node' or the ;; empty node list. (define (prev-matching-node #!optional (osnl (current-node))) (node-list-ref (matching-siblings) (- (child-number osnl) 2))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (previous-element osnl) Returns either a singleton node-list containing the previous sibling of osnl, or an empty node-list if osnl is the first sibling. ;; In the absence of the full node machinery, return the preceding ;; sibling of `node' which is an element (or the empty node list if ;; none found). (define (previous-element #!optional (node (current-node))) ;; cdr down the siblings keeping track of the last element node ;; visited and check the current car against `node'; if it matches, ;; return the noted previous. (let ((first (node-list-first (siblings)))) (let loop ((previous (if (gi first) first (empty-node-list))) (current (node-list-rest (siblings)))) (cond ((node-list-empty? current) (empty-node-list)) ((node-list=? node (node-list-first current)) ; got it previous) (else (loop (if (gi (node-list-first current)) (node-list-first current) previous) (node-list-rest current))))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (siblings osnl) Returns a node-list containing the siblings of osnl, including osnl itself. (define (siblings #!optional (osnl (current-node))) (children (parent osnl))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (maybe-not-sosofo predicate sosofo) Returns empty-sosofo if predicate evaluates to a true value, or sosofo if it does not. (define (maybe-not-sosofo predicate sosofo) (if predicate (empty-sosofo) sosofo)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (maybe-not-sosofo predicate sosofo) Returns sosofo if predicate evaluates to a true value, or empty-sosofo if it does not. ;; Conditionally use the sosofo or the empty one. (define (maybe-sosofo predicate sosofo) (if predicate sosofo (empty-sosofo))) ChrisMaden 1.0 19971022 Chris Maden crism@ora.com Copied from author's DSSSList post of 19971017 (process-text snl) This procedure outlines a mechanism that preserves entity references for special characters and SDATA entity references in Jade output. It relies on some DSSSL extensions implemented in Jade, and may not work with other DSSSL engines. If query construction rules are available in your DSSSL engine, better solutions are possible. ;; Process the text under 'snl', replacing any special characters ;; and SDATA entities with appropriate entity references. (define (process-text #!optional (osnl (current-node))) (let p-t-loop ((this-node (node-list-first (children snl))) (other-nodes (node-list-rest (children snl)))) (if (node-list-empty? this-node) (empty-sosofo) (sosofo-append (case (node-property 'class-name this-node) ;; handle special characters ((data-char) (case (node-property 'char this-node) ;; ampersand ((#\&) (make entity-ref name: "amp")) ;; etc.... (else (process-node-list this-node)))) ;; handle SDATA entity references ((sdata) (case (node-property 'system-data this-node) ;; a with grave accent (("[agrave]") (make entity-ref name: "agrave")) ;; ampersand (("[amp ]") (make entity-ref name: "amp")) ;; etc.... no else )) (else (process-node-list this-node))) (p-t-loop (node-list-first other-nodes) (node-list-rest other-nodes)))))) ;; An example use for a DocBook to HTML convertor, using the SGML backend. ;; Use (process-text) as the content-expression for any element construction ;; rule where the element has mixed-content. ;;(element CITETITLE ;; (make element ;; gi: "CITE" ;; attributes: (list (list "CLASS" ;; "CITETITLE")) ;; (process-text (current-node)))) TonyGraham 1.0 19971021 Tony Graham tgraham@mulberrytech.com Based upon James Clark's DSSSList post of 19970429 (small-caps children) This procedure is sets the glyph-subst-table characteristic to a glyph table with glyphs for small caps letters in place of the glyphs for lowercase letters. Jade's RTF backend, at least, recognises those glyphs and outputs the correct information for the text to be formatted as small caps. ;; From code posted to the DSSSList by James Clark 4/29/97 (define small-caps-glyph-table (letrec ((signature (* #o375 256)) (make-afii (lambda (n) (glyph-id (string-append "ISO/IEC 10036/RA//Glyphs::" (number->string n))))) (gen (lambda (from count) (if (= count 0) '() (cons (cons (make-afii from) (make-afii (+ from signature))) (gen (+ 1 from) (- count 1))))))) (glyph-subst-table (gen #o141 26)))) (define (small-caps children) (make sequence glyph-subst-table: small-caps-glyph-table children)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (compose f1 f2) ;; Make a function equivalent to applying `f2' to its arguments and ;; `f1' to the result. (define (compose f1 f2) (lambda (#!rest rest) (f1 (apply f2 rest)))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (const c) ;; Constant function evaluating to `c'. (define (const c) (lambda (#!rest rest) c)) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (curry f arg) ;; Partially apply two-argument function `f' to `arg', returning a ;; one-argument function. (define (curry f arg) (lambda (a) (f arg a))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (curryn f rest) ;; n-ary variant (define (curryn f #!rest rest) (lambda (#!rest args) (apply f (append rest args)))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (foldl f zero xs) ;; Fold left with function `f' over list `xs' with the given `zero' ;; value. (Like DSSSL `reduce' but normal arg order.) (define (foldl f zero xs) (if (null? xs) zero (foldl f (f zero (car xs)) (cdr xs)))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (foldl1 f xs) ;; Fold left with list car as zero. (define (foldl1 f xs) (cond ((null? xs) '()) ((null? (cdr xs)) (car xs)) (else (foldl f (car xs) (cdr xs))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (foldr f zero xs) ;; Fold right, as above. (define (foldr f zero xs) (if (null? xs) zero (f (car xs) (foldl f zero (cdr xs))))) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (id arg) Returns arg. (define (id arg) arg) DaveLove 1.0 19970716 Dave Love d.love@dl.ac.uk Copied from David's DSSSList post of 19970702 (my-debug return-value) A version of debug that tries to print more helpful information than <unknown object .... Will need extending for any further types added to Jade which don't have useful print methods. ;; A version of debug that tries to print more helpful information ;; than `<unknown object ...'. Will need extending for any further ;; types added to Jade which don't have useful print methods. Fixme: ;; should yield more information extracted from each type. (define (my-debug x #!optional return-value) (debug (cond ((node-list? x) (if (node-list-empty? x) (list 'empty-node-list x) (list (if (named-node-list? x) 'named-node-list 'node-list) (node-list-length x) x))) ((sosofo? x) (list 'sosofo x)) ((procedure? x) (list 'procedure x)) ((style? x) (list 'style x)) ((address? x) (list 'address x)) ((color? x) (list 'color x)) ((color-space? x) (list 'color-space x)) ((display-space? x) (list 'display-space x)) ((inline-space? x) (list 'inline-space x)) ((glyph-id? x) (list 'glyph-id x)) ((glyph-subst-table? x) (list 'glyph-subst-table x)) (else x))))