<!DOCTYPE style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN">
<style-sheet>
<style-specification>
<style-specification-body>
;; $Id: dblib.dsl,v 1.8 2004/10/24 01:09:35 petere78 Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://nwalsh.com/docbook/dsssl/
;;
;; This file contains a general library of DSSSL functions.
;;
;; If **ANY** change is made to this file, you _MUST_ alter the
;; following definition:
;; REFERENCE Library Version
(define %library-version%
;; REFENTRY version
;; PURP Defines the library version string
;; DESC
;; Defines the library version string.
;; /DESC
;; /REFENTRY
"Modular DocBook Stylesheet Library")
;; === Book intro, for dsl2man ==========================================
<![CDATA[
;; DOCINFO
;; <title>DSSSL Library</title>
;; <subtitle>Part of the Modular DocBook Stylesheet distribution</subtitle>
;; <author><firstname>Norman</firstname><surname>Walsh</surname>
;; </author>
;; <edition>$Revision: 1.8 $</edition>
;; <copyright><year>1997</year><year>1998</year><year>1999</year>
;; <holder>Norman Walsh</holder></copyright>
;; <legalnotice>
;; <para>
;; This software may be distributed under the same terms as Jade:
;; </para>
;; <para>
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the “Software”), to deal in the Software without
;; restriction, including without limitation the rights to use,
;; copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following
;; conditions:
;; </para>
;; <para>
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; </para>
;; <para>
;; Except as contained in this notice, the names of individuals
;; credited with contribution to this software shall not be used in
;; advertising or otherwise to promote the sale, use or other
;; dealings in this Software without prior written authorization
;; from the individuals in question.
;; </para>
;; <para>
;; Any stylesheet derived from this Software that is publically
;; distributed will be identified with a different name and the
;; version strings in any derived Software will be changed so that
;; no possibility of confusion between the derived package and this
;; Software will exist.
;; </para>
;; </legalnotice>
;; <legalnotice>
;; <para>
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL NORMAN WALSH OR ANY OTHER
;; CONTRIBUTOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;; OTHER DEALINGS IN THE SOFTWARE.
;; </para>
;; </legalnotice>
;; <legalnotice>
;; <para>Please direct all questions, bug reports, or suggestions for changes
;; to Norman Walsh, <<literal>ndw@nwalsh.com</literal>>.
;; </para>
;; <para>
;; See <ulink url="http://nwalsh.com/docbook/dsssl/">http://nwalsh.com/docbook/dsssl/</ulink> for more information.</para>
;; </legalnotice>
;; /DOCINFO
]]>
;; === Some additional units ============================================
(define-unit pi (/ 1in 6)) ;pica
(define-unit pc (/ 1in 6)) ;pica, another name
(define-unit pt (/ 1in 72)) ;point
(define-unit px (/ 1in 96)) ;pixel
;; REFERENCE ISO/IEC 10179
(define (node-list-reduce nl proc init)
;; REFENTRY node-list-reduce
;; PURP Implements node-list-reduce as per ISO/IEC 10179:1996
;; DESC
;; Implements 'node-list-reduce' as per ISO/IEC 10179:1996
;; /DESC
;; AUTHOR From ISO/IEC 10179:1996
;; /REFENTRY
(if (node-list-empty? nl)
init
(node-list-reduce (node-list-rest nl)
proc
(proc init (node-list-first nl)))))
(define (node-list-last nl)
;; REFENTRY node-list-last
;; PURP Implements node-list-last as per ISO/IEC 10179:1996
;; DESC
;; Implements 'node-list-last' as per ISO/IEC 10179:1996
;; /DESC
;; AUTHOR From ISO/IEC 10179:1996
;; /REFENTRY
(node-list-ref nl
(- (node-list-length nl) 1)))
(define (node-list-first-element nodelist)
;; REFENTRY node-list-first-element
;; PURP Return the first element node in a node list
;; DESC
;; This function returns the first node in a node list which is
;; an element (as opposed to a PI or anything else that might appear
;; in a node list).
;; /DESC
;; /REFENTRY
(let loop ((nl nodelist))
(if (node-list-empty? nl)
(empty-node-list)
(if (gi (node-list-first nl))
(node-list-first nl)
(loop (node-list-rest nl))))))
(define (node-list-last-element nodelist)
;; REFENTRY node-list-last-element
;; PURP Return the last element node in a node list
;; DESC
;; This function returns the last node in a node list which is
;; an element (as opposed to a PI or anything else that might appear
;; in a node list).
;; /DESC
;; /REFENTRY
(let loop ((el (empty-node-list)) (nl nodelist))
(if (node-list-empty? nl)
el
(if (gi (node-list-first nl))
(loop (node-list-first nl) (node-list-rest nl))
(loop el (node-list-rest nl))))))
(define (ipreced nl)
;; REFENTRY ipreced
;; PURP Implements ipreced as per ISO/IEC 10179:1996
;; DESC
;; Implements 'ipreced' as per ISO/IEC 10179:1996
;; /DESC
;; AUTHOR From ISO/IEC 10179:1996
;; /REFENTRY
(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))
(define (ifollow nl)
;; REFENTRY ifollow
;; PURP Implements ifollow as per ISO/IEC 10179:1996
;; DESC
;; Implements 'ifollow' as per ISO/IEC 10179:1996
;; /DESC
;; AUTHOR From ISO/IEC 10179:1996
;; /REFENTRY
(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))
(define (siblings snl)
;; REFENTRY siblings
;; PURP Implements siblings as per ISO/IEC 10179:1996
;; DESC
;; Implements 'siblings' as per ISO/IEC 10179:1996
;; /DESC
;; AUTHOR From ISO/IEC 10179:1996
;; /REFENTRY
(children (parent snl)))
(define (string->list str)
;; REFENTRY string-2-list
;; PURP Converts a string into a list of characters.
;; DESC
;; Implements 'string->list' as per ISO/IEC 10179:1996
;; (clause 8.5.9.9).
;; /DESC
;; AUTHOR David Megginson
;; EMAIL dmeggins@uottawa.ca
;; /REFENTRY
(let loop ((chars '())
(k (- (string-length str) 1)))
(if (< k 0)
chars
(loop (cons (string-ref str k) chars) (- k 1)))))
(define (list->string chars)
;; REFENTRY list-2-string
;; PURP Converts a list of characters into a string
;; DESC
;; Implements 'list->string' as per ISO/IEC 10179:1996
;; (clause 8.5.9.9).
;; /DESC
;; AUTHOR David Megginson
;; EMAIL dmeggins@uottawa.ca
;; /REFENTRY
(let loop ((cl chars)
(str ""))
(if (null? cl)
str
(loop (cdr cl)
(string-append str (string (car cl)))))))
;; ======================================================================
(define (map f #!rest xs)
;; REFENTRY map
;; PURP Implements map
;; DESC
;; Implements map
;; /DESC
;; AUTHOR From Mulberry Tech. site (need better attribution)
;; /REFENTRY
(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 (absolute-child-number #!optional (nd (current-node)))
;; REFENTRY absolute-child-number
;; PURP Returns the absolute child number of the specified node
;; DESC
;; Returns the child number, regardless of gi, of 'snl' within its
;; parent.
;;
;; Isn't there a better way to get this?
;; ARGS
;; ARG snl
;; The node (singleton node list) whose child number is desired.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(+ (node-list-length (preced nd)) 1))
;; REFERENCE Debug
(define (my-debug x #!optional return-value)
;; REFENTRY my-debug
;; PURP A debugging function more helpful than (debug)
;; DESC
;; A version of debug that tries to print information more helpful
;; than "unknown object ...". Will need extending for any further
;; types added to Jade which don't have useful print methods.
;; (Should yield more information extracted from each type.)
;; ARGS
;; ARG x
;; The object about which debugging information is desired.
;; /ARG
;; /ARGS
;; /DESC
;; AUTHOR Tony Graham
;; /REFENTRY
(let ((msg (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)))))
return-value))
;; REFERENCE Miscellaneous
(define (string-with-space string #!optional (space " "))
;; REFENTRY string-with-space
;; PURP Returns string with a space appended or the empty string
;; DESC
;; If 'string' is not the empty string, returns 'string' with a
;; 'space' appended. If 'string' is empty, or is not a '(string?)',
;; returns 'string' unmodified.
;; ARGS
;; ARG 'string'
;; The string onto which a space should be appended.
;; /ARG
;; ARG 'space' o
;; If specified, the space to append. Defaults to a single space.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(if (string? string)
(if (equal? string "")
string
(string-append string space))
string))
;; ======================================================================
(define (split str #!optional (whitespace '(#\space)))
;; REFENTRY split
;; PURP Splits string at whitespace and returns the resulting list of tokens
;; DESC
;; Given a string containing delimited tokens, return a list
;; of the tokens in string form.
;; ARGS
;; ARG 'str'
;; The string to split.
;; /ARG
;; ARG 'whitespace' o
;; A list of characters that should
;; be treated as whitespace.
;; /ARG
;; /ARGS
;; /DESC
;; AUTHOR David Megginson
;; EMAIL dmeggins@uottawa.ca
;; /REFENTRY
(let loop ((characters (string->list str)) ; Top-level recursive loop.
(current-word '())
(tokens '()))
; If there are no characters left,
; then we're done!
(cond ((null? characters)
; Is there a token in progress?
(if (null? current-word)
(reverse tokens)
(reverse (cons (list->string (reverse current-word))
tokens))))
; If there are characters left,
; then keep going.
(#t
(let ((c (car characters))
(rest (cdr characters)))
; Are we reading a space?
(cond ((member c whitespace)
(if (null? current-word)
(loop rest '() tokens)
(loop rest
'()
(cons (list->string (reverse current-word))
tokens))))
; We are reading a non-space
(#t
(loop rest (cons c current-word) tokens))))))))
;; ======================================================================
(define (strip str #!optional (stripchars '(#\space #\&#RE #\U-0009)))
;; REFENTRY strip
;; PURP Strip leading and trailing characters off of a string
;; DESC
;; Strips leading and trailing characters in the 'stripchars' list
;; off of a string and returns the stripped string.
;; ARGS
;; ARG 'str'
;; The string to strip
;; /ARG
;; ARG 'stripchars' o
;; A list of characters that should
;; be stripped.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(let* ((startpos (let loop ((count 0))
(if (>= count (string-length str))
(string-length str)
(if (member (string-ref str count) stripchars)
(loop (+ count 1))
count))))
(tailstr (substring str startpos (string-length str)))
(endpos (let loop ((count (- (string-length tailstr) 1)))
(if (< count 1)
0
(if (member (string-ref tailstr count) stripchars)
(loop (- count 1))
count)))))
(if (or (< endpos 0)
(string=? tailstr ""))
""
(substring tailstr 0 (+ endpos 1)))))
;; ======================================================================
(define (join slist #!optional (space " "))
;; REFENTRY join
;; PURP Joins a list of strings together
;; DESC
;; Given a list of strings and a space string, returns the string
;; that results from joining all the strings in the list together,
;; separated by space.
;; ARGS
;; ARG 'slist'
;; The list of strings.
;; /ARG
;; ARG 'space' o
;; The string to place between each member of the list. Defaults to
;; a single space.
;; /ARG
;; /ARGS
;; /DESC
;; AUTHOR David Carlisle
;; /REFENTRY
(letrec ((loop (lambda (l result)
(if (null? l)
result
(loop (cdr l) (cons space (cons (car l) result)))))))
(if (null? slist)
""
(apply string-append (cons (car slist)
(loop (reverse (cdr slist)) '() ))))))
;; ======================================================================
(define (pad-string string length padchar)
;; REFENTRY pad-string
;; PURP Pads a string, in front, to the specified length
;; DESC
;; Returns 'string', padded in front with 'padchar' to at least 'length'
;; Returns 'string' unmodified if 'string' is not a '(string?)',
;; 'padchar' is not a '(string?)', 'padchar' is the empty string, or if
;; 'string' is already greater than or equal to 'length' in length.
;; ARGS
;; ARG 'string'
;; The string to pad.
;; /ARG
;; ARG 'length'
;; The desired length.
;; /ARG
;; ARG 'padchar'
;; The character (string, actually) to use as padding. If 'padchar' is
;; longer than 1 character, the resulting string may be longer than
;; 'length' when returned.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(if (and (string? string)
(string? padchar)
(> (string-length padchar) 0))
(let loop ((s string) (count (- length (string-length string))))
(if (<= count 0)
s
(loop (string-append padchar s)
(- count (string-length padchar)))))
string))
;; ======================================================================
(define (match-split string target)
;; REFENTRY match-split
;; PURP Splits string at target and returns the resulting list of tokens
;; DESC
;; Splits string at every occurance of target and returns the result
;; as a list. Note that 'match-split' returns the occurances of 'target'
;; in the list of tokens.
;; ARGS
;; ARG 'string'
;; The string to split.
;; /ARG
;; ARG 'target'
;; The string which is a delimiter between tokens
;; /ARG
;; /ARGS
;; /DESC
;; EXAMPLE
;; '"this is a test"' split at '"is"' returns
;; '("th" "is" " " "is" " a test")'
;; /EXAMPLE
;; /REFENTRY
(if (string? string)
(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))))))
(list string)))
(define (match-split-string-list string-list target)
;; REFENTRY match-split-string-list
;; PURP Splits each string in a list of strings and returns the concatenated result list
;; DESC
;; Splits each string in 'string-list' at 'target' with '(match-split)',
;; concatenates the results, and returns a single list of tokens.
;; ARGS
;; ARG string-list
;; The list of strings to split.
;; /ARG
;; ARG target
;; The string which is a delimiter between tokens.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(let loop ((result '()) (sl string-list))
(if (null? sl)
result
(loop (append result (match-split (car sl) target))
(cdr sl)))))
(define (match-split-list string target-list)
;; REFENTRY match-split-list
;; PURP Splits a string at a list of targets and returns the resulting list of tokens
;; DESC
;; Splits 'string' at every target in 'target-list' with '(match-split)',
;; returning the whole collection of tokens as a list.
;; ARGS
;; ARG string
;; The string to split.
;; /ARG
;; ARG target-list
;; A list of target strings which are the delimters between tokens.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(let loop ((result (list string)) (tlist target-list))
(if (null? tlist)
result
(loop (match-split-string-list result (car tlist))
(cdr tlist)))))
;; ======================================================================
(define (assoc-objs alist)
;; REFENTRY assoc-objs
;; PURP Returns a list of the objects in an associative list
;; DESC
;; Returns a list of the objects in an associative list.
;; ARGS
;; ARG alist
;; The associative list. An associative list is a list of lists
;; where each interior list is a pair of elements.
;; /ARG
;; /ARGS
;; /DESC
;; EXAMPLE
;; '(assoc-objs (("a" "b") ("c" "d")))' returns '("a" "c")'
;; /EXAMPLE
;; /REFENTRY
(let loop ((result '()) (al alist))
(if (null? al)
result
(loop (append result (list (car (car al)))) (cdr al)))))
(define (assoc obj alist)
;; REFENTRY assoc
;; PURP Returns the association of an object in an associative list
;; DESC
;; Given an associative list, returns the pair that has 'obj' as a 'car'
;; or '#f' if no such pair exists.
;; ARGS
;; ARG obj
;; The associative key to locate.
;; /ARG
;; ARG alist
;; The associative list.
;; /ARG
;; /ARGS
;; /DESC
;; EXAMPLE
;; '(assoc "a" (("a" "b") ("c" "d")))' returns '("a" "b")'
;; /EXAMPLE
;; /REFENTRY
(let loop ((al alist))
(if (null? al)
#f
(if (equal? obj (car (car al)))
(car al)
(loop (cdr al))))))
(define (match-substitute-sosofo string assoc-list)
;; REFENTRY match-substitute-sosofo
;; PURP Return matching sosofo from associative list
;; DESC
;; 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.
;;
;; (This function is used for a particular task in the DocBook stylesheets.
;; It may not be particularly general, but it's in 'dblib.dsl' because
;; there is nothing DTD-specific about it.)
;; /DESC
;; /REFENTRY
(if (assoc string assoc-list)
(car (cdr (assoc string assoc-list)))
(literal string)))
(define (string-list-sosofo string-list assoc-list)
;; REFENTRY string-list-sosofo
;; PURP Build sosofo from a list of strings and an associative list
;; DESC
;; Take a list of strings and an associative list that maps strings
;; to sosofos and return an appended sosofo.
;;
;; (This function is used for a particular task in the DocBook stylesheets.
;; It may not be particularly general, but it's in 'dblib.dsl' because
;; there is nothing DTD-specific about it.)
;; /DESC
;; EXAMPLE
;; 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 sequence of sosofos
;; equivalent to '(literal "what is one plus one")'.
;; /EXAMPLE
;; /REFENTRY
(if (null? string-list)
(empty-sosofo)
(sosofo-append (match-substitute-sosofo (car string-list) assoc-list)
(string-list-sosofo (cdr string-list) assoc-list))))
;; ======================================================================
(define (repl-substring? string target pos)
;; REFENTRY repl-substring-p
;; PURP Returns true if the specified substring can be replaced
;; DESC
;; Returns '#t' if 'target' occurs at 'pos' in 'string'.
;; /DESC
;; /REFENTRY
(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))))
(define (repl-substring string target repl pos)
;; REFENTRY repl-substring
;; PURP Replace substring in a string
;; DESC
;; Replaces 'target' with 'repl' in 'string' at 'pos'.
;; /DESC
;; /REFENTRY
(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)))
(define (repl-substring-list? string replace-list pos)
;; REFENTRY repl-substring-list-p
;; PURP Perform repl-substring? with a list of target/replacement pairs
;; DESC
;; Returns '#t' if any target in 'replace-list' occurs at 'pos' in 'string'.
;; ARGS
;; ARG 'string'
;; The string in which replacement should be tested.
;; /ARG
;; ARG 'replace-list'
;; A list of target/replacement pairs. This list is just a list of
;; strings, treated as pairs. For example, '("was" "x" "is" "y")'.
;; In this example, 'was' may be replaced by 'x' and 'is' may be
;; replaced by 'y'.
;; /ARG
;; ARG 'pos'
;; The location within 'string' where the test will occur.
;; /ARG
;; /ARGS
;; /DESC
;; EXAMPLE
;; '(repl-substring-list? "this is it" ("was" "x" "is" "y") 2)'
;; returns '#t': "is" could be replaced by "y".
;; /EXAMPLE
;; /REFENTRY
(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))))))
(define (repl-substring-list-target string replace-list pos)
;; REFENTRY repl-substring-list-target
;; PURP Return the target that matches in a string
;; DESC
;; Returns the target in 'replace-list' that matches in 'string' at 'pos'
;; See also 'repl-substring-list?'.
;; /DESC
;; /REFENTRY
(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))))))
(define (repl-substring-list-repl string replace-list pos)
;; REFENTRY repl-substring-list-repl
;; PURP Return the replacement that would be used in the string
;; DESC
;; Returns the replacement in 'replace-list' that would be used for the
;; target that matches in 'string' at 'pos'
;; See also 'repl-substring-list?'.
;; /DESC
;; /REFENTRY
(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))))))
(define (repl-substring-list string replace-list pos)
;; REFENTRY repl-substring-list
;; PURP Replace the first target in the replacement list that matches
;; DESC
;; Replaces the first target in 'replace-list' that matches in 'string'
;; at 'pos' with its replacement.
;; See also 'repl-substring-list?'.
;; /DESC
;; /REFENTRY
(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))
(define (string-replace string target repl)
;; REFENTRY string-replace
;; PURP Replace all occurances of a target substring in a string
;; DESC
;; Replaces all occurances of 'target' in 'string' with 'repl'.
;; /DESC
;; /REFENTRY
(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))))))
(define (string-replace-list string replace-list)
;; REFENTRY string-replace-list
;; PURP Replace a list of target substrings in a string
;; DESC
;; Replaces, in 'string', all occurances of each target in
;; 'replace-list' with its replacement.
;; /DESC
;; /REFENTRY
(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))))))
;; ======================================================================
(define (ancestor-member nd gilist)
;; REFENTRY ancestor-member
;; PURP Returns the first ancestor in a list of GIs
;; DESC
;; Returns the first ancestor of 'nd' whose GI is a member of 'gilist'.
;; /DESC
;; /REFENTRY
(if (node-list-empty? nd)
(empty-node-list)
(if (member (gi nd) gilist)
nd
(ancestor-member (parent nd) gilist))))
(define (has-ancestor-member? nd gilist)
;; REFENTRY has-ancestor-member-p
;; PURP Returns true if the specified node has one of a set of GIs as an ancestor
;; DESC
;; Returns '#t' if 'nd' has an ancestor whose GI is a member of 'gilist'.
;; /DESC
;; /REFENTRY
(not (node-list-empty? (ancestor-member nd gilist))))
;; ======================================================================
(define (descendant-of? ancestor child)
;; REFENTRY descendant-of-p
;; PURP Returns true if the child is some descendant of the specified node
;; DESC
;; Returns '#t' if 'child' is a descendant of 'ancestor'.
;; /DESC
;; /REFENTRY
(let loop ((c child))
(if (node-list-empty? c)
#f
(if (node-list=? ancestor c)
#t
(loop (parent c))))))
;; ======================================================================
(define (expand-children nodelist gilist)
;; REFENTRY expand-children
;; PURP Expand selected nodes in a node list
;; DESC
;; Given a node-list, 'expand-children' replaces all of the members
;; of the node-list whose GIs are members of 'gilist' with
;; '(children)'.
;;
;; This function can be used to selectively
;; flatten the hierarchy of a document.
;; /DESC
;; EXAMPLE
;; Suppose that the node list is '(BOOKINFO PREFACE PART APPENDIX)'.
;; '(expand-children nl ("PART"))' might return
;; '(BOOKINFO PREFACE CHAPTER CHAPTER APPENDIX)'.
;; /EXAMPLE
;; /REFENTRY
(let loop ((nl nodelist) (result (empty-node-list)))
(if (node-list-empty? nl)
result
(if (member (gi (node-list-first nl)) gilist)
(loop (node-list-rest nl)
(node-list result (children (node-list-first nl))))
(loop (node-list-rest nl)
(node-list result (node-list-first nl)))))))
;; ======================================================================
(define (directory-depth pathname)
;; REFENTRY directory-depth
;; PURP Count the directory depth of a path name
;; DESC
;; Returns the number of directory levels in 'pathname'
;;
;; The pathname must end in a filename.
;; Further, this function assumes that directories in a pathname are
;; separated by forward slashes ("/").
;; /DESC
;; EXAMPLE
;; "filename" => 0,
;; "foo/filename" => 1,
;; "foo/bar/filename => 2,
;; "foo/bar/../filename => 1.
;; /EXAMPLE
;; /REFENTRY
(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)))))))
(define (file-extension filespec)
;; REFENTRY file-extension
;; PURP Return the extension of a filename
;; DESC
;; Returns the extension of a filename. The extension is the last
;; "."-delimited part of the name. Returns "" if there is no period
;; in the filename.
;; /DESC
;; /REFENTRY
(if (string? filespec)
(let* ((pathparts (match-split filespec "/"))
(filename (list-ref pathparts (- (length pathparts) 1)))
(fileparts (match-split filename "."))
(extension (list-ref fileparts (- (length fileparts) 1))))
(if (> (length fileparts) 1)
extension
""))
""))
;; ======================================================================
(define (copy-string string num)
;; REFENTRY copy-string
;; PURP Return a string duplicated a specified number of times
;; DESC
;; Copies 'string' 'num' times and returns the result.
;; /DESC
;; EXAMPLE
;; (copy-string "x" 3) returns "xxx"
;; /EXAMPLE
;; /REFENTRY
(if (<= num 0)
""
(let loop ((str string) (count (- num 1)))
(if (<= count 0)
str
(loop (string-append str string) (- count 1))))))
;; ======================================================================
(define (node-list-filter-by-gi nodelist gilist)
;; REFENTRY node-list-filter-by-gi
;; PURP Returns selected elements from a node list
;; DESC
;; Returns a node list containing all the nodes from 'nodelist' whose
;; GIs are members of 'gilist'. The order of nodes in the node list
;; is preserved.
;; /DESC
;; /REFENTRY
(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))))))
;; ======================================================================
(define (node-list-filter-by-not-gi nodelist gilist)
;; REFENTRY node-list-filter-by-not-gi
;; PURP Returns selected elements from a node list
;; DESC
;; Returns a node list containing all the nodes from 'nodelist' whose
;; GIs are NOT members of 'gilist'. The order of nodes in the node list
;; is preserved.
;; /DESC
;; /REFENTRY
(let loop ((result (empty-node-list)) (nl nodelist))
(if (node-list-empty? nl)
result
(if (member (gi (node-list-first nl)) gilist)
(loop result (node-list-rest nl))
(loop (node-list result (node-list-first nl))
(node-list-rest nl))))))
;; ======================================================================
(define (node-list-filter-out-pis nodelist)
;; REFENTRY node-list-filter-out-pis
;; PURP Returns the nodelist with all PIs removed
;; DESC
;; Returns a node list containing all the nodes from 'nodelist' that
;; are not PIs. The order of nodes in the node list is preserved.
;; /DESC
;; /REFENTRY
(let loop ((result (empty-node-list)) (nl nodelist))
(if (node-list-empty? nl)
result
(if (equal? (node-property 'class-name (node-list-first nl)) 'pi)
(loop result (node-list-rest nl))
(loop (node-list result (node-list-first nl))
(node-list-rest nl))))))
;; ======================================================================
(define (node-list-filter-elements nodelist)
;; REFENTRY node-list-filter-elements
;; PURP Returns the elements in 'nodelist'
;; DESC
;; Returns the elements in 'nodelist'
;; /DESC
;; /REFENTRY
(let loop ((result (empty-node-list)) (nl nodelist))
(if (node-list-empty? nl)
result
(if (equal? (node-property 'class-name (node-list-first nl)) 'element)
(loop (node-list result (node-list-first nl))
(node-list-rest nl))
(loop result (node-list-rest nl))))))
;; ======================================================================
(define (component-descendant-node-list inputnd complist)
;; REFENTRY component-descendant-node-list
;; PURP Find all 'inputnd's within an ancestor element
;; DESC
;; Finds the first ancestor of 'inputnd' in 'complist' and then returns
;; a node list of all the 'inputnd's within (that are descendants of)
;; that ancestor.
;; /DESC
;; /REFENTRY
(let ((nd (ancestor-member inputnd complist)))
(select-elements (descendants nd) (gi inputnd))))
(define (component-child-number inputnd complist)
;; REFENTRY component-child-number
;; PURP Find child-number within a component
;; DESC
;; Finds the first ancestor of 'inputnd' in 'complist' and then counts
;; all the elements of type 'inputnd' from that point on and returns
;; the number of 'inputnd'. (This is like a 'recursive-child-number'
;; starting at the first parent of 'inputnd' in 'complist'.)
;; /DESC
;; /REFENTRY
(let loop ((nl (component-descendant-node-list inputnd complist))
(num 1))
(if (node-list-empty? nl)
0
(if (node-list=? (node-list-first nl) inputnd)
num
(if (string=? (gi (node-list-first nl)) (gi inputnd))
(loop (node-list-rest nl) (+ num 1))
(loop (node-list-rest nl) num))))))
(define (component-list-descendant-node-list inputnd inputlist complist)
;; REFENTRY component-descendant-list-node-list
;; PURP Find all elements of a list of elements in a component
;; DESC
;; Finds the first ancestor of 'inputnd' in 'complist' and
;; then returns a list of all the elements in 'inputlist'
;; within that component.
;;
;; WARNING: this requires walking over *all* the descendants
;; of the ancestor node. This may be *slow*.
;; /DESC
;; /REFENTRY
(let ((nd (ancestor-member inputnd complist)))
(let loop ((nl (descendants nd)) (result (empty-node-list)))
(if (node-list-empty? nl)
result
(if (member (gi (node-list-first nl)) inputlist)
(loop (node-list-rest nl)
(node-list result (node-list-first nl)))
(loop (node-list-rest nl)
result))))))
(define (component-list-child-number inputnd inputlist complist)
;; REFENTRY component-list-child-number
;; PURP Find child-number of a list of children within a component
;; DESC
;; Finds the first ancestor of 'inputnd' in 'complist' and
;; then counts all the elements of the types in 'inputlist'
;; from that point on and returns the number of 'inputnd'.
;;
;; If the node is not found, 0 is returned.
;;
;; WARNING: this requires walking over *all* the descendants
;; of the ancestor node. This may be *slow*.
;; /DESC
;; /REFENTRY
(let loop ((nl (component-list-descendant-node-list
inputnd inputlist complist))
(num 1))
(if (node-list-empty? nl)
0
(if (node-list=? (node-list-first nl) inputnd)
num
(loop (node-list-rest nl) (+ num 1))))))
;; ======================================================================
(define (expt b n)
;; REFENTRY expt
;; PURP Exponentiation
;; DESC
;; Returns 'b' raised to the 'n'th power for integer 'n' >= 0.
;; /DESC
;; /REFENTRY
;;
(if (<= n 0)
1
(* b (expt b (- n 1)))))
;; ======================================================================
(define (list-member-find element elementlist)
;; REFENTRY list-member-find
;; PURP Returns the index of an element in a list
;; DESC
;; Returns the index of 'element' in the list 'elementlist'. The
;; first element in a list has index 0.
;; /DESC
;; /REFENTRY
(let loop ((elemlist elementlist) (count 0))
(if (null? elemlist)
-1
(if (equal? element (car elemlist))
count
(loop (cdr elemlist) (+ count 1))))))
;; ======================================================================
(define default-uppercase-list
;; REFENTRY
;; PURP The default list of uppercase characters
;; DESC
;; The default list of uppercase characters. The order and sequence
;; of characters
;; in this list must match the order and sequence in
;; 'default-lowercase-list'.
;; /DESC
;; /REFENTRY
'(#\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 default-lowercase-list
;; REFENTRY
;; PURP The default list of lowercase characters
;; DESC
;; The default list of lowercase characters. The order and sequence
;; of characters
;; in this list must match the order and sequence in
;; 'default-uppercase-list'.
;; /DESC
;; /REFENTRY
'(#\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 (case-fold-down-char ch #!optional (uc-list default-uppercase-list)
(lc-list default-lowercase-list))
;; REFENTRY
;; PURP Return the lowercase form of a single character
;; DESC
;; Returns the lowercase form of 'ch' if 'ch' is a member of
;; the uppercase list, otherwise return 'ch'.
;;
;; The implied mapping from uppercase to lowercase in the two lists is
;; one-to-one. The first element of the uppercase list is the uppercase
;; form of the first element of the lowercase list, and vice versa.
;; ARGS
;; ARG 'ch'
;; The character to fold down.
;; /ARG
;; ARG 'uc-list' o
;; The list of uppercase letters. The default is the list of English
;; uppercase letters.
;; /ARG
;; ARG 'lc-list' o
;; The list of lowercase letters. The default is the list of English
;; lowercase letters.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(let ((idx (list-member-find ch uc-list)))
(if (>= idx 0)
(list-ref lc-list idx)
ch)))
(define (case-fold-up-char ch #!optional (uc-list default-uppercase-list)
(lc-list default-lowercase-list))
;; REFENTRY
;; PURP Return the uppercase form of a single character
;; DESC
;; Returns the uppercase form of 'ch' if 'ch' is a member of
;; 'lowercase-list', otherwise return 'ch'.
;;
;; The implied mapping from uppercase to lowercase in the two lists is
;; one-to-one. The first element of the uppercase list is the uppercase
;; form of the first element of the lowercase list, and vice versa.
;; ARGS
;; ARG 'ch'
;; The character to fold down.
;; /ARG
;; ARG 'uc-list' o
;; The list of uppercase letters. The default is the list of English
;; uppercase letters.
;; /ARG
;; ARG 'lc-list' o
;; The list of lowercase letters. The default is the list of English
;; lowercase letters.
;; /ARG
;; /ARGS
;; /DESC
;; /REFENTRY
(let ((idx (list-member-find ch lc-list)))
(if (>= idx 0)
(list-ref uc-list idx)
ch)))
(define (case-fold-down-charlist charlist)
;; REFENTRY case-fold-down-charlist
;; PURP Return the list of characters, shifted to lowercase
;; DESC
;; Shifts all of the characters in 'charlist' to lowercase with
;; 'case-fold-down-char'.
;; /DESC
;; /REFENTRY
(if (null? charlist)
'()
(cons (case-fold-down-char (car charlist))
(case-fold-down-charlist (cdr charlist)))))
(define (case-fold-up-charlist charlist)
;; REFENTRY case-fold-up-charlist
;; PURP Return the list of characters, shifted to uppercase
;; DESC
;; Shifts all of the characters in 'charlist' to uppercase with
;; 'case-fold-up-char'.
;; /DESC
;; /REFENTRY
(if (null? charlist)
'()
(cons (case-fold-up-char (car charlist))
(case-fold-up-charlist (cdr charlist)))))
(define (case-fold-down str)
;; REFENTRY case-fold-down
;; PURP Shift a string to lowercase
;; DESC
;; Returns 'str' in lowercase.
;; /REFENTRY
(if (string? str)
(apply string (case-fold-down-charlist (string->list str)))
str))
(define (case-fold-up str)
;; REFENTRY case-fold-up
;; PURP Shift a string to uppercase
;; DESC
;; Returns 'str' in uppercase.
;; /REFENTRY
(if (string? str)
(apply string (case-fold-up-charlist (string->list str)))
str))
;; ======================================================================
(define (find-first-char string skipchars findchars #!optional (pos 0))
;; REFENTRY find-first-char
;; PURP Find the first occurance of a character in a string
;; DESC
;; 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.
;; /DESC
;; /REFENTRY
(let ((skiplist (if (string? skipchars)
(string->list skipchars)
'()))
(findlist (string->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))))))))
;; ======================================================================
(define (parse-measurement measure)
;; REFENTRY parse-measurement
;; PURP Parse a string containing a measurement and return the magnitude and units
;; DESC
;; Parse a string containing a measurement, e.g., '"3pi"' or '"2.5in"',
;; and return the magnitude and units: '(3 "pi")' or '(2.5 "in")'.
;;
;; Either element of the list may be '#f' if the string cannot reasonably
;; be parsed as a measurement. Leading and trailing spaces are ignored.
;; /DESC
;; /REFENTRY
(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)))
(define unit-conversion-alist
;; REFENTRY
;; PURP Defines the base length of specific unit names
;; DESC
;; This list identifies the length of each unit.
;; /DESC
;; /REFENTRY
(list
'("default" 1pi)
'("mm" 1mm)
'("cm" 1cm)
'("in" 1in)
'("pi" 1pi)
'("pc" 1pi)
'("pt" 1pt)
'("px" 1px)
'("barleycorn" 2pi)))
(define (measurement-to-length measure)
;; REFENTRY measurement-to-length
;; PURP Convert a measurement to a length
;; DESC
;; Given a string containing a measurement, return that measurement
;; as a length.
;; /DESC
;; EXAMPLES
;; '"2.5cm"' returns 2.5cm as a length. '"3.4barleycorn"' returns
;; 6.8pi.
;; /EXAMPLES
;; /REFENTRY
(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)))
;; ======================================================================
(define (dingbat usrname)
;; REFENTRY dingbat
;; PURP Map dingbat names to Unicode characters
;; DESC
;; Map a dingbat name to the appropriate Unicode character.
;; /DESC
;; /REFENTRY
;; Print dingbats and other characters selected by name
(let ((name (case-fold-down usrname)))
(case name
;; For backward compatibility
(("box") "\white-square;")
(("checkbox") "\white-square;")
;; \check-mark prints the wrong symbol (in Jade 0.8 RTF backend)
(("check") "\heavy-check-mark;")
(("checkedbox") "\ballot-box-with-check;")
(("dash") "\em-dash;")
(("copyright") "\copyright-sign")
;; Straight out of Unicode
(("raquo") "\U-00BB;")
(("laquo") "\U-00AB;")
(("rsaquo") "\U-203A;")
(("lsaquo") "\U-2039;")
(("lsquo") "\U-2018;")
(("rsquo") "\U-2019;")
(("ldquo") "\U-201C;")
(("rdquo") "\U-201D;")
(("ldquor") "\U-201E;")
(("rdquor") "\U-201D;")
(("en-dash") "\en-dash;")
(("em-dash") "\em-dash;")
(("en-space") "\U-2002;")
(("em-space") "\U-2003;")
(("bullet") "\bullet;")
(("black-square") "\black-square;")
(("white-square") "\white-square;")
;; \ballot-box name doesn't work (in Jade 0.8 RTF backend)
;; and \white-square looks better than \U-2610; anyway
(("ballot-box") "\white-square;")
(("ballot-box-with-check") "\ballot-box-with-check;")
(("ballot-box-with-x") "\ballot-box-with-x;")
;; \check-mark prints the wrong symbol (in Jade 0.8 RTF backend)
(("check-mark") "\heavy-check-mark;")
;; \ballot-x prints out the wrong symbol (in Jade 0.8 RTF backend)
(("ballot-x") "\heavy-check-mark;")
(("copyright-sign") "\copyright-sign;")
(("registered-sign") "\registered-sign;")
(else "\bullet;"))))
;; ======================================================================
(define (nth-node nl k)
;; REFENTRY nth-node
;; PURP Return a specific node in a node list (by numeric index)
;; DESC
;; Returns the 'k'th node in 'nl'. The first node in the node list
;; has the index "1".
;; /DESC
;; /REFENTRY
(if (equal? k 1)
(node-list-first nl)
(nth-node (node-list-rest nl) (- k 1))))
;; ======================================================================
(define (constant-list value length)
;; REFENTRY constant-list
;; PURP Returns a list of the specified value
;; DESC
;; Return a list containing 'length' elements, each of 'value'.
;; /DESC
;; AUTHOR David Carlisle
;; EXAMPLE
;; '(constant-list 0 4)' returns '(0 0 0 0)'
;; /EXAMPLE
;; /REFENTRY
(let loop ((count (abs length)) (result '()))
(if (equal? count 0)
result
(loop (- count 1) (cons value result)))))
(define (list-head inputlist k)
;; REFENTRY list-head
;; PURP Return the head of a list
;; DESC
;; Returns the list that contains the first 'k' elements of 'inputlist'.
;; /DESC
;; EXAMPLE
;; '(list-head (1 2 3 4) 2)' returns '(1 2)'.
;; /EXAMPLE
;; /REFENTRY
(let loop ((l inputlist) (count k) (result '()))
(if (<= count 0)
result
(loop (cdr l) (- count 1) (append result (list (car l)))))))
(define (list-put vlist ordinal value #!optional (span 1))
;; REFENTRY list-put
;; PURP Replace a specific member of a list
;; DESC
;; Replaces the 'ordinal'th value of 'vlist' with 'value'. If 'span' > 1,
;; replaces 'ordinal' to 'ordinal+span-1' values starting at 'ordinal'.
;; /DESC
;; EXAMPLE
;; '(list-put (1 2 3 4 5) 2 0 2)' returns '(1 0 0 4 5)'.
;; /EXAMPLE
;; /REFENTRY
(let loop ((result vlist) (count span) (k ordinal))
(if (equal? count 0)
result
(let ((head (list-head result (- k 1)))
(tail (list-tail result k)))
(loop (append head (list value) tail) (- count 1) (+ k 1))))))
(define (decrement-list-members vlist #!optional (decr 1) (floor 0))
;; REFENTRY decrement-list-members
;; PURP Decrement each member of a list
;; DESC
;; Decrement all the values of a list by 'decr', not to fall below 'floor'.
;; ARGS
;; ARG 'vlist'
;; The list of values. All the values of this list should be numeric.
;; /ARG
;; ARG 'decr' o
;; The amount by which each element of the list should be decremented.
;; The default is 1.
;; /ARG
;; ARG 'floor' o
;; The value below which each member of the list is not allowed to fall.
;; The default is 0.
;; /ARG
;; /ARGS
;; /DESC
;; AUTHOR David Carlisle
;; EXAMPLE
;; '(decrement-list-members (0 1 2 3 4 5))' => '(0 0 1 2 3 4)'.
;; /EXAMPLE
;; /REFENTRY
(map (lambda (a)
(if (<= a (+ decr floor))
floor
(- a decr)))
vlist))
;; ======================================================================
(define (sgml-root-element #!optional (grove-node (current-node)))
;; REFENTRY
;; PURP Returns the node that is the root element of the current document
;; DESC
;; Returns the node that is the root element of the current document
;; /DESC
;; /REFENTRY
(node-property 'document-element (node-property 'grove-root grove-node)))
(define (sgml-root-element? node)
;; REFENTRY
;; PURP Test if a node is the root element
;; DESC
;; Returns '#t' if node is the root element of the current document.
;; /DESC
;; /REFENTRY
(node-list=? node (sgml-root-element node)))
;; ======================================================================
(define (length-string-number-part lenstr)
;; REFENTRY length-string-number-part
;; PURP Returns the numeric part of a length string
;; DESC
;; Given a length as a string, return the numeric part.
;; /DESC
;; EXAMPLE
;; '"100pt"' returns '"100"'. '"30"' returns '"30"'.
;; '"in"' returns '""'.
;; /EXAMPLE
;; /REFENTRY
(let ((digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.)))
(let loop ((chars (string->list lenstr))
(number-part ""))
(if (or (null? chars) (not (member (car chars) digits)))
number-part
(loop (cdr chars) (string-append number-part
(string (car chars))))))))
(define (length-string-unit-part lenstr)
;; REFENTRY length-string-unit-part
;; PURP Returns the unit part of a length string
;; DESC
;; Given a length as a string, return the units part.
;; /DESC
;; EXAMPLE
;; '"100pt"' returns '"pt"'. '"30"' returns '""'.
;; '"in"' returns '"in"'.
;; /EXAMPLE
;; /REFENTRY
(let ((number-part (length-string-number-part lenstr))
(strlen (string-length lenstr)))
(if (equal? (string-length number-part) strlen)
""
(substring lenstr (string-length number-part) strlen))))
;; ======================================================================
(define (normalize str)
;; REFENTRY normalize
;; PURP Normalize the str according to the SGML declaration in effect
;; DESC
;; Performs SGML general name normalization on the string;
;; used to compare attribute names and generic identifiers correctly
;; according to the SGML declaration in effect; this is necessary
;; since XML is case-sensitive but the reference concrete syntax and
;; many SGML DTDs are not.
;; /DESC
;; AUTHOR Chris Maden
;; /REFENTRY
(if (string? str)
(general-name-normalize str
(current-node))
str))
;; ======================================================================
(define (node-list->string nodelist)
;; REFENTRY node-2-string
;; PURP Return a string representation of the node list
;; DESC
;; Builds a string representation of the node list and returns it.
;; The representation is
;;
;; "gi(firstchildgi()secondchildgi(firstgrandchildgi())) secondgi()..."
;;
;; This is a debugging function, in case that wasn't obvious...
;; /DESC
;; /REFENTRY
(let loop ((nl nodelist) (res ""))
(if (node-list-empty? nl)
res
(loop (node-list-rest nl)
(string-append res
(if (gi (node-list-first nl))
(string-append
(gi (node-list-first nl))
"("
(node-list->string
(children (node-list-first nl)))
")")
""))))))
;; ======================================================================
(define (include-file fileref)
;; REFENTRY include-file
;; PURP Return the literal content of fileref
;; DESC
;; Opens and loads fileref with (read-entity); returns the content
;; of fileref as a (literal). Trims the last trailing newline off
;; the file so that "the right thing" happens in asis environments.
;; /DESC
;; /REFENTRY
(literal (include-characters fileref)))
;; ======================================================================
(define (include-characters fileref)
;; REFENTRY include-characters
;; PURP Return the character content of fileref
;; DESC
;; Opens and loads fileref with (read-entity); returns the content
;; of fileref as characters. Trims the last trailing newline off
;; the file so that "the right thing" happens in asis environments.
;; /DESC
;; /REFENTRY
(let* ((newline #\U-000D)
(file-content (read-entity fileref))
(file-length (string-length file-content))
;; If the last char is a newline, drop it, otherwise print it...
(content (if (equal? newline (string-ref file-content
(- file-length 1)))
(substring file-content 0 (- file-length 1))
file-content)))
content))
;; ======================================================================
(define (url-encode-char ch)
;; REFENTRY url-encode-char
;; PURP Returns the url-encoded equivalent of a character
;; DESC
;; Converts 'ch' to a properly encoded URL character.
;; /DESC
;; /REFENTRY
(cond ((char=? ch #\space) "%20") ; space
((char=? ch #\U-0026) "%26") ; ampersand
((char=? ch #\?) "%3F") ; question
((char=? ch #\{) "%7B") ; open curly
((char=? ch #\}) "%7D") ; close curly
((char=? ch #\|) "%7C") ; vertical bar
((char=? ch #\\) "%5C") ; backslash
((char=? ch #\/) "%2F") ; slash
((char=? ch #\^) "%5E") ; caret
((char=? ch #\~) "%7E") ; tilde
((char=? ch #\[) "%5B") ; open square
((char=? ch #\]) "%5D") ; close square
((char=? ch #\`) "%60") ; backtick
((char=? ch #\%) "%25") ; percent
((char=? ch #\+) "%2B") ; plus
(else (string ch))))
(define (url-encode-string str)
;; REFENTRY url-encode-string
;; PURP Returns str with all special characters %-encoded
;; DESC
;; Converts 'str' to a properly encoded URL string. Returns str unchanged
;; if it is not a string.
;; /DESC
;; /REFENTRY
(if (string? str)
(let loop ((charlist (string->list str)) (url ""))
(if (null? charlist)
url
(loop (cdr charlist)
(string-append url (url-encode-char (car charlist))))))
str))
;; ======================================================================
(define (system-id-filename target)
;; REFENTRY system-id-filename
;; PURP Returns the filename part of the system id of target
;; DESC
;; The entity-generated-system-id of target seems to begin with a
;; keyword, usually OSFILE on my system, in angle brackets.
;; This function removes the leading OSFILE bit.
;; /DESC
;; /REFENTRY
(let* ((sysid (entity-generated-system-id target))
(fnbits (split sysid '(#\>)))
(fntail (cdr fnbits)))
(join fntail "\U-0061;")))
;; ======================================================================
(define (trim-string str string-list)
;; REFENTRY trim-string
;; PURP Trims the tail off of a string
;; DESC
;; If 'str' ends with any of the strings in 'string-list', trim that
;; string off and return the base string.
;; E.g., '(trim-string "filename.sgm" '(".sgm" ".xml" ".sgml"))
;; returns "filename".
;; /DESC
;; /REFENTRY
(let ((strlen (string-length str)))
(let loop ((sl string-list))
(if (null? sl)
str
(if (equal?
(substring str (- strlen (string-length (car sl))) strlen)
(car sl))
(substring str 0 (- strlen (string-length (car sl))))
(loop (cdr sl)))))))
;; ======================================================================
(define (string-index source target)
;; REFENTRY string-index
;; PURP Finds first occurance of 'target' in 'source'
;; DESC
;; Returns the position of the first occurance of 'target' in 'source',
;; or -1 if it does not occur.
;; /DESC
;; /REFENTRY
(let loop ((str source) (pos 0))
(if (< (string-length str) (string-length target))
-1
(if (string=? (substring str 0 (string-length target)) target)
pos
(loop (substring str 1 (string-length str))
(+ pos 1))))))
;; ======================================================================
(define (parse-pi-attribute pivalues #!optional (skip #f))
(let* ((equalpos (string-index pivalues "="))
(name (substring pivalues 0 equalpos))
(quotchar (substring pivalues (+ equalpos 1) (+ equalpos 2)))
(rest (substring pivalues
(+ equalpos 2)
(string-length pivalues)))
(quotpos (string-index rest quotchar))
(value (substring rest 0 quotpos))
(morevals (strip (substring rest
(+ quotpos 1)
(string-length rest)))))
(if skip
morevals
(list name value))))
(define (parse-skip-pi-attribute pivalues)
(parse-pi-attribute pivalues #t))
(define (parse-starttag-pi pi)
;; REFENTRY parse-starttag-pi
;; PURP Parses a structured PI and returns a list of values
;; DESC
;; It has become common practice to give PIs structured values. The
;; result is a PI that looks a lot like a start tag with attributes:
;;
;; <?pitarget name1="value1" name2='value2' name3="value '3'">
;;
;; This function parses a PI with this form and returns a list. The
;; list contains the pitarget and each of the name/value pairs:
;;
;; ("pitarget" "name1" "value1" "name2" "value2" "name3" "value '3'")
;; /DESC
;; /REFENTRY
(let* ((strippi (strip pi))
(spacepos (string-index strippi " ")))
(if (< spacepos 0)
(list strippi)
(let* ((pitarget (substring strippi 0 spacepos))
(pivalues (strip (substring strippi
(+ spacepos 1)
(string-length strippi)))))
(let loop ((values pivalues) (result (list pitarget)))
(if (string=? values "")
result
(loop (parse-skip-pi-attribute values)
(append result (parse-pi-attribute values)))))))))
;; ======================================================================
(define (string->nodes s)
;; Escape XML characters...
(let* ((achars (string-replace s "&" "&#38;#38;"))
(bchars (string-replace achars "<" "&#38;#60;"))
(cchars (string-replace bchars ">" "&#38;#62;")))
(let ((doc (string-append "<literal><!DOCTYPE doc [ <!ELEMENT "
"doc - - (#PCDATA)> ]><doc>" cchars ";</doc>")))
(children (node-property 'docelem (sgml-parse doc))))))
;; ======================================================================
</style-specification-body>
</style-specification>
</style-sheet>