[DSSSL style sheet for HTML 3.2 print output
Mirrored from:
ftp://sunsite.unc.edu:/pub/sun-info/standards/dsssl/stylesheets/html3_2/html32hc.dsl.960802.  See also the README.]

<!doctype style-sheet system "style-sh.dtd">

;; ######################################################################
;;
;; DSSSL style sheet for HTML 3.2 print output
;;
;; 1996.08.02
;;
;; Jon Bosak, SunSoft, based on work by Anders Berglund, EBT,
;;    with critical assistance from James Clark
;;
;; ######################################################################


;; Features in HTML 3.2 that are not implemented in the style sheet:
;;
;;    automatic table column widths
;;    % on width attribute for TABLE
;;    attributes on TH and TD: align, valign, rowspan, colspan
;;    attributes on TABLE: width, align, border, cellspacing, cellpadding
;;    start attribute on OL
;;    value attribute on LI
;;    noshade attribute on HR
;;
;;    See also "Non-Printing Elements" below
;;
;; Features in the style sheet that are not in HTML 3.2:
;;
;;    page headers that display the HEAD TITLE content
;;    page footers that display the page number
;;    optional autonumbering of heads and table captions
;;    support for named units (pt, pi, cm, mm) in size attributes


;; ============================== UNITS ================================

(define-unit pi (/ 1in 6))
(define-unit pt (/ 1in 72))
(define-unit px (/ 1in 96))

;; see below for definition of "em"


;; =========================== PARAMETERS ==============================

;; Visual acuity levels are "normal", "presbyopic", and 
;;   "large-type"; set the line following to choose the level

(define *visual-acuity* "normal")
;; (define *visual-acuity* "presbyopic")
;; (define *visual-acuity* "large-type")

(define *bf-size*
  (case *visual-acuity*
	(("normal") 10pt)
	(("presbyopic") 12pt)
	(("large-type") 24pt)))
(define *mf-size* *bf-size*)
(define *hf-size* (- *bf-size* 1pt))

(define-unit em *bf-size*)

;; these font selections are for Windows 95

(define *title-font-family* "Arial")
(define *body-font-family* "Times New Roman")
(define *mono-font-family* "Courier New")
(define *dingbat-font-family* "Wingdings")

;; these "bullet strings" are a hack that is completely dependent on
;;    the Wingdings font family selected above; consider this a
;;    placeholder for suitable ISO 10646 characters

(define *disk-bullet* "l")
(define *circle-bullet* "¡")
(define *square-bullet* "o")
(define *small-diamond-bullet* "w")

(define *line-spacing-factor* 1.1)
(define *bf-line-spacing* (* *bf-size* *line-spacing-factor*))
(define *mf-line-spacing* (* *mf-size* *line-spacing-factor*))
(define *hf-line-spacing* (* *hf-size* *line-spacing-factor*))

(define *head-before-factor* 1.0)
(define *head-after-factor* 0.6)
(define *autonum-level* 6)       ;; zero disables autonumbering
(define *flushtext-headlevel* 4) ;; heads above this hang out on the left

(define *page-width* 8.5in)
(define *page-height* 11in)

(define *left-right-margin* 6pi)
(define *top-margin*
  (if (equal? *visual-acuity* "large-type") 7.5pi 6pi))
(define *bottom-margin*
  (if (equal? *visual-acuity* "large-type") 7.5pi 6pi))
(define *header-margin*
  (if (equal? *visual-acuity* "large-type") 4.5pi 3pi))
(define *footer-margin* 3pi)

(define *text-width* (- *page-width* (* *left-right-margin* 2)))
(define *body-start-indent* 6pi)
(define *body-width* (- *text-width* *body-start-indent*))
(define *para-sep* (/ *bf-size* 2.0))
(define *block-sep* (* *para-sep* 2.0))
(define *hsize-bump-factor* 1.2)
(define *ss-size-factor* 0.6)
(define *ss-shift-factor* 0.4)
(define *smaller-size-factor* 0.8)


;; ========================== COMMON FUNCTIONS ==========================

(define (expt b n)
  (if (= n 0)
      1
      (* b (expt b (- n 1)))))

(define upperalpha
  (list #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
	#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))

(define loweralpha
  (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
	#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))

(define (char-downcase char)
  (let loop ((c char) (a1 upperalpha) (a2 loweralpha))
       (cond ((null? a1) '())
	     ((char=? c (car a1)) (car a2))
	     ((char=? c (car a2)) c)
	     (else (loop c (cdr a1) (cdr a2))))))

(define (LOCASE slist)
  (if (null? slist)
      '()
      (cons (char-downcase (car slist)) (LOCASE (cdr slist)))))

(define (STR2LIST s)
  (let ((len (string-length s)))
    (let loop ((i 0) (ln len))
	 (if (= i len)
	     '()
	     (cons (string-ref s i) (loop (+ i 1) ln))))))

(define (STRING-DOWNCASE s)
  (apply string (LOCASE (STR2LIST s))))

(define (UNAME-START-INDEX u last)
  (let ((c (string-ref u last)))
    (if (or (member c upperalpha) (member c loweralpha))
	(if (= last 0)
	    0
	    (UNAME-START-INDEX u (- last 1)))
        (+ last 1))))

(define (PARSEDUNIT u) ;; this doesn't deal with "%" yet
 (if (string? u)
  (let ((strlen (string-length u)))
    (if (> strlen 2)
	(let ((u-s-i (UNAME-START-INDEX u (- strlen 1))))
	  (if (= u-s-i 0) ;; there's no number here
	      1pi         ;; so return something that might work
	      (if (= u-s-i strlen)           ;; there's no unit name here
		  (* (string->number u) 1px) ;; so default to pixels (3.2)
		  (let* ((unum (string->number
			       (substring u 0 u-s-i)))
			 (uname (STRING-DOWNCASE
				 (substring u u-s-i strlen))))
		    (case uname
			  (("mm") (* unum 1mm))
			  (("cm") (* unum 1cm))
			  (("in") (* unum 1in))
			  (("pi") (* unum 1pi))
			  (("pc") (* unum 1pi))
			  (("pt") (* unum 1pt))
			  (("px") (* unum 1px))
			  (("barleycorn") (* unum 2pi)) ;; extensible!
			  (else
			   (cond 
			    ((number? unum)
			     (* unum 1px))
			    ((number? (string->number u))
			     (* (string->number u) 1px))
				 (else u))))))))
        (if (number? (string->number u))
	    (* (string->number u) 1px)
	    1pi)))
    1pi))

(define (INLIST?)
  (or
    (have-ancestor? "OL")
    (have-ancestor? "UL")
    (have-ancestor? "DIR")
    (have-ancestor? "MENU")
    (have-ancestor? "DL")))

(define (HSIZE n)
  (* *bf-size*
    (expt *hsize-bump-factor* n)))

(define (OLSTEP)
  (case (modulo (length (hierarchical-number-recursive "OL")) 4)
	((1) 1.2em)
	((2) 1.2em)
	((3) 1.6em)
	((0) 1.4em)))

(define (ULSTEP) 1em)

(define (PQUAD)
  (case (attribute-string "align")
	(("LEFT") 'start)
	(("CENTER") 'center)
	(("RIGHT") 'end)
	(else (inherited-quadding))))

(define (HQUAD)
  (cond
    ((string? (attribute-string "align")) (PQUAD))
    ((have-ancestor? "CENTER") 'center)
    ((have-ancestor? "DIV") (inherited-quadding))
    (else 'start)))

(define (BULLSTR sty)
  (case sty
	(("CIRCLE") *circle-bullet*)
	(("SQUARE") *square-bullet*)
	(else *disk-bullet*)))


;; ======================= NON-PRINTING ELEMENTS ========================

;; Note that HEAD includes TITLE, ISINDEX, BASE, META, STYLE,
;;   SCRIPT, and LINK as possible children

(element HEAD (empty-sosofo))
(element FORM (empty-sosofo))
(element APPLET (empty-sosofo))
(element PARAM (empty-sosofo))
(element TEXTFLOW (empty-sosofo))
(element MAP (empty-sosofo))
(element AREA (empty-sosofo))


;; ============================ TOP LEVEL ===============================

(element HTML
 (make simple-page-sequence
       font-family-name: *body-font-family*
       font-size: *bf-size*
       line-spacing: *bf-line-spacing*
       left-header:
         (make sequence
	       font-size: *hf-size*
	       line-spacing: *hf-line-spacing*
	       font-posture: 'italic
	       (process-first-descendant "TITLE"))
       right-footer:
         (make sequence
	       font-size: *hf-size*
	       line-spacing: *hf-line-spacing*
	       (literal "Page ")
	       (page-number-sosofo))
       top-margin: *top-margin*
       bottom-margin: *bottom-margin*
       left-margin: *left-right-margin*
       right-margin: *left-right-margin*
       header-margin: *header-margin*
       footer-margin: *footer-margin*
       page-width: *page-width*
       page-height: *page-height*
       input-whitespace-treatment: 'collapse
       quadding: 'justify
       (process-children-trim)))

(element BODY
  (process-children-trim))


;; ========================== BLOCK ELEMENTS ============================


;; ............................ Generic DIV .............................

(element DIV
 (let ((align (attribute-string "align")))
  (make display-group
	quadding:
	  (case align
		(("LEFT") 'start)
		(("CENTER") 'center)
		(("RIGHT") 'end)
		(else 'justify))
	(process-children-trim))))

(element CENTER
 (make display-group
       quadding: 'center
       (process-children-trim)))


;; .............................. Headings ..............................

(define *hlist* (list "H1" "H2" "H3" "H4" "H5" "H6"))

(define (NUMLABEL hlvl)
  (let ((enl (element-number-list
	      (reverse (list-tail (reverse *hlist*) (- 6 hlvl))))))
    (let loop ((idx 1))
	 (if (or (= idx *autonum-level*) (= idx hlvl))
	     (if (= idx 2) ". " " ")
	     (let ((thisnum (list-ref enl idx)))
	       (string-append
		 (if (> idx 1) "." "")
		 (format-number thisnum "1")
		 (loop (+ idx 1))))))))

(define ($heading$ headlevel)
  (let ((headsize (if (= headlevel 6) 0 (- 5 headlevel))))
    (make paragraph
	  font-family-name: *title-font-family*
	  font-weight: (if (< headlevel 6) 'bold 'medium)
	  font-posture: (if (< headlevel 6) 'upright 'italic)
	  font-size: (HSIZE headsize)
	  line-spacing: (* (HSIZE headsize) *line-spacing-factor*)
	  space-before: (* (HSIZE headsize) *head-before-factor*)
	  space-after: (* (HSIZE headsize) *head-after-factor*)
	  start-indent: *body-start-indent*
	  first-line-start-indent:
	    (if (< headlevel *flushtext-headlevel*)
		(- *body-start-indent*)
	        0pt)
	  quadding: (HQUAD)
	  keep-with-next?: #t
	  (literal
	   (if (and (<= headlevel *autonum-level*) (> headlevel 1))
	       (NUMLABEL headlevel)
	       (string-append "")))
	  (process-children-trim))))

(element H1 ($heading$ 1))
(element H2 ($heading$ 2))
(element H3 ($heading$ 3))
(element H4 ($heading$ 4))
(element H5 ($heading$ 5))
(element H6 ($heading$ 6))


;; ............................ Paragraphs ..............................

(define p-style
  (style
   font-size: *bf-size*
   line-spacing: *bf-line-spacing*))

(element P
 (make paragraph
       use: p-style
       space-before: *para-sep*
       start-indent: *body-start-indent*
       quadding: (PQUAD)
       (process-children-trim)))

(element ADDRESS
  (make paragraph
	use: p-style
	font-posture: 'italic
	space-before: *para-sep*
	start-indent: *body-start-indent*
	(process-children-trim)))

(element BLOCKQUOTE
  (make paragraph
	font-size: (* *bf-size* *smaller-size-factor*)
	line-spacing: (* *bf-line-spacing* *smaller-size-factor*)
	space-before: *para-sep*
	start-indent: (+ *body-start-indent* 1em)
	end-indent: 1em
	(process-children-trim)))

(define ($monopara$)
  (make paragraph
	use: p-style
	space-before: *para-sep*
	start-indent: (+ *body-start-indent* 1em)
        lines: 'asis
	font-family-name: *mono-font-family*
	font-size: *mf-size*
	input-whitespace-treatment: 'preserve
        (process-children-trim)))

(element PRE ($monopara$))
(element XMP ($monopara$))
(element LISTING ($monopara$))
(element PLAINTEXT ($monopara$))

(element BR
  (make display-group
    (empty-sosofo)))


;; ................... Lists: UL, OL, DIR, MENU, DL .....................

(define ($list-container$)
 (make display-group
       space-before: (if (INLIST?) *para-sep* *block-sep*)
       space-after:  (if (INLIST?) *para-sep* *block-sep*)
       start-indent: (if (INLIST?) 
			 (inherited-start-indent)
		         *body-start-indent*)))

(define ($li-para$)
  (make paragraph
	use: p-style
	start-indent: (+ (inherited-start-indent) (OLSTEP))
	first-line-start-indent: (- (OLSTEP))
	(process-children-trim)))

(element UL ($list-container$))

(element (UL LI)
  (let ((isnested (> (length (hierarchical-number-recursive "UL")) 1)))
    (make paragraph
	  use: p-style
	  space-before:
	   (if (attribute-string "compact" (ancestor "UL")) 0 *para-sep*)
	  start-indent: (+ (inherited-start-indent) (ULSTEP))
	  first-line-start-indent: (- (ULSTEP))
	  (make line-field
		font-family-name: *dingbat-font-family*
		font-size: (if isnested *bf-size* (- *bf-size* 2pt))
		field-width: (ULSTEP)
		(literal
		  (let
		      ((litype
			(attribute-string "type"))
		       (ultype
			(attribute-string "type" (ancestor "UL"))))
		    (cond
		      (litype (BULLSTR litype))
		      (ultype (BULLSTR ultype))
		      (else (if isnested
			        *small-diamond-bullet*
			        *disk-bullet*))))))
	  (process-children-trim))))

(element (UL LI P) ($li-para$))

(element OL ($list-container$))

(element (OL LI)
 (make paragraph
       use: p-style
       space-before:
         (if (attribute-string "compact" (ancestor "OL")) 0 *para-sep*)
       start-indent: (+ (inherited-start-indent) (OLSTEP))
       first-line-start-indent: (- (OLSTEP))
       (make line-field
	     field-width: (OLSTEP)
	     (literal
 	       (case (modulo
		       (length (hierarchical-number-recursive "OL")) 4)
		     ((1) (string-append 
			   (format-number (child-number) "1") "."))
		     ((2) (string-append
			   (format-number (child-number) "a") "."))
		     ((3) (string-append
			   "(" (format-number (child-number) "i") ")"))
		     ((0) (string-append
			   "(" (format-number (child-number) "a") ")")))))
       (process-children-trim)))

(element (OL LI P) ($li-para$))

;; Note that DIR cannot properly have block children.  Here DIR is
;;   interpreted as an unmarked list without extra vertical
;;   spacing.

(element DIR ($list-container$))

(element (DIR LI)
 (make paragraph
       use: p-style
       start-indent: (+ (inherited-start-indent) (* 2.0 (ULSTEP)))
       first-line-start-indent: (- (ULSTEP))
       (process-children-trim)))

;; Note that MENU cannot properly have block children.  Here MENU is
;;   interpreted as a small-bulleted list with no extra vertical
;;   spacing.

(element MENU ($list-container$))

(element (MENU LI)
 (make paragraph
       use: p-style
       start-indent: (+ (inherited-start-indent) (ULSTEP))
       first-line-start-indent: (- (ULSTEP))
       (make line-field
	     font-family-name: *dingbat-font-family*
	     font-size: *bf-size*
	     field-width: (ULSTEP)
	     (literal "w"))
       (process-children-trim)))

;; This treatment of DLs doesn't apply a "compact" attribute set at one
;;    level to any nested DLs.  To change this behavior so that nested
;;    DLs inherit the "compact" attribute from an ancestor DL, substitute
;;    "inherited-attribute-string" for "attribute-string" in the
;;    construction rules for DT and DD.


(element DL
  (make display-group
	space-before: (if (INLIST?) *para-sep* *block-sep*)
	space-after:  (if (INLIST?) *para-sep* *block-sep*)
	start-indent: (if (INLIST?)
			  (+ (inherited-start-indent) 2em)
			  (+ *body-start-indent* 2em))
	(make paragraph)))

(element DT
  (let ((compact (attribute-string "compact" (ancestor "DL"))))
    (if compact
	(make line-field
	      field-width: 3em
	      (process-children-trim))
        (make paragraph
	      use: p-style
	      space-before: *para-sep*
	      first-line-start-indent: -1em
	      (process-children-trim)))))

(element DD
  (let ((compact (attribute-string "compact" (ancestor "DL"))))
    (if compact
	(sosofo-append
	  (process-children-trim)
	  (make paragraph-break))
        (make paragraph
	      use: p-style
	      start-indent: (+ (inherited-start-indent) 2em)
	      (process-children-trim)))))


;; ========================== INLINE ELEMENTS ===========================

(define ($bold-seq$)
  (make sequence
    font-weight: 'bold
    (process-children-trim)))

(element B ($bold-seq$))
(element EM ($bold-seq$))
(element STRONG ($bold-seq$))

;; ------------

(define ($italic-seq$)
  (make sequence
    font-posture: 'italic
    (process-children-trim)))

(element I ($italic-seq$))
(element CITE ($italic-seq$))
(element VAR ($italic-seq$))

;; ------------

(define ($bold-italic-seq$)
  (make sequence
    font-weight: 'bold
    font-posture: 'italic
    (process-children-trim)))

(element DFN ($bold-italic-seq$))
(element A ($bold-italic-seq$))

;; ------------

(define ($mono-seq$)
  (make sequence
	font-family-name: *mono-font-family*
	font-size: *mf-size*
	(process-children-trim)))

(element TT ($mono-seq$))
(element CODE ($mono-seq$))
(element KBD ($mono-seq$))
(element SAMP ($mono-seq$))

;; ------------

(define ($score-seq$ stype)
  (make score
	type: stype
	(process-children-trim)))

(element STRIKE ($score-seq$ 'through))
(element U      ($score-seq$ 'after))

;; ------------

(define ($ss-seq$ plus-or-minus)
  (make sequence
	font-size:
	  (* (inherited-font-size) *ss-size-factor*)
	position-point-shift:
	  (plus-or-minus (* (inherited-font-size) *ss-shift-factor*))
	(process-children-trim)))

(element SUP ($ss-seq$ +))
(element SUB ($ss-seq$ -))

;; ------------

(define ($bs-seq$ div-or-mult)
  (make sequence
	font-size:
	  (div-or-mult (inherited-font-size) *smaller-size-factor*)
	line-spacing:
	  (div-or-mult (inherited-line-spacing) *smaller-size-factor*)))

(element BIG ($bs-seq$ /))
(element SMALL ($bs-seq$ *))

;; ------------

(element FONT
 (let ((fsize (attribute-string "SIZE")))
  (make sequence
    	font-size:
	  (if fsize (PARSEDUNIT fsize) (inherited-font-size)))))


;; ============================== TABLES ================================

(element TABLE
	 (make display-group
	       space-before: (* *block-sep* 2)
	       space-after: (* *block-sep* 2)
	       content-map: '((caption #f))
	       (make table
		     start-indent: *body-start-indent*
		     table-border: #t
		     (make sequence
			   start-indent: 0pt))))

(element CAPTION
 (make paragraph
       label: 'caption
       use: p-style
       font-weight: 'bold
       space-before: *para-sep*
       space-after: (/ *para-sep* 2.0)
       start-indent: *body-start-indent*
       (literal
	(string-append
	 "Table "
	 (format-number
	  (element-number) "1")
	 ". "))
       (process-children-trim)))


(element TR
	 (make table-row
	       (process-children-trim)))

(element TH
 (make table-cell
       (make paragraph
	     font-weight: 'bold
	     space-before: 0.25em
	     space-after: 0.25em
	     start-indent: 0.25em
	     end-indent: 0.25em
	     quadding: 'start
	     (process-children-trim))))

(element TD
 (make table-cell
       (make paragraph
	     space-before: 0.25em
	     space-after: 0.25em
	     start-indent: 0.25em
	     end-indent: 0.25em
	     quadding: 'start
	     (process-children-trim))))


;; ============================== RULES =================================

(element HR
 (let ((align (attribute-string "ALIGN"))
       (noshade (attribute-string "NOSHADE"))
       (size (attribute-string "SIZE"))
       (width (attribute-string "WIDTH")))
  (make rule
	orientation: 'horizontal
	space-before: *block-sep*
	space-after: *block-sep*
	line-thickness: (if size (PARSEDUNIT size) 1pt)
	length: (if width (PARSEDUNIT width) *body-width*)
	display-alignment:
	  (case align
		(("LEFT") 'start)
		(("CENTER") 'center)
		(("RIGHT") 'end)
		(else 'end)))))


;; ============================= GRAPHICS ===============================

;; Note that DSSSL does not currently support text flowed around an
;;   object, so the action of the ALIGN attribute is merely to shift the
;;   image to the left or right.  An extension to add runarounds to DSSSL
;;   has been proposed and should be incorporated here when it becomes
;;   final.

(element IMG
  (make external-graphic
	entity-system-id: (attribute-string "src")
	display?: #t
	space-before: 1em
	space-after: 1em
	display-alignment:
	  (case (attribute-string "align")
		(("LEFT") 'start)
		(("RIGHT") 'end)
		(else 'center))))