]> ;------------------------------------------------------------ ; Plays Topic Map Style Sheet ; ; Provides pleasant formatting for the PlaysMap topic map ; document. ; ; Author: W. Eliot Kimber ; ; ; Change History: ; ; $Header$ ; ; $Log$ ; ;-------------------------------------------------------------------------- (define debug (external-procedure "UNREGISTERED::James Clark//Procedure::debug")) (define *rgb-color-space* (color-space "ISO/IEC 10179:1996//Color-Space Family::Device RGB")) (define midnight-blue-color (color *rgb-color-space* (/ 25 255) (/ 25 255) (/ 112 255))) (define blue-color (color *rgb-color-space* (/ 25 255) (/ 25 255) (/ 255 255))) (define sea-green-color (color *rgb-color-space* (/ 46 255) (/ 139 255) (/ 87 255))) (define red-color (color *rgb-color-space* (/ 255 255) (/ 0 255) (/ 0 255))) (define black-color (color *rgb-color-space* (/ 0 255) (/ 0 255) (/ 0 255))) (define white-color (color *rgb-color-space* (/ 255 255) (/ 255 255) (/ 255 255))) (define cyan-color (color *rgb-color-space* (/ 0 255) (/ 255 255) (/ 255 255))) (define yellow-color (color *rgb-color-space* (/ 255 255) (/ 255 255) (/ 0 255))) (declare-initial-value font-family-name "Helvetica") (declare-initial-value font-size 12pt) (declare-initial-value line-spacing 14pt) ;-------------------------------------------------- ; Define general-purpose functions: ;-------------------------------------------------- ;-------------------------------------------------- ; string->list: ; Convert a string into a list of characters. ; (ISO/IEC 10179:1996, clause 8.5.9.9) ; (from David Megginson) ;-------------------------------------------------- (define (string->list str) (let loop ((chars '()) (k (- (string-length str) 1))) (if (< k 0) chars (loop (cons (string-ref str k) chars) (- k 1))))) (define (list->string xs) (apply string xs)) (define (split str #!optional (whitespace '(#\space))) ; Top-level recursive loop. (let loop ((characters (string->list str)) (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 (ancestors nl) (node-list-map (lambda (snl) (let loop ((cur (parent snl)) (result (empty-node-list))) (if (node-list-empty? cur) result (loop (parent cur) (node-list cur result))))) nl)) (define (elements-with-ids idlist groveind) (let loop ((idlist idlist) (resultnl (empty-node-list))) (if (null? idlist) resultnl (loop (cdr idlist) (node-list resultnl (element-with-id (car idlist) groveind)))))) (root (make scroll start-margin: 20pt end-margin: 20pt (process-children))) (element topicmap (sosofo-append (make paragraph font-weight: 'bold quadding: 'center font-size: 18pt color: midnight-blue-color line-spacing: 20pt (literal "Topic Map")) (let ((theme (attribute-string "THEME" (current-node)))) (if theme (make paragraph font-weight: 'bold quadding: 'center font-size: 18pt color: midnight-blue-color line-spacing: 20pt space-after: 24pt (literal "Theme: ") (with-mode topic-title (process-node-list (elements-with-ids (list (attribute-string "THEME" (current-node))) (current-node))))) (empty-sosofo))) (process-children))) (element themes (sosofo-append (make rule space-before: 24pt line-thickness: 2pt) (make paragraph font-size: 16pt line-spacing: 24pt font-weight: 'bold (literal "Theme-Defining Topics")) (process-children))) (element types (sosofo-append (make rule space-before: 24pt line-thickness: 2pt) (make paragraph font-size: 16pt font-weight: 'bold (literal "Type-Defining Topics")) (process-children))) (element subjects (sosofo-append (make rule space-before: 24pt line-thickness: 2pt) (make paragraph font-size: 16pt font-weight: 'bold (literal "Subject Topics")) (process-children))) (element associations (sosofo-append (make rule space-before: 24pt line-thickness: 2pt) (make paragraph font-size: 16pt font-weight: 'bold (literal "Topic Associations")) (process-children))) (element (topic) (sosofo-append (make paragraph space-before: 24pt font-size: 14pt font-weight: 'bold color: sea-green-color (sosofo-append (literal "Topic: ") (with-mode topic-title (process-matching-children (list "name"))))) (if (attribute-string "TYPE" (current-node)) (let ((address (idref-address (attribute-string "TYPE" (current-node))))) (make paragraph start-indent: 24pt (sosofo-append (literal "Topic type(s): ") (if (address? address) (make link destination: (idref-address (attribute-string "TYPE" (current-node))) (literal (attribute-string "TYPE" (current-node)))) (literal (attribute-string "TYPE" (current-node))))))) (empty-sosofo)) (process-children))) (element occur (empty-sosofo)) (element association (sosofo-append (make paragraph font-size: 14pt font-weight: 'bold space-before: (* 2 (actual-line-spacing)) space-after: 14pt (make sequence color: sea-green-color (literal "Association, type=" (attribute-string "LINKTYPE" (current-node))))) (process-children))) (element assocrole (make paragraph (sosofo-append (make line-field field-width: 1.5in (make sequence font-weight: 'bold (literal "Association role:"))) (literal (attribute-string "ANCHROLE" (current-node))) (if (attribute-string "HREF" (current-node)) (literal ", HREF=\"" (attribute-string "HREF" (current-node)) "\"") (empty-sosofo))))) (element p (make paragraph space-before: (actual-line-spacing) (process-children))) (default (process-children)) (mode topic-title (element name (if (first-sibling? (current-node)) (process-children) (sosofo-append (literal ", ") (process-children)))) (element topic (process-children)) (element desc (empty-sosofo)) (element basename (process-children)) (element displayname (empty-sosofo)) (element sortname (empty-sosofo)))