;;; -*- Package: ALTER-USER; Mode: LISP; Base: 10; Syntax: Common-Lisp; -*-
(in-package "ALTER-USER")
;;; -------------------------------------------------------------------
;;; --- This Alter module defines a "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.
;;; -------------------------------------------------------------------
;;; -------------------------------------------------------------------
(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)
   (set-findent! ts (+ findent (/ 1 4)))
   (set-sindent! ts (+ sindent (/ 1 4)))
   (set-sp-before! ts 12) )

(find-operation heading-font!)
(add-method (heading-font! (font-description) self sz)
   (set-size! self sz)
   (set-bold! self #t))

;;; -------------------------------------------------------------------
;;; -------------------------------------------------------------------
;;; --- METHODS: flow-counterpart
;;; --- NOTE:    These methods produce the formatted counterpart of html-nodes.
;;; -------------------------------------------------------------------
(find-operation map-from-roadmap)

(add-method (map-from-roadmap (roadmap-structure-node) self c)
  (process-children c map-from-roadmap self))

(add-method (map-from-roadmap (roadmap-head) self c)
  (process-children c map-from-roadmap self))

(add-method (map-from-roadmap (roadmap-body) self c)
  (process-children c map-from-roadmap self))

(add-method (map-from-roadmap (roadmap-body) self c)
   (show-progress-for-each "Formatting..."
			   (lambda (e)
			     (map-from-roadmap e c))
			   (children self)))

(add-method (map-from-roadmap (roadmap-title) self c)
   (let ((c-font (current-font c)) )
     (set-sp-before! (current-style c) 24)
     (set-bold! c-font #t)
     (set-size! c-font 24)
     (start-para c)
     (process-children c map-from-roadmap self)))

(add-method (map-from-roadmap (roadmap-date) self c)
   (let ((c-font (current-font c)))
     (set-sp-before! (current-style c) 72)
     (set-bold! c-font #f)
     (set-italic! c-font #t)
     (set-size! c-font 14)
     (start-para c)
     (process-children c map-from-roadmap self)))

(add-method (map-from-roadmap (roadmap-capabilities) self c)
   (set-current-font! c (copy (default-font c))) ; restore default font
   (auto-num 0)                                 ; reset auto-numbering
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-normal) self c)
   (new-para! (current-style c))
   (start-para c)
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (sdata) self c)
   (put-string c (contents self)))

(add-method (map-from-roadmap (roadmap-heading1) self c)
   (heading-font! (current-font c) 24)
   (set-sp-before! (current-style c) 24)
   (start-para c)
   (auto-num 1)
   (put-string c (auto-num-string 1 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading2) self c)
   (heading-font! (current-font c) 18)
   (set-sp-before! (current-style c) 24)
   (start-para c)
   (auto-num 2)
   (put-string c (auto-num-string 2 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading3) self c)
   (heading-font! (current-font c) 14)
   (set-sp-before! (current-style c) 24)
   (start-para c)
   (auto-num 3)
   (put-string c (auto-num-string 3 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading4) self c)
   (heading-font! (current-font c) 12)
   (set-sp-before! (current-style c) 24)
   (start-para c)
   (auto-num 4)
   (put-string c (auto-num-string 4 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading5) self c)
   (heading-font! (current-font c) 12)
   (set-sp-before! (current-style c) 12)
   (start-para c)
   (auto-num 5)
   (put-string c (auto-num-string 5 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading6) self c)
   (heading-font! (current-font c) 12)
   (set-sp-before! (current-style c) 12)
   (start-para c)
   (auto-num 6)
   (put-string c (auto-num-string 6 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-heading7) self c)
   (heading-font! (current-font c) 12)
   (set-sp-before! (current-style c) 12)
   (start-para c)
   (auto-num 7)
   (put-string c (auto-num-string 7 "."))
   (process-children c map-from-roadmap self) )

(add-method (map-from-roadmap (roadmap-appheading) self c)
   (heading-font! (current-font c) 18)
   (set-sp-before! (current-style c) 24)
   (start-para c)
   (put-string c "Appendix: ")
   (process-children c map-from-roadmap self))

map-from-roadmap
