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

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

(break test? xs)

Returns

;; Like `span', but with the sense of the test reversed.
(define (break test? xs)
  (span (compose not test?) xs))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(define whitespaced-words
  (curry words char-whitespace?))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(siblings osnl)

Returns a node-list containing the siblings of osnl, including osnl itself.

(define (siblings #!optional (osnl (current-node)))
  (children (parent osnl)))

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

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

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

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

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

(const c)

;; Constant function evaluating to `c'.
(define (const c)
  (lambda (#!rest rest) c))

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

(curryn f rest)

;; n-ary variant
(define (curryn f #!rest rest)
  (lambda (#!rest args)
    (apply f (append rest args))))

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

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

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

(id arg)

Returns arg.

(define (id arg) arg)

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