Subject: Re: DD: Cookbook procedure markup sample (Was: DD: Status) From: Dave Love <d.love@xxxxxxxx> Date: 02 Jul 1997 23:11:16 +0100 |
Rather than a `cookbook' I'd like to see a documented library à la Scheme's SLIB (some of which is potentially useful asis). However, here's a collection of random stuff in case any of it is useful, though not directly formatting-related. Public domain, I guess, but mostly `trad' anyhow. I don't have time to mark it up and, actually, for pedagogical purposes and guarantees of runnability I'd prefer to use a literate programming system. Corrections welcome where I've messed up... [Some things are in a form which may not be optimal for Jade -- as opposed to a typical Scheme compiler -- but it's not so easy to check. Guidance on that could be useful.] HTH. <!DOCTYPE style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN"> <![ CDATA [ ; protect <s that we use ;; Fixme: Insert some error-checking! ;;; Debugging (define debug (external-procedure "UNREGISTERED::James Clark//Procedure::debug")) ;; 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)))) ;;; IEEE/R4RS stuff missing from Jade ;; (It's possible stuff like this isn't optimally coded if ;; tail-call-modulo-cons isn't optimized.) (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))))))))) (define (caddr xs) (list-ref xs 2)) (define (cadr xs) (list-ref xs 1)) (define (cddr xs) (cdr (cdr xs))) (define (string->list s) (let ((l (string-length s))) (let loop ((i 0)) (if (= i l) '() (cons (string-ref s i) (loop (+ i 1))))))) (define (list->string cs) (apply string cs)) (define (assoc obj alist) (if (not (list? alist)) (error "assoc: second arg not a list") (letrec ((assoc (lambda (obj alist) (if (not (null? alist)) (let ((cary (car alist))) (if (equal? obj (car cary)) cary (assoc obj (cdr alist)))) #f)))) (assoc obj alist)))) (define (even? n) (zero? (remainder n 2))) ;; Neat, but lose potential arg-checking value. ;(define odd? (compose not even?)) ;(define zero? (curry equal? 0)) (define (odd? n) (not (even? n))) (define (zero? n) (equal? 0 n)) (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)))) ;; Does an interative one win? Does it matter? Of course we should ;; use successive squaring (SICP)... ;(define (expt b n) ; (let expt1 ((accum 1) ; (nn (abs n))) ; always +ve nn ; (if (zero? nn) ; (if (< n 1) ; (/ accum) ; maybe reciprocal ; accum) ; (expt1 (* b accum) ; (- nn 1))))) ;;; Random utilities non-(DSSSL-)standard `standard' procedures ;; Lists ;; Return 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)))))) ;; Return list `xs' less the first `n' elements. (define (drop n xs) (list-tail xs n)) ;; 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)))))) ;; 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)))))) ;; 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)))) ;; 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))))) ;; Fold right, as above. (define (foldr f zero xs) (if (null? xs) zero (f (car xs) (foldl f zero (cdr 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)))))) ;; 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))))) ;; 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))) ;; 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))))) ;; Like `span', but with the sense of the test reversed. (define (break test? xs) (span (compose not test?) xs)) ;; 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))))) (define whitespaced-words (curry words char-whitespace?)) ;; Is `a' an initial sibstring of `b'? (define (initial-substring? a b) (string=? a (substring b 0 (string-length a)))) ;; 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))))) ;; Combinators ;; 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)))) ;; Partially apply two-argument function `f' to `arg', returning a ;; one-argument function. (define (curry f arg) (lambda (a) (f arg a))) ;; n-ary variant (define (curryn f #!rest rest) (lambda (#!rest args) (apply f (append rest args)))) ;; Constant function evaluating to `c'. (define (const c) (lambda (#!rest rest) c)) (define (id arg) arg) ;;; Full DSSSL node machinery which is missing from Jade ;; (Note that in the absence of a node list constructor, we're pretty ;; stymied.) ;(define (empty-node-list) ; (node-list-rest (current-node))) ; hack, hack ;(define (node-list-ref nl i) ; (cond ((< i 0) (empty-node-list)) ; ((= 0 i) (node-list-first nl)) ; (else (node-list-ref (node-list-rest nl) ; (- i 1))))) ;(define (follow snl) ; (let loop ((rest (siblings snl))) ; (cond ((node-list-empty? rest) ; (empty-node-list)) ; ((node-list=? (node-list-first rest) snl) ; (node-list-rest rest)) ; (else (node-list-rest rest))))) (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))))) (define (node-list-some? proc nl) (node-list-reduce nl (lambda (result snl) (if (or result (proc snl)) #t #f)) #f)) (define (node-list-filter proc nl) (node-list-reduce nl (lambda (result snl) (if (proc snl) (node-list snl result) result)) (empty-node-list))) ;;; DSSSL conveniences ;; Conditionally use the sosofo or the empty one. (define (maybe-sosofo predicate sosofo) (if predicate sosofo (empty-sosofo))) (define (maybe-not-sosofo predicate sosofo) (if predicate (empty-sosofo) sosofo)) ;; 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))))) (define (siblings #!optional (node (current-node))) (children (parent node))) ;; Node list of siblings with the same GI as node (define (matching-siblings #!optional (node (current-node))) (select-elements (siblings node) (gi node))) ;; Return the preceding sibling with the same GI as `node' or the ;; empty node list. (define (prev-matching-node #!optional (node (current-node))) (node-list-ref (matching-siblings) (- (child-number node) 2))) ;; 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))) ;; 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))))))) ]]><!-- CDATA --> DSSSList info and archive: http://www.mulberrytech.com/dsssl/dssslist
Current Thread |
---|
|
<- Previous | Index | Next -> |
---|---|---|
DD: Cookbook procedure markup sampl, Tony Graham | Thread | Re: DD: Cookbook procedure markup s, Tony Graham |
DD: Cookbook procedure markup sampl, Tony Graham | Date | Re: DD: Cookbook procedure markup s, Dave Love |
Month |