;;; -*- Package: ALTER-USER; Mode: SCHEME; Base: 10; Syntax: Scheme; -*-
;;; -------------------------------------------------------------------
;;; --- File:	     htmlnorm.sty
;;; --- Created:	     [jmaloney:19950526.1404CST]
;;; --- Last Update:    [jmaloney:19960110.1733CST]
;;; --- System:         DoME 4.06
;;; --- Version:        1.03
;;; ---
;;; --- This Alter module defines an example "style-sheet" to be used by
;;; --- a formatter to apply formatting to an SGML document.
;;; ---
;;; --- A style sheet defines an operation that is used when processing an
;;; --- ELEMENT.
;;; ---
;;; --- This style sheet defines the "normal" style for HTML documents.
;;; ---
;;; --- Revision History:
;;; ---
;;; --- [1] [jmaloney:19951213.1122CST]
;;; ---   Added a method for graph model to support inserting graphics 
;;; ---   of DoME models in the document.
;;; ---
;;; --- [2] [jmaloney:19951213.1124CST]
;;; ---   Made modifications to support new formatters.
;;; ---
;;; --- [3] [jmaloney:19951219.2015CST]
;;; ---   Removed use of quanitity-type.
;;; ---
;;; -------------------------------------------------------------------
(in-package "ALTER-USER")
(require 'quantity)
(require 'style)
;;; -------------------------------------------------------------------
;;; --- METHODS: numbering
;;; --- NOTE:    These methods provide auto-numbering capibility.
;;; -------------------------------------------------------------------
(find-operation auto-num)
(find-operation auto-num-string)

(letrec
 ((counter '())
  (reset (lambda () (set! counter '())))
  (n (lambda (index)
       (do ((i 0 (+ i 1))
	    (c '() (append c (if (= i index)
				 (if (>= i (length counter))
				     (list 1)
				     (list (+ (list-ref counter i) 1)))
			         (if (>= i (length counter))
				     (list 0)
				     (list (list-ref counter i)))))))
	   ((> i index) (set! counter c)))))
  (current (lambda () counter)))
 (add-method (auto-num (number-type) num)
    (if (= num 0) 
	(begin (reset) 0)
        (n (- num 1))))
 (add-method (auto-num-string (number-type) num sep)
   (let ( (r "")
	  (psep "") )
     (map (lambda (e)
	    (set! r (append r psep (number->string e)))
	    (set! psep sep))
	  counter)
     (append r " "))))
;;; -------------------------------------------------------------------
;;; -------------------------------------------------------------------
;;; --- METHODS: modify
;;; --- NOTE:    Methods to modify the state of the context
;;; -------------------------------------------------------------------
(find-operation new-para)
(add-method (new-para (text-style) ts c)
   (let ( (new-style (copy ts))
	  (nfi (+ findent (* (/ 1 4) 72)))  ; assume 72 dpi
	  (nsi (+ sindent (* (/ 1 4) 72))) )
     (set-findent! new-style nfi)
     (set-sindent! new-style nsi)
     (set-sp-before! new-style 12)
     (define-style c new-style (append "Indent" (number->string (* nsi (/ 4 72)))))
     new-style) )

(find-operation heading-font)
(add-method (heading-font (font-description) self sz)
   (let ( (new-fd (copy self)) )
     (set-size! new-fd sz)
     (set-bold! new-fd #t)
     new-fd) )
;;; -------------------------------------------------------------------
;;; -------------------------------------------------------------------
;;; --- METHODS: flow-counterpart
;;; --- NOTE:    These methods produce the formatted counterpart of html-nodes.
;;; -------------------------------------------------------------------
(find-operation flow-counterpart)
(add-method (flow-counterpart (html-node) self c)
   (process-children c flow-counterpart self) )

(add-method (flow-counterpart (list-type) self c)
   (for-each (lambda (e) (flow-counterpart e c)) self) )

(add-method (flow-counterpart (html-html) self c)
; [2]   (set-current-font! c (copy (default-font c))) ; restore default font
   (let ( (cf (default-font (current-style c)))          ; current font (cf)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-family! nf "Helvetica")         ; make the default Helvetica
     (auto-num 0)                                 ; reset auto-numbering
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )

(add-method (flow-counterpart (html-title) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 24)
     (set-sp-after! ns 24)
     (set-default-font! ns (heading-font (default-font ns) 24))
     (define-style c ns "Title")
     (start-para c)
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )
; [2]   (let ( (c-font (current-font c)) )
; [2]        (set-sp-before! (current-style c) (pt 24))
; [2]	(set-bold! c-font #t)
; [2]	(set-size! c-font (pt 24))
;	(start-para c)
;	(process-children c flow-counterpart self) ) ; [2] )
	
(add-method (flow-counterpart (html-a) self c)
   (flow-counterpart (get-id-attributes self) c)
   (process-children c flow-counterpart self)
   (flow-counterpart (get-idref-attributes self) c) )

(add-method (flow-counterpart (at) self c)
   (cond (id?           (anchor c (contents self)))
	 (idref?        (link c (contents self))) ) )

(add-method (flow-counterpart (html-p) self c)
   (let ( (cs (current-style c)) )          ; current style (cs)
     (set-current-style! c (new-para cs c)) ; style gets defined in new-para
     (start-para c)
     (process-children c flow-counterpart self)
     (set-current-style! c cs)) )

(add-method (flow-counterpart (html-h1) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 24)
     (set-withnext! ns #t)
     (set-default-font! ns (heading-font (default-font ns) 24))
     (define-style c ns "Heading 1")
; [2]   (heading-font (current-font c) (pt 24))
; [2]   (set-sp-before! (current-style c) (pt 24))
     (start-para c)
     (auto-num 1)
     (put-string c (auto-num-string 1 "."))
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-h2) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 24)
     (set-withnext! ns #t)
     (set-default-font! ns (heading-font (default-font ns) 18))
     (define-style c ns "Heading 2")
; [2]   (heading-font (current-font c) (pt 18))
; [2]   (set-sp-before! (current-style c) (pt 24))
     (start-para c)
     (auto-num 2)
     (put-string c (auto-num-string 2 "."))
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-h3) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 24)
     (set-withnext! ns #t)
     (set-default-font! ns (heading-font (default-font ns) 14))
     (define-style c ns "Heading 3")
; [2]   (heading-font (current-font c) (pt 14))
; [2]   (set-sp-before! (current-style c) (pt 24))
     (start-para c)
     (auto-num 3)
     (put-string c (auto-num-string 3 "."))
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-h4) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 24)
     (set-withnext! ns #t)
     (set-default-font! ns (heading-font (default-font ns) 12))
     (define-style c ns "Heading 4")
; [2]   (heading-font (current-font c) (pt 12))
; [2]   (set-sp-before! (current-style c) (pt 24))
     (start-para c)
     (auto-num 4)
     (put-string c (auto-num-string 4 "."))
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-h5) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 12)
     (set-withnext! ns #t)
     (set-default-font! ns (heading-font (default-font ns) 12))
     (set-italic! (default-font ns) #t)
     (define-style c ns "Heading 5")
; [2]   (heading-font (current-font c) (pt 12))
; [2]   (set-sp-before! (current-style c) (pt 24))
     (start-para c)
     (auto-num 5)
     (put-string c (auto-num-string 5 "."))
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-dl) self c)
;   (if (not (null? c))
;       (begin
; [2]	 (new-para (current-style c))
   (let ( (cs (current-style c)) ) ; current style (cs)
     (set-current-style! c (new-para cs c))
     (start-para c)
     (put-string c " ")
     (process-children c flow-counterpart self)
     (set-current-style! c cs)) )

(add-method (flow-counterpart (html-ul) self c)
;   (if (not (null? c))
;       (begin
; [2]	 (new-para (current-style c))
   (let ( (cs (current-style c))                ; current style (cs)
	  (ns (new-para (current-style c) c)) ) ; new style     (ns)
     (set-current-style! c ns)
     (start-para c)
     (put-string c " ")
     (process-children c flow-counterpart self)
     (set-current-style! c cs)) )

(add-method (flow-counterpart (html-ol) self c)
;   (if (not (null? c))
;       (begin
; [2]	 (new-para (current-style c))
   (let ( (cs (current-style c)) ) ; current style (cs)
     (set-current-style! c (new-para cs c))
     (start-para c)
     (put-string c " ")
     (process-children c flow-counterpart self)
     (set-current-style! c cs)) )

(add-method (flow-counterpart (html-dt) self c)
   (let ( (cs (current-style c))          ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 0)
     (set-withnext! ns #t)
     (let ( (df (default-font ns)) )
       (set-family! df "Courier")
       (set-underline! df #t))
; [2]   (set-family! (current-font c) "Courier")
; [2]   (set-underline! (current-font c) #t)
; [2]   (set-sp-before! (current-style c) (pt 0))
     (define-style c ns (append "Term" (number->string (* (sindent ns) (/ 4 72)))))
     (start-para c)
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-dd) self c)
   (let ( (cs (current-style c))                       ; current style (cs)
	  (ns (copy (new-para (current-style c) c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 0)
     (set-withprev! ns #t)
; [2]   (let ( (c-style (current-style c)) )
; [2]        (set-findent! c-style (add (findent c-style) (in (/ 1 4))))
; [2]	(set-sindent! c-style (add (sindent c-style) (in (/ 1 4))))
; [2]	(set-sp-before! c-style (pt 0))
     (define-style c ns (append "Definition" (number->string (* (sindent ns) (/ 4 72)))))
     (start-para c)
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-li) self c)
   (let ( (cs (current-style c))              ; current style (cs)
	  (ns (copy (current-style c))) ) ; new style     (ns)
     (set-current-style! c ns)
     (set-sp-before! ns 0)
; [2]   (set-sp-before! (current-style c) (pt 0))
     (define-style c ns "Item")
     (start-para c)
     (process-children c flow-counterpart self)
     (set-current-style! c cs) ) )

(add-method (flow-counterpart (html-i) self c)
   (let ( (cf (default-font (current-style c)))          ; current font (cs)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-italic! nf #t)
; [2]   (set-italic! (current-font c) #t)
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )

(add-method (flow-counterpart (html-b) self c)
   (let ( (cf (default-font (current-style c)))          ; current font (cs)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-bold! nf #t)
; [2]   (set-bold! (current-font c) #t)
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )

(add-method (flow-counterpart (html-tt) self c)
   (let ( (cf (default-font (current-style c)))          ; current font (cs)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-family! nf "Courier")
; [2]   (set-family! (current-font c) "Courier")
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )

(add-method (flow-counterpart (html-em) self c)
   (let ( (cf (default-font (current-style c)))          ; current font (cs)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-family! nf "Courier")
     (set-italic! nf #t)
; [2]   (set-family! (current-font c) "Courier")
; [2]   (set-italic! (current-font c) #t)
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )

(add-method (flow-counterpart (html-strong) self c)
   (let ( (cf (default-font (current-style c)))          ; current font (cs)
	  (nf (copy (default-font (current-style c)))) ) ; new font (nf)
     (set-default-font! (current-style c) nf)
     (set-family! nf "Courier")
     (set-italic! nf #t)
     (set-bold! nf #t)
; [2]   (set-family! (current-font c) "Courier")
; [2]   (set-italic! (current-font c) #t)
; [2]   (set-bold! (current-font c) #t)
     (process-children c flow-counterpart self)
     (set-default-font! (current-style c) cf) ) )


(add-method (flow-counterpart (sdata) self c)
   (put-string c (contents self)) )

(add-method (flow-counterpart (html-img) self c)  ; [1]
   (flow-counterpart source c) )

(add-method (flow-counterpart (grapething) self c)
   (let ( (cs (current-style c))
	  (ns (copy (current-style c))) )
     (set-withprev! ns #t)
     (set-current-style! c ns)
     (draw-grapething c self)
     (set-current-style! c cs) ) )

flow-counterpart
