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 formattingrelated. 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 stylesheet PUBLIC "//James Clark//DTD DSSSL Style Sheet//EN"> <![ CDATA [ ; protect <s that we use ;; Fixme: Insert some errorchecking! ;;; Debugging (define debug (externalprocedure "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 (mydebug x #!optional returnvalue) (debug (cond ((nodelist? x) (if (nodelistempty? x) (list 'emptynodelist x) (list (if (namednodelist? x) 'namednodelist 'nodelist) (nodelistlength 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)) ((colorspace? x) (list 'colorspace x)) ((displayspace? x) (list 'displayspace x)) ((inlinespace? x) (list 'inlinespace x)) ((glyphid? x) (list 'glyphid x)) ((glyphsubsttable? x) (list 'glyphsubsttable x)) (else x)))) ;;; IEEE/R4RS stuff missing from Jade ;; (It's possible stuff like this isn't optimally coded if ;; tailcallmodulocons 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) (listref xs 2)) (define (cadr xs) (listref xs 1)) (define (cddr xs) (cdr (cdr xs))) (define (string>list s) (let ((l (stringlength s))) (let loop ((i 0)) (if (= i l) '() (cons (stringref 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 argchecking 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) (listtail 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 (removeif pred? ys) (cond ((null? ys) ys) ((pred? (car ys)) (removeif pred? (cdr ys))) (else (cons (car ys) (removeif 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 (zipwith zipper #!rest xs) (if (any? null? xs) '() (cons (apply zipper (map car xs) ) (apply zipwith 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 whitespacedwords (curry words charwhitespace?)) ;; Is `a' an initial sibstring of `b'? (define (initialsubstring? a b) (string=? a (substring b 0 (stringlength 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 twoargument function `f' to `arg', returning a ;; oneargument function. (define (curry f arg) (lambda (a) (f arg a))) ;; nary 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 (emptynodelist) ; (nodelistrest (currentnode))) ; hack, hack ;(define (nodelistref nl i) ; (cond ((< i 0) (emptynodelist)) ; ((= 0 i) (nodelistfirst nl)) ; (else (nodelistref (nodelistrest nl) ; ( i 1))))) ;(define (follow snl) ; (let loop ((rest (siblings snl))) ; (cond ((nodelistempty? rest) ; (emptynodelist)) ; ((nodelist=? (nodelistfirst rest) snl) ; (nodelistrest rest)) ; (else (nodelistrest rest))))) (define (nodelistreduce nl combine init) (if (nodelistempty? nl) init (nodelistreduce (nodelistrest nl) combine (combine init (nodelistfirst nl))))) (define (nodelistsome? proc nl) (nodelistreduce nl (lambda (result snl) (if (or result (proc snl)) #t #f)) #f)) (define (nodelistfilter proc nl) (nodelistreduce nl (lambda (result snl) (if (proc snl) (nodelist snl result) result)) (emptynodelist))) ;;; DSSSL conveniences ;; Conditionally use the sosofo or the empty one. (define (maybesosofo predicate sosofo) (if predicate sosofo (emptysosofo))) (define (maybenotsosofo predicate sosofo) (if predicate (emptysosofo) sosofo)) ;; Map function `f' over node list `nl', returning an ordinary list. ;; (No node list constructor in Jade.) (define (mapnodelist>list f nl) (if (nodelistempty? nl) '() (cons (f (nodelistfirst nl)) (mapnodelist>list f (nodelistrest nl))))) (define (siblings #!optional (node (currentnode))) (children (parent node))) ;; Node list of siblings with the same GI as node (define (matchingsiblings #!optional (node (currentnode))) (selectelements (siblings node) (gi node))) ;; Return the preceding sibling with the same GI as `node' or the ;; empty node list. (define (prevmatchingnode #!optional (node (currentnode))) (nodelistref (matchingsiblings) ( (childnumber node) 2))) ;; Return the following sibling with the same GI as `node' (or the ;; empty node list if none found). (define (nextmatchingnode #!optional (node (currentnode))) (nodelistref (matchingsiblings) (childnumber))) ;; 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 (previouselement #!optional (node (currentnode))) ;; 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 (nodelistfirst (siblings)))) (let loop ((previous (if (gi first) first (emptynodelist))) (current (nodelistrest (siblings)))) (cond ((nodelistempty? current) (emptynodelist)) ((nodelist=? node (nodelistfirst current)) ; got it previous) (else (loop (if (gi (nodelistfirst current)) (nodelistfirst current) previous) (nodelistrest 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 