diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/ChangeLog | 36 | ||||
| -rw-r--r-- | lib/dblib.dsl | 1858 |
2 files changed, 1894 insertions, 0 deletions
diff --git a/lib/ChangeLog b/lib/ChangeLog new file mode 100644 index 0000000..a521bda --- /dev/null +++ b/lib/ChangeLog @@ -0,0 +1,36 @@ +2004-10-24 <petere78@users.sourceforge.net> + + * dblib.dsl: Revision 1.6 completely broke PI processing, so back that out for now. + +2003-04-29 Adam Di Carlo <adicarlo@users.sourceforge.net> + + * dblib.dsl: Fix my-debug so it actually returns what you ask it to. + +2003-04-28 Adam Di Carlo <adicarlo@users.sourceforge.net> + + * dblib.dsl: Make PI parsing more robust by rewriting parse-pi-attribute and a fix + in parse-starttag-pi. I'm still not entirely happy with the PI + parsing, its probably a little flakey, but it shouldn't completely + bail out when it hits data its not expecting. Closes Debian Bug#186886. + +2003-04-26 Adam Di Carlo <adicarlo@users.sourceforge.net> + + * dblib.dsl: Fix a typo in the param docs + +2003-04-05 Adam Di Carlo <adicarlo@users.sourceforge.net> + + * dblib.dsl: xsl stylesheet refers to pica as "pc" rather than "pi", so we allow + either one as a pica + +2002-05-12 Norman Walsh <nwalsh@users.sourceforge.net> + + * dblib.dsl: Bugs #429663 and #474328 fixed (allow external linespecific content to be indented and numbered). Eight bit or unicode external linespecific content may be problematic though. + +2001-07-10 Norman Walsh <nwalsh@users.sourceforge.net> + + * dblib.dsl: Bug fix: (strip) was returning the empty string for any string one character long + +2001-04-02 Norman Walsh <nwalsh@users.sourceforge.net> + + * dblib.dsl: New file. + diff --git a/lib/dblib.dsl b/lib/dblib.dsl new file mode 100644 index 0000000..a896cb2 --- /dev/null +++ b/lib/dblib.dsl @@ -0,0 +1,1858 @@ +<!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> |