Re: DD: Cookbook procedure markup sample (Was: DD: Status)

[Dave Love <d.love@xxxxxxxx>]

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