;; -*- Scheme -*-
;;
;; parameter-build.scm
;; -- make parameter from spec
;;
;; -- print objects and cr.
(define (print . x)
(map (lambda (e) (write e)(display " ")) x)
(newline))
(define (warn . x)
(map (lambda (e) (display e)(display " ")) x)
(newline))
;; ------------------------------------------------
;; Memorize a formation result in *results*.
;; ------------------------------------------------
(define *results* '())
(define (add-result x) (set! *results* (append *results* (list x))))
;; ------------------------------------------------
;; norm-unit : normalize unit inspec
;; Unify the treatment of scheme into 'mm'
;; because unit during the description can't
;; be interpreted unlike the DSSSL treatment.
;; The one without unit is handled with mm.
;; (Though the basis unit of DSSSL is meter,
;; it isn't understood easily that it is
;; unified with meter.)
;; ------------------------------------------------
;;-- Reference 4.3
(define (Q->pt num) ;; the conversion function which makes Q cope with pt
(case num
((7) 5) ((8) 5.5) ((9) 6) ((10) 7) ((11) 7.5)
((12) 8) ((13) 9) ((14) 10) ((15) 10.5) ((16) 11)
((18) 12) ((20) 14) ((21) 15) ((24) 16) ((26) 18.5) ((28) 20)
(else (* num (/ 0.25 0.3514)))))
(define (get-unit- nul)
;; devide char list into num and unit. used in norm-unit
;; ex) (string->list "13.5mm") --> ((#ｴ1 #ｴ3 #ｴ. #ｴ5 #ｴm #ｴm))
(if (memq (car nul) '(#ｴ0 #ｴ1 #ｴ2 #ｴ3 #ｴ4 #ｴ5 #ｴ6 #ｴ7 #ｴ8 #ｴ9 #ｴ.))
(let ((g (get-unit- (cdr nul))))
(cons (cons (car nul)(car g)) (cdr g)))
(list '() nul)))
(define (rm-unit- str org)
(let* ((x (get-unit- (string->list str)))
(num (string->number (list->string (car x))))
(unit (list->string (cadr x))))
(cond ((eqv? num #f) org) ;; no number part
((string=? unit "mm") num) ;; It normalizes completely in mm.
((string=? unit "cm") (* num 10.0))
((string=? unit "in") (* num 25.4))
; It is 0.3514 times because it is being converted
; into mm after it is changed into pt from the unit Q.
((string=? unit "Q") (* (Q->pt num) 0.3514))
((string=? unit "q") (* (Q->pt num) 0.3514))
;; 1/72 inch(American inch) is follow.
;; ((string=? unit "pt") (* num (/ 25.4 72)))
;; A point is made "1pt = 0.3514".
((string=? unit "pt") (* num 0.3514))
((string=? unit "pica") (* num 4.233333))
(else (warn "warning : norm-unit : unknown unit name : "
unit)
num))))
;; An expression with the unit is normalized with mm.
(define (norm-unit num_w_unit)
(cond ((number? num_w_unit)
num_w_unit)
((symbol? num_w_unit)
(rm-unit- (symbol->string num_w_unit) num_w_unit))
((string? num_w_unit)
(rm-unit- num_w_unit num_w_unit))))
;; The function that mm makes numerical value stuck.
(define (mm x)
(cond ((null? x) '())
((number? x) (string->symbol (string-append
(number->string x) "mm")))
((list? x) (cons (mm (car x))(mm (cdr x))))
(else x)))
;; A function to change into pt only targeting Q.
(define (norm-pt x)
(let ((QtoPT
(lambda (s x)
(let* ((ul (get-unit- (string->list s)))
(num (string->number (list->string (car ul))))
(unit (list->string (cadr ul))))
(cond ((eqv? num #f) x) ;; no number part
((string=? unit "Q")
(string->symbol (string-append
(number->string (Q->pt num))
"pt")))
(else x))))))
(cond ((null? x) '())
((list? x) (cons (norm-pt (car x))(norm-pt (cdr x))))
((symbol? x)
(QtoPT (symbol->string x) x))
((string? x)
(QtoPT x x))
(else x))))
; The function which makes numerical value an expression to have about the unit pt.
; It is added to 1999.
(define (pt x)
(cond ((null? x) '())
((number? x) (string->symbol (string-append (number->string x) "pt")))
((list? x)(cons (pt (car x))(pt (cdr x))))
(else x)))
; The conversion of only the numerical value to the pt unit from the mm unit.
; It is added to 1999.
(define (mm->pt x)
(round (/ x 0.3514)))
;; ------------------------------------------------
;; determine-paper-size :
;; The decision of *page-width* *page-height*.
;; ------------------------------------------------
(define *paper-size-list* ;; -- Reference 4.1
;; paper name X mm Y mm ; X inch Y inch
'(("11x17" (279.4 431.8) ) ; (11 17)
("a0" (839.611 1188.16)) ; (33.0556 46.7778)
("a1" (594.078 839.611)) ; (23.3889 33.0556)
("a2" (419.806 594.078)) ; (16.5278 23.3889)
("a3" (297.039 419.806)) ; (11.6944 16.5278)
("a4" (209.903 297.039)) ; (8.26389 11.6944)
("a5" (148.519 209.903)) ; (5.84722 8.26389)
("a6" (104.775 148.519)) ; (4.125 5.84722)
("a7" (74.0833 104.775)) ; (2.91667 4.125)
("a8" (52.2111 74.0833)) ; (2.05556 2.91667)
("a9" (37.0417 52.2111)) ; (1.45833 2.05556)
("a10" (26.1056 37.0417)) ; (1.02778 1.45833)
("b0" (1000.48 1413.93)) ; (39.3889 55.6667)
("b1" (706.967 1000.48)) ; (27.8333 39.3889)
("b2" (500.239 706.967)) ; (19.6944 27.8333)
("b3" (353.483 500.239)) ; (13.9167 19.6944)
("b4" (250.119 353.483)) ; (9.84722 13.9167)
("b5" (176.742 250.119)) ; (6.95833 9.84722)
("flsa" (215.9 330.2) ) ; (8.5 13)
("flse" (215.9 330.2) ) ; (8.5 13)
("halfletter" (139.7 215.9) ) ; (5.5 8.5)
("ledger" (431.8 279.4) ) ; (17 11)
("legal" (215.9 355.6) ) ; (8.5 14)
("letter" (215.9 279.4) ) ; (8.5 11)
("note" (190.5 254.0) ) ; (7.5 10)
;; ....
))
(define (get-paper-size paper_name)
(assoc paper_name *paper-size-list*))
(define (determine-paper-size spec)
(let ((pn (assoc '*paper-name* spec))
(dir (assoc '*paper-direction* spec))
(flow-dir (assoc '*writing-direction* spec))
(w (assoc '*paper-width* spec))
(h (assoc '*paper-height* spec)))
(if w (set! w (norm-unit (cadr w))))
(if h (set! h (norm-unit (cadr h))))
(if (and (not (and w h)) pn)
(let* ((pnn (cadr pn))
(xy (assoc pnn *paper-size-list*)))
(if xy
(begin
(set! xy (cadr xy))
(if (and dir (string=? "landscape" (cadr dir)))
(begin
(if (not w) (set! w (cadr xy)))
(if (not h) (set! h (car xy))))
(begin
(if (not w) (set! w (car xy)))
(if (not h) (set! h (cadr xy))))))
(warn "unknown paper name.")
)))
(if (not (and w h))
(determine-paper-size (cons '(*paper-name* "a4") spec))
(begin
(if pn
(set! pn (cadr pn))
(set! pn "none"))
(add-result `(define *paper-name* ,pn))
(if dir
(set! dir (cadr dir))
(set! dir "portrait"))
(add-result `(define *paper-direction* ,dir))
(if flow-dir
(set! flow-dir (cadr flow-dir))
(set! flow-dir "horizontal"))
(add-result `(define *writing-direction* ,flow-dir))
(add-result `(define *paper-width* ,(mm w)))
(add-result `(define *paper-height* ,(mm h)))
(list w h pn dir flow-dir)
))))
;; ------------------------------------------------
;;
;; How to put a standard such as a book by the edition type together.
;; (Only a side set writes landscape with a4r and so on.)
;; It is amended in 1999. Default value is established.
;;
(define *standard-composition-list*
'(; type paper-direct writing-mode colomn-n
("43-14" (9pt 43 14 18pt 0))
("43-15" (9pt 43 15 18pt 0))
("43-16" (9pt 43 16 17pt 0))
("44-17" (9pt 44 17 16pt 0))
("50-18" (8pt 50 18 15pt 0))
("50-19" (8pt 50 19 14pt 0)))
(("b6" "portrait" "vertical" 2)
("25-20" (8pt 25 20 14pt 2))
("26-20" (8pt 26 20 14pt 2)))
(("b6" "portrait" "horizontal" 1)
("30-23" (9pt 30 23 17pt 0))
("33-25" (8pt 33 25 16pt 0))
("33-27" (8pt 33 27 15pt 0))
("34-27" (8pt 34 27 15pt 0)))
(("b5" "portrait" "vertical" 1)
("24-31" (8pt 24 31 13pt 0)))
(("b5" "portrait" "horizontal" 1)
("43-32" (9pt 43 32 18pt 0))
("regular" (13Q 42 31 26Q 0)))
(("b5" "portrait" "horizontal" 2)
("23-44" (9pt 23 44 14pt 2))
("22-41" (9pt 22 41 15pt 2))
("25-51" (8pt 25 51 12pt 2))
("regular " (13Q 22 43 20Q 2))
("wide" (13Q 21 39 22Q 2))
("small" (12Q 23 48 18Q 2)))
(("a6" "portrait" "vertical" 1)
("41-13" (8pt 41 13 17pt 0))
("41-14" (8pt 41 14 16pt 0))
("41-15" (8pt 42 15 15pt 0))
("42-13" (8pt 42 13 16pt 0))
("42-14" (8pt 42 14 16pt 0))
("42-15" (8pt 42 15 15pt 0))
("43-15" (8pt 43 15 15pt 0))
("43-16" (8pt 43 16 14pt 0))
("43-18" (8pt 43 18 13pt 0))
("43-19" (8pt 43 19 13pt 0)))
(("a5" "portrait" "vertical" 1)
("51-16" (9pt 51 16 18pt 0))
("52-16" (9pt 52 16 18pt 0))
("52-17" (9pt 52 17 18pt 0))
("52-18" (9pt 52 18 17pt 0))
("52-19" (9pt 52 19 17pt 0)))
(("a5" "portrait" "vertical" 2)
("25-20" (9pt 25 20 15pt 2))
("30-24" (8pt 30 24 13pt 2))
("29-23" (8pt 29 23 14pt 2)))
(("a5" "portrait" "horizontal" 1)
("35-26" (9pt 35 26 18pt 0))
("35-28" (9pt 35 28 17pt 0))
("35-30" (9pt 35 30 16pt 0))
("40-30" (8pt 40 30 16pt 0))
("38-33" (8pt 38 33 14pt 0))
("regular" (13Q 34 27 25Q 0))
("narrow" (13Q 34 29 23Q 0))
("small" (12Q 37 28 24Q 0))
("narrow-small" (12Q 36 31 21Q 0)))
;; The next a4 is not the standard value that is general but a reference.
(("a4" "portrait" "horizontal" 1)
("regular" (13Q 51 41 24Q 0))
("narrow" (14Q 48 39 25Q 0)))
(("a4" "portrait" "horizontal" 2)
("regular" (14Q 24 42 23Q 2)))
(("a4" "portrait" "horizontal" 3)
("regular" (14Q 16 42 23Q 2)))
))
;; The next function thinks about a party direction only by the lateral writing.
(define (calc-xx cn xx fd)
(let ((fs (norm-unit (car xx)))
(num (norm-unit (cadr xx)))
(ln (norm-unit (caddr xx)))
(lw (norm-unit (cadddr xx)))
(cs (cddddr xx)))
(if (= (length cs) 0)
(set! cs 0) ;; if cs is omitted
(set! cs (car cs)))
(let ((rw (+ (* cn num fs) (* (- cn 1) cs fs)))
(rh (* ln lw)))
(if (string=? fd "horizontal")
(list rw rh)
(list rh rw)) )))
(define (get-sc pn dir flow-dir cn sc)
(let ((e (list pn dir flow-dir cn))(ret #f))
(set! ret (assoc e *standard-composition-list*))
(if ret
(begin
(set! ret(cdr ret))
(set! ret (assoc sc ret))
(if ret
(cadr ret) ;; return xx
#f))
#f)))
;; The function that *page-spec* is formed forcibly when or value is wrong
;; that *standard-composition* isn't being given to it.
;; It is added to 1999.
(define (get-xx pn dir flow-dir cn )
(let ((e (list pn dir flow-dir cn))
(ret #f)
(sc "default"))
(set! ret (assoc e *standard-composition-list*))
(if ret
(begin
(set! ret (cdr ret))
(set! ret (car ret))
(cadr ret))
#f)))
(define (determine-regionsize ps spec)
(let (
(w (car ps))
(h (cadr ps))
(pn (caddr ps))
(dir (cadddr ps))
(flow-dir (cadddr (cdr ps)))
(cn (assoc '*column-number* spec))
(xx (assoc '*page-spec* spec)) ;; (FontSZ Letters Lines Feeds Colomn space)
(rw (assoc '*page-region-width* spec))
(rh (assoc '*page-region-height* spec))
(sc (assoc '*standard-composition* spec))
(fs (assoc '*base-font-size* spec))
(xr (assoc '*area-x-ratio* spec))
(yr (assoc '*area-y-ratio* spec))
(xroff (assoc '*page-region-x-offset* spec))
(yroff (assoc '*page-region-y-offset* spec))
(x-off 0)
(y-off 0)
)
(if fs (set! fs (cadr fs)))
(if cn (set! cn (cadr cn)))
(if (not (number? cn)) (set! cn 1))
(if rw (set! rw (norm-unit (cadr rw))))
(if rh (set! rh (norm-unit (cadr rh))))
(if sc (set! sc (cadr sc)))
(if xx (set! xx (cadr xx)))
;;;; To quote the table for which to become a standard here.
;;
;; (1) Column set ＋ *page-region-width*/*page-region-height*
;;
;; (2) Column set ＋ (x x x x x)
;;
;; (3) Paper size/direction
;; writing-mode ＋ *standard-composition*
;; Colomn set
;;
;; The combination of either one is necessary. (The order of priority of (1) is high.)。
;;
;; The Colomn set number is supposed to be single-column-set (*column-number* == 1)
;; without being.
(if (and (not xx) sc) (set! xx (get-sc pn dir flow-dir cn sc)))
(if xx
(begin
(set! xx (norm-pt xx))
(let ;; pattern (2) or (3)
((ret (calc-xx cn xx flow-dir)))
(if ret
(begin
(if (not rw) (set! rw (car ret)))
(if (not rh) (set! rh (cadr ret)))
)))))
(if cn (add-result `(define *column-number* ,cn)))
(if xx (add-result `(define *page-spec* ',xx)))
(if sc (add-result `(define *standard-composition* ,sc)))
;; The function is decided forcibly when region height/width isn't decided.
;; In 1999, modification on addition.
(if (not rw)
(begin
(warn "no region width.")
(set! rw (* w 0.8))))
(if (not rh)
(begin
(warn "no region height.")
(set! rh (* h 0.8))))
(add-result `(define *page-region-width* ,(mm rw)))
(add-result `(define *page-region-height* ,(mm rh)))
(if (not xx)
(begin
(set! xx (get-xx pn dir flow-dir cn))
(if sc (warn "*standard-composition* error"))
(if xx
(begin
(add-result `(define *page-spec* ,xx))
(warn "default *page-spec*"))
(add-result `(undefine *page-spec* #f)))))
;;;;;;;;; Edition side position.
;;
;; It is used by the edition side position when *page-region-x-offset* /
;; *page-region-y-offset* is being given to it specifically.
;; When it is not so, it is calculated as a thing given to it in the ratio
;; by *area-x-ratio* / *area-y-ratio*.
;; The ratio 0.5 is made default when either isn't being given to it.
;;
(if (not xr) (set! xr 0.5))
(if (not yr) (set! yr 0.5))
(add-result `(define *area-x-ratio* ,xr))
(add-result `(define *area-y-ratio* ,yr))
(if xroff
(set! x-off xroff)
(set! x-off (* (- w rw) xr)))
(if yroff
(set! y-off yroff)
(set! y-off (* (- h rh) yr)))
(add-result `(define *page-region-x-offset* ,(mm x-off)))
(add-result `(define *page-region-y-offset* ,(mm y-off)))
(if (not fs) (if xx (set! fs (car xx))))
(if fs (determine-font-size fs spec))
(list x-off y-off)
))
(define (assoc-value e l)
(let ((ret (assoc e l)))
(if ret (cdr ret) ret)))
;;
;; Headline character size calculation
;;
;; -- reference 4.19
(define *default-font-table*
'( (("a5" "portrait" "vertical" (9pt))
(s 0 (large 14pt 4 4) (medium 12pt 6 3) (small 10pt 7 2))
(lms 1 (large 14pt 4 3) (medium 12pt 6 2) (small 10pt 7 2))
(lm 1 (large 14pt 4 2) (medium 12pt 6 3))
(ls 1 (large 14pt 4 3) (small 10pt 7 2))
(ms 1 (medium 12pt 6 2) (small 10pt 7 2))
(n 2))
(("a5" "portrait" "horizontal" (9pt 8pt))
(s 0 (large 14pt 'c 4) (medium 12pt 'c 3) (small 10pt 'c 2))
(lms 1 (large 14pt 'c 3) (medium 12pt 'c 2) (small 10pt 'c 2))
(lm 1 (large 14pt 'c 2) (medium 12pt 'c 3))
(ls 1 (large 14pt 'c 3) (small 10pt 'c 2))
(ms 1 (medium 12pt 'c 2) (small 10pt 'c 2))
(n 2))))
; The function that *font-table* of the default is computed.
; It is modified in 1999.
(define (determine-font-size fs flow-dir spec)
(if fs (add-result `(define *base-font-size* ,fs)))
(let ((jtm (assoc '*font-table* spec)))
(if jtm
(add-result `(define *font-table* ',jtm))
; To make it easy to handle later, "vertial". "horizontal" is judged,
; and *font-table* of the default is returned.
(begin
(if (string=? flow-dir "vertical")
(set! jtm (cdr (list-ref *default-font-table* 0)))
(set! jtm (cdr (list-ref *default-font-table* 1))))
(add-result `(define *font-table*',jtm)))
))) ;; --- need to fix .....
;; The items/chapter number/footnote number description of the default.
(define *default-footnote-number-desc*
'(#f #f "" "" ")")
)
(define *default-enum-number-desc*
'(((1) #f "(" "" ")") ;; (1)
((2) 'ABC "" "" ".") ;; A.
((3) 'abc "" "" ")") ;; a)
))
(define *default-title-number-desc*
'(((1) #f "第" "." "章") ;; 第１章
((2) #f "" "." "節") ;; 1.1
((3) #f "" "." "項") ;; 1.1.1
((n) #f "" "." "")) ;; 1.1.1.1
)
(define (check-other-defs spec)
(let ((rubi-f (assoc-value '*rubi-font-size-factor* spec))
(subs-f (assoc-value '*subscript-font-size-factor* spec))
(sups-f (assoc-value '*superscript-font-size-factor* spec))
(bfw (assoc-value '*base-font-weight* spec))
(bfp (assoc-value '*base-font-posture* spec))
(bff (assoc-value '*base-font-family* spec))
; (tff (assoc-value '*title-font-family* spec))
(findf (assoc-value '*jisage-factor* spec))
(indf (assoc-value '*indent-factor* spec))
(hhn (assoc-value '*has-header-nonburu* spec))
(hhh (assoc-value '*has-header-hasira* spec))
(hfn (assoc-value '*has-footer-nonburu* spec))
(hfh (assoc-value '*has-footer-hasira* spec))
(hr (assoc-value '*hasira-rect* spec))
(hv (assoc-value '*hasira-verso* spec))
(fs (assoc-value '*footnote-style* spec))
(fe (assoc-value '*footnote-exp* spec))
(fn-nd (assoc-value '*footnote-number-desc* spec))
(en-nd (assoc-value '*enum-number-desc* spec))
(tt-nd (assoc-value '*title-number-desc* spec))
)
(add-result `(define *rubi-font-size-factor* ,(if rubi-f (car rubi-f) 0.5)))
(add-result `(define *subscript-font-size-factor*
,(if subs-f (car subs-f) 0.3)))
(add-result `(define *superscript-font-size-factor*
,(if sups-f (car sups-f) 0.3)))
(add-result `(define *base-font-weight*
',(if bfw (car bfw) 'medium)))
(add-result `(define *base-font-posture*
',(if bfp (car bfp) 'upright)))
(add-result `(define *base-font-family*
',(if bff (car bff) "mincho-light,sans-medium"))) ;; The default of the font name.
; (add-result `(define *title-font-family*
; ',(if tff (car tff) "gochic-light,times-medium"))) ;; The default of the font name.
(add-result `(define *jisage-factor*
,(if findf (car findf) 1))) ;; The number of the characters
;; that a letter is indented in the beginning of the paragraph.
(add-result `(define *indent-factor*
,(if indf (car indf) 2))) ;; The number of the characters that a letter is indented.
(add-result `(define *has-header-nonburu* ,(if hhn (car hhn) #t)))
(add-result `(define *has-header-hasira* ,(if hhh (car hhh) #t)))
(add-result `(define *has-footer-nonburu* ,(if hfn (car hfn) #f)))
(add-result `(define *has-footer-hasira* ,(if hfh (car hfh) #f)))
(add-result `(define *hasira-rect* ,(if hr (car hr) " ")))
(add-result `(define *hasira-verso* ,(if hv (car hv) " ")))
(add-result `(define *footnote-exp* ,(if fe (car fe) "[]")))
(add-result `(define *footnote-number-desc*
,(if fn-nd (car fn-nd)
*default-footnote-number-desc*)))
(add-result `(define *enum-number-desc*
,(if en-nd (car en-nd)
*default-enum-number-desc*)))
(add-result `(define *title-number-desc*
,(if tt-nd (car tt-nd)
*default-title-number-desc*)))
))
;;
;; top function
;;
(define (build-page page-spec)
; (set! *results* '())
(set! *results* '( ;; It is defined in advance, of the spider.
(define-unit Q 0.25mm)
(define-unit pt 0.3514mm)
;(define-unit pi (/ 1in 6))
;(define-unit pt (/ 1in 72))
;(define-unit px (/ 1in 96))
))
(let* ((wh (determine-paper-size page-spec)))
(determine-region size wh page-spec)
(check-other-defs page-spec)
*results*
))
;(define (r) (pp *results*))
(define (r)
(let loop ((rs *results*))
(cond ((null? rs) #t)
(else
(print (car rs))
(loop (cdr rs))))))
;;;;; sample
;
(define page-spec
'(
(*paper-name* "b5")
(*paper-direction* "portrait") ;; "landscape" / "portrait"
(*standard-composition* "standard")
(*column-number* 1)
))
;
(build-page page-spec)
(r)
;
.
;
;; -*- Scheme -*-
;; Amended Functions.dsl
;
; Numbering Functions for section and footnote
;
(define (char-repeat sym num)
(string-append (char-repeat sym (- num 1)) sym))
(define (num->alpha num)
(substring " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
num (+ num 1)))
(define (num->alphaCAP num)
(substring " ABCDEFGHIJKLMNOPQRSTUVWXYZ"
num (+ num 1)))
(define (num->kanji num) ;; Assume max 2 digit.
(if (> num 10)
(string-append (if (= (quotient num 10) 1)
""
(num->kanji (quotient num 10)))
"十"
(num->kanji (remainder num 10)))
(case num
((0) "") ((1) "一") ((2) "二") ((3) "三") ((4) "四") ((5) "五")
((6) "六") ((7) "七") ((8) "八") ((9) "九") ((10) "十"))))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Roma numbering function
(define (num->roma num)
(format-number num "i"))
(define (make-num n exp)
(case exp
(('abc) (num->alpha n))
(('ABC) (num->alphaCAP n))
(('kanji) (num->kanji n))
(('roma) (num->roma n))
; (('hira) (num->hira n))
; (('kata) (num->hira n))
; (('iroha-hira) (num->hira n))
; (('iroha-kata) (num->hira n))
(('asterisk) (char-repeat "*" n))
(('dag) (char-repeat "†" n)) ; Dag, ddag, P, S and Vert follow TeX.
(('ddag) (char-repeat "‡" n))
(('P) (char-repeat "¶" n))
(('S) (char-repeat "§" n))
(('Vert) (char-repeat "‖" n))
(('sharp) (char-repeat "#" n))
(else (number->string n))
))
(define (make-numbering nl desc)
(if (equal? #f desc)
(make-numbering nl *title-number-desc*)
(letrec ((num-member
(lambda (e l)
(cond ((not(list? l)) #f)
((member e l) #t)
((eq? 'nl (car (reverse l)))
(let* ((ll (reverse (cdr (reverse l)))))
(if (> (length ll) 0)
(> e (apply max ll))
#t)))
(else #f))))
(match-level
(lambda (level desc)
(cond ((null? desc) #f)
((not (list? (car desc))) desc)
((not (list? (caar desc))) (car desc)) ; non-list
((num-member level (caar desc)) (car desc))
(else (match-level level (cdr desc)))
)))
(make-infix
(lambda (nl num infix)
; (cond ((eqv? 'last infix) amendment200x
(cond ((or (eqv? 'last infix) (eqv? "" infix)) ;amendment2000
(make-num (car (reverse nl)) num))
((null? (cdr nl))
(make-num (car nl) num))
(else
(string-append
(make-num (car nl) num)
infix
(make-infix (cdr nl) num infix)))))))
(cond ((number? nl) (make-numbering (list nl) desc))
((not (list? nl)) "")
((not (list? desc)) "")
((match-level (length nl) desc)
; => (lambda (d) am..200x
(let ((d (match-level (length nl) desc))) ;am..2000
(string-append
(caddr d) ;; pre
(make-infix nl (cadr d)(cadddr d))
(cadddr (cdr d)) ;; post
)))
(else "")))))
;; Paragraph ? Define only style not function
(define *paragraph-style* ;; Base set of paragraph
(style
font-size: *base-font-size*
font-weight: *base-font-weight*
font-posture: *base-font-posture*
font-family-name: *base-font-family*
line-spacing: (cadddr *page-spec*)
quadding: 'start ;; Left alignment.
))
(define *fli-paragraph-style* ;; Indented paragraph
(style
use: *paragraph-style*
first-line-start-indent: (* *base-font-size* *jisage-factor*)
))
(define *indent-step*
(* *base-font-size* *indent-factor*))
;; Head line/Page number
;; - See PAGE-HEADER and PAGE-FOOTER. Here is only style.
(define *header-footer-style*
(style
use: *paragraph-style*
font-size: (* *base-font-size* 1.0)
line-spacing: (* (cadddr *page-spec*) 1.0)
;;font-posture: 'italic
))
;; Footnote
(define *footnote-style*
(style
use: *paragraph-style*
font-size: (* *base-font-size* 1.0)
line-spacing: (* (cadddr *page-spec*) 1.0)
))
;; Jidori
(define (jidori n)
(make line-field
field-width: (* *base-font-size* n) ;; n jidori
(make paragraph
quadding: 'justify
last-line-quadding: 'justify
(process-children))))
;; Caption
;;; Caption's paragraph definition is not eazy. Ready node count function.
(define (GET-MIDASHI-NUMS node-list)
; (make-numbering (element-number-list node-list))) am..200x
(make-numbering (element-number-list node-list) #f)) ;am..2000
;; Ruby
;;;;;;; improvement.200x (glyph-annotation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (RUBI)
; (make glyph-annotation improvement.200x
; annotation-glyph-placement: 'centered
; annatation: (process-matching-children 'yomi)
; (process-children)))
;
;(define (YOMI . f)
; (let ((factor (if (null? f) *rubi-font-size-factor* (car f))))
; (make paragraph
; font-size: (* (inherited-font-size) factor)
; (process-children))))
;;;;;; am..2000 (glyph-annotation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (YOMI)
(sosofo-append
(literal "(")
(process-children)
(literal ")")))
;; Inferior
; Using the period allow to omitt the argument.
; But the processer does not adapt to the syntax.
;(define (SUBSCRIPT . f) am..200x
(define (SUBSCRIPT f) ;am..2000
(let ((factor (if (null? f) *subscript-font-size-factor* (car f))))
(make math-sequence
math-display-mode: 'inline
(make subscript
font-size: (* (inherited-font-size) factor)
(process-children)))))
;(define (SUPERSCRIPT . f) am..200x
(define (SUPERSCRIPT f) ;am..2000
(let ((factor (if (null? f) *superscript-font-size-factor* (car f))))
(make math-sequence
math-display-mode: 'inline
(make superscript
font-size: (* (inherited-font-size) factor)
(process-children)))))
;; Underline
(define (UNDERLINE)
(make score
type: 'after
(process-children)))
;; Cuttingnote
;;;;;; improvement.200x (multi-line-inline-node) ;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (WARICHUU)
; (make multi-line-inline-node ;; see ISO/IEC10179 12.6.24 improvement.200x
; (process-children)))
;; Emphasized mark
;;;;;; improvement.200x (emphasizing-mark) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (KENTEN)
; (make emphasizing-mark ;; see ISO/IEC10179 12.6.25 improvement.200x
; mark: (literal "・")
; (process-children)))
;; Typeface
(define (BOLD-SEQ)
(make sequence
font-weight: 'bold
(process-children)))
(define (ITALIC-SEQ)
(make sequence
font-posture: 'italic
(process-children)))
(define (BOLD-ITALIC-SEQ)
(make sequence
font-weight: 'bold
font-posture: 'italic
(process-children)))
(define (STRIKE-SEQ)
(make score
type: 'through
(process-children)))
;; Itemize
(define (MAKE-ENUM-EXP nul)
(make-numbering nul *enum-number-desc*))
;;;;;;; am..200x ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (LIST-CONTAINER)
; (make display-group
; ;space-before:
; ;space-after:
; start-indent: (inherit-start-indent)
;))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (LIST-CONTAINER)
(make display-group
;space-before:
;space-after:
start-indent: (+ (inherited-start-indent) (* *indent-factor* *base-font-size*))
))
;;;;;;; am..200x ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (LIST-ELEMENT lhead) ;; lhead -- list head string
; (make paragraph
; use: *paragraph-style*
; ;space-before:
; start-indent: (+ (inherit-start-indent)
; (* *indent-factor* *base-font-size*))
; first-line-start-indent: (- (* *indent-factor* *base-font-size*))
; (make line-field
; field-width: (* *indent-factor* *base-font-size*)
; (literal lhead))
; (process-children-trim)))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (LIST-ELEMENT lhead) ;; lhead -- list head string
(make paragraph
use: *paragraph-style*
;space-before:
start-indent: (inherited-start-indent)
first-line-start-indent: (- (* *indent-factor* *base-font-size*))
(make line-field
field-width: (* *indent-factor* *base-font-size*)
(literal lhead))
(process-children-trim)))
;; Title
;;;;;;; am..200x ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (TITLE-LARGE)
; (make paragraph
; use: *paragraph-style*
; font-size: (list-ref *font-table* 2)
; font-weight: 'bold
; space-before:
; (car
; (case (gi (first (children (current-node))))
; (("h2" "h3") (car (title-vertical-spacing "h1" 2)))
; (else (car (title-vertical-spacing "h1" 0)))))
; space-after:
; (cadr
; (case (gi (first (children (current-node))))
; (("h2" "h3") (cadr (title-vertical-spacing "h1" 2)))
; (else (cadr (title-vertical-spacing "h1" 0)))))
; escapement-space-after: ;; used by character flow objedt class.
; (title-char-spacing (count (children (current-node))) *paper-name*)
; (literal (GET-MIDASHI-NUMS '("H1")))
; (literal " ")
; (process-children)))
;;;;;;; am..200x ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (TITLE-MEDIUM)
; (make paragraph
; use: *paragraph-style*
; font-size: (list-ref *font-table* 3)
; font-weight: 'bold
; space-before:
; (let ((b1 (absolute-first-sibling? (current-node)))
; (b2 (string=? (gi (first (children (current-node)))) "h3")))
; (car
; (cond
; ((and b1 b2) (title-vertical-spacing "h2" 3))
; ((and (not b1) b2) (title-vertical-spacing "h2" 2))
; ((and b1 (not b2)) (title-vertical-spacing "h2" 1))
; (else (title-vertical-spacing "h2" 0)))))
; space-after:
; (let ((b1 (absolute-first-sibling? (current-node)))
; (b2 (string=? (gi (first (children (current-node)))) "h3")))
; (cadr
; (cond
; ((and b1 b2) (title-vertical-spacing "h2" 3))
; ((and (not b1) b2) (title-vertical-spacing "h2" 2))
; ((and b1 (not b2)) (title-vertical-spacing "h2" 1))
; (else (title-vertical-spacing "h2" 0)))))
; escapement-space-after:
; (title-char-spacing (count (children (current-node))) *paper-name*)
; ; (make embedded-text ;; Title number improvement.200x
; direction: 'right-to-left
; escapement-space-after: 0
; (literal (GET-MIDASHI-NUMS '(H1 H2)))
; (literal " ")
; )
; (process-children)))
;;;;;;; am..200x ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (TITLE-SMALL)
; (make paragraph
; use: *paragraph-style*
; font-size: (list-ref *font-table* 4)
; font-weight: 'bold
; space-before:
; (car
; (if (absolute-first-sibling? (current-node))
; (title-vertical-spacing "h2" 1)
; (title-vertical-spacing "h2" 0)))
; space-after:
; (cadr
; (if (absolute-first-sibling? (current-node))
; (title-vertical-spacing "h2" 1)
; (title-vertical-spacing "h2" 0)))
; escapement-space-after:
; (title-char-spacing (count (children (current-node))) *paper-name*)
; ; (make embedded-text ;; Title number improvement.200x
; direction: 'right-to-left
; escapement-space-after: 0
; (literal (GET-MIDASHI-NUMS '(H1 H2 H3)))
; (literal " ")
; )
; (process-children)))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (TITLE-LARGE)
(make paragraph
use: *paragraph-style*
font-size: (list-ref (list-ref *font-table* 1) 1)
font-weight: 'bold
space-before:
(car
(case (gi (first (children (current-node))))
(("h2" "h3") (title-vertical-spacing "h1" 2))
(else (title-vertical-spacing "h1" 0))))
space-after:
(cadr
(case (gi (first (children (current-node))))
(("h2" "h3") (title-vertical-spacing "h1" 2))
(else (title-vertical-spacing "h1" 0))))
escapement-space-after:
(title-char-spacing (count (children (current-node))) *paper-name*)
(literal (GET-MIDASHI-NUMS '("H1")))
(literal " ")
(process-children)))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (TITLE-MEDIUM)
(make paragraph
use: *paragraph-style*
font-size: (list-ref (list-ref *font-table* 2) 1)
font-weight: 'bold
space-before:
(let ((b1 (absolute-first-sibling? (current-node)))
(b2 (string=? (gi (first (children (current-node)))) "h3")))
(car
(cond
((and b1 b2) (title-vertical-spacing "h2" 3))
((and (not b1) b2) (title-vertical-spacing "h2" 2))
((and b1 (not b2)) (title-vertical-spacing "h2" 1))
(else (title-vertical-spacing "h2" 0)))))
space-after:
(let ((b1 (absolute-first-sibling? (current-node)))
(b2 (string=? (gi (first (children (current-node)))) "h3")))
(cadr
(cond
((and b1 b2) (title-vertical-spacing "h2" 3))
((and (not b1) b2) (title-vertical-spacing "h2" 2))
((and b1 (not b2)) (title-vertical-spacing "h2" 1))
(else (title-vertical-spacing "h2" 0)))))
escapement-space-after:
(title-char-spacing (count (children (current-node))) *paper-name*)
(literal (GET-MIDASHI-NUMS '("H1" "H2")))
(literal " ")
(process-children)))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (TITLE-SMALL)
(make paragraph
use: *paragraph-style*
font-size: (list-ref (list-ref *font-table* 3) 1)
font-weight: 'bold
space-before:
(car
(if (absolute-first-sibling? (current-node))
(title-vertical-spacing "h2" 1)
(title-vertical-spacing "h2" 0)))
space-after:
(cadr
(if (absolute-first-sibling? (current-node))
(title-vertical-spacing "h2" 1)
(title-vertical-spacing "h2" 0)))
escapement-space-after:
(title-char-spacing (count (children (current-node))) *paper-name*)
(literal (GET-MIDASHI-NUMS '("H1" "H2" "H3")))
(literal " ")
(process-children)))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Some additional definitions
(define (caar a)
(car (car a)))
(define (cadr a)
(car (cdr a)))
(define (caddr a)
(car (cdr (cdr a))))
(define (cadddr a)
(car (cdr (cdr (cdr a)))))
(define (first a)
(node-list-first a))
(define (eq? a b)
(if (and (not (list? a)) (not (list? b)))
(equal? a b)
#f))
(define (eqv? a b)
(eq? a b))
(define (count nl)
(node-list-count nl))
(define (node-list-count nl)
(node-list-length (node-list-remove-duplicates nl)))
(define (node-list-remove-duplicates nl)
(node-list-reduce nl
(lambda (result snl)
(if (node-list-contains? result snl)
result
(node-list result snl)))
(empty-node-list)))
(define (node-list-contains? nl snl)
(node-list-reduce nl
(lambda (result i)
(or result
(node-list=? snl i)))
#f))
(define (string=? a b)
(if (and (string? a) (string? b))
(equal? a b)
#f))
.
;; -*- Scheme -*-
;; Amended Pagemodel.dsl
;; Additional characteristics
;; Ruby must not be on adjoin Chinese.
(declare-characteristic ruby-style "-//JIS//TR X 0010//JP" #t)
;; Patterns of line.
(declare-characteristic line-style "-//JIS//TR X 0010//JP" 'hyoukei)
;; Ruby and emphasized mark don't increase line space. Parent character base.
(declare-characteristic layout-rule "-//JIS//TR X 0010//JP" #t)
;;
;; Page model
;; Default height of header/footer is for 2 lines.
(define *header-height* (* (cadddr *page-spec*) 2))
(define *footer-height* (* (cadddr *page-spec*) 2))
;; *page-region-y-offset* is distance from top left. Change into bottom left like DSSSL.
;; In addition to, region contains header/footer.
(define *pr-y-off*
(- *paper-height* *page-region-y-offset*
*page-region-height* *footer-height*))
;;;;;;; improvement.200x (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define-page-model standard-rect-page
; (filling-direction 'top-to-bottom)
; (width *paper-width*)
; (height *paper-height*)
; (region
; (x-origin *page-region-x-offset*)
; (y-origin *pr-y-off*)
; (width *page-region-width*)
; (height (+ *page-region-height* *header-height* *footer-height*))
; (header
; (height *header-height*)
; (width *page-region-width*)
; (generate (HEADER-CONTENT 'rect)))
; (footer
; (height *footer-height*)
; (width *page-region-width*)
; (generate (FOOTER-CONTENT 'rect)))
; ))
;;;;;;; improvement.200x (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define *verso-pr-x-off*
; (- *paper-width* *page-region-x-offset* *page-region-width*))
;;;;;;; improvement.200x (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define-page-model standard-verso-page
; (filling-direction 'top-to-bottom)
; (width *paper-width*)
; (height *paper-height*)
; (region
; (x-origin *verso-pr-x-off*)
; (y-origin *pr-y-off*)
; (width *page-region-width*)
; (height (+ *page-region-height* *header-height* *footer-height*))
; (header
; (height *header-height*)
; (width *page-region-width*)
; (generate (PAGE-HEADER 'verso)))
; (footer
; (height *footer-height*)
; (width *page-region-width*)
; (generate (PAGE-FOOTER 'verso)))
; ))
;;
;; Specification of head line and page number.
;;
;; *has-header-nonburu*
;; *has-header-hasira*
;; *has-footer-nonburu*
;; *has-footer-hasira*
;; *hasira-rect* (string)
;; *hasira-verso* (string)
;;
;; Head line and page number space is zenkakuaki.
;; No specification that the head line is center of top edge.
;;
;;;;;;; improvement.200x (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (PAGE-HEADER side)
; (make paragraph
; use: *header-footer-style* ;;*paragraph-style*
; quadding: (if (eq side 'verso) 'end 'start)
; (case side
; (('rect)
; (sosofo-append ((if *has-header-nonburu*
; (MAKE-NONBURU) #f)
; (literal " ")
; (if *has-header-hasira*
; (literal *hasira-rect*) #f)
; )))
; (else
; (sosofo-append ((if *has-header-hasira*
; (literal *hasira-verso*) #f)
; (if *has-header-nonburu*
; (progn
; (literal " ")
; (MAKE-NONBURU)) #f)
; )))
; )))
;;;;;;; improvement.200x (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (PAGE-FOOTER side)
; (make paragraph
; use: *header-footer-style* ;;*paragraph-style*
; space-before: *base-font-size* ;; 1 line space
; quadding: (if (eq side 'verso) 'end 'start)
; (case side
; (('rect)
; (sosofo-append ((if *has-footer-nonburu*
; (MAKE-NONBURU) #f)
; (literal " ")
; (if *has-footer-hasira*
; (literal *hasira-rect*) #f)
; )))
; (else
; (sosofo-append ((if *has-footer-hasira*
; (literal *hasira-verso*) #f)
; (if *has-footer-nonburu*
; (progn
; (literal " ")
; (MAKE-NONBURU)) #f)
; )))
; )))
(define MAKE-NONBURU
;;(literal "page ")
(page-number-sosofo) ;; Number only
)
;;
;; Set footnote
;;
(define (MAKE-FOOTNOTE-EXP num) ;; Expression footnote
(make-numbering num *footnote-number-desc*))
;;;;;;; improvement.200x (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (FOOTNOTE)
; (let ((footnote-exp (MAKE-FOOTNOTE-EXP (footnote-number 'page))))
; ;; First, only footnote number every page.
; ;; Aijirusi position of note is where (FOOTNOTE) is called .
; (make sequence
; (make included-container-area improvement.200x
; use: *footnote-style*
; display?: #f
; (literal footnote-exp))
; (make paragraph
; label: 'footnote
; (literal footnote-exp)
; (literal " ")
; (process-children)))))
;;;;;;; am..2000 (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;------Footnote number only-------;
(define (FOOTNOTE)
(make superscript
font-size: (* (inherited-font-size) *superscript-font-size-factor*)
(literal (MAKE-FOOTNOTE-EXP (element-number (current-node))))))
;;;;;;; am..2000 (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;------Footnote contents----------;
(define (FOOTNOTE-CONTENTS)
(with-mode FOOT-MODE
(process-node-list (node-matching-list (parent (current-node)) "FN"))))
;;;;;;; am..2000 (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(mode FOOT-MODE
(element FN
(make paragraph
(literal (MAKE-FOOTNOTE-EXP (element-number (current-node))))
(process-children))))
;;;;;;; am..2000 (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----Searches in the subgrove whose roots are each member of nl for element matching pattern.----;
(define (node-matching-list nl pattern)
(let (
(first (node-list-first nl))
(rest (node-list-rest nl)))
(if (node-list-empty? first)
first
(node-list
(if (string=? pattern (gi first))
first
(node-list-rest first))
(node-matching-list (children first) pattern)
(node-matching-list rest pattern)))))
;;;;;;; improvement.200x (included-container-area);;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (FOOTNOTE-SEPARATOR)
; (make rule
; orientation: 'horizontal
; line-thickness: 1pt
; ))
;;
;; Set column
;;
;;;;;;; improvement.200x (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define *column-width* (* (cadr *page-spec*)(caddr *page-spec*)))
;(define *column-width+gap*
; (let ((gap (cddddr *page-spec*)))
; (if (null? gap)
; *column-width*
; (* (cadr *page-spec*)(+ (caddr *page-spec*) (car gap))))))
;;;;;;; improvement.200x (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define (filling-dir fld) ;; Filling direction is perpendicularity if
;; how to set type is vertical.
; (if (equal fld 'vertical)
; 'left-to-right
; 'top-to-bottom))
;;;;;;; improvement.200x (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define-column-set-model standard-one-column-model
; (filling-direction (filling-dir *writing-dir*))
; (column-subset
; (column
; (x-origin 0)
; (width *column-width*)
; (footnote-separator
; (generate (FOOTNOTE-SEPARATOR))
; (flow '(footnote footnote) )
; ))
;))
;;;;;;; improvement.200x (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (filling-direction (filling-dir *writing-dir*))
; (column-subset
; (column
; (x-origin 0)
; (width *column-width*))
; (column
; (x-origin *column-width+gap*)
; (width *column-width*)
; (footnote-separator
; (generate (FOOTNOTE-SEPARATOR))
; (flow '(footnote footnote) )
; ))
;))
;;;;;;; improvement.200x (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define-column-set-model standard-three-column-model
; (filling-direction (filling-dir *writing-dir*))
; (column-subset
; (column
; (x-origin 0)
; (width *column-width*))
; (column
; (x-origin *column-width+gap*)
; (width *column-width*))
; (column
; (x-origin (* 2 *column-width+gap*))
; (width *column-width*)
; (footnote-separator
; (generate (FOOTNOTE-SEPARATOR))
; (flow '(footnote footnote) )
; ))
;))
;; Functions to generate top level flow object.
;; Call with top level construction rule.
;;
;;;;;;; improvement.200x (page-sequence,column-set-sequence,included-container-area);;;
;(define (STANDARD-PAGE-SEQUENCE)
; (case *column-number*
; ((1)
; (make page-sequence improvement.200x
; initial-page-models: (standard-rect-page standard-verso-page)
; repeat-page-models: (standard-rect-page standard-verso-page)
; ;;content-map: '((footnote footnote))
; (make column-set-sequence improvement.200x
; column-set-model: standard-one-column-model
; (process-children-trim)) ))
; ((2)
; (make page-sequence improvement.200x
; initial-page-models: (standard-rect-page standard-verso-page)
; repeat-page-models: (standard-rect-page standard-verso-page)
; ;;content-map: '((footnote footnote))
; (make column-set-sequence improvement.200x
; column-set-model: standard-two-column-model
; (process-children-trim)) ))
; ((3)
; (make page-sequence improvement.200x
; initial-page-models: (standard-rect-page standard-verso-page)
; repeat-page-models: (standard-rect-page standard-verso-page)
; ;;content-map: '((footnote footnote))
; (make column-set-sequence improvement.200x
; column-set-model: standard-three-column-model
; (process-children-trim)) ))
; ))
;;;;;;; am..2000 (page-sequence,column-set-sequence,included-container-area);;;;
(define (STANDARD-PAGE-SEQUENCE)
(make simple-page-sequence
font-family-name: *base-font-family*
font-size: *base-font-size*
line-spacing: (cadddr *page-spec*)
left-header: (make sequence
font-size: (- *base-font-size* 1pt)
line-spacing: (cadddr *page-spec*)
font-posture: 'italic
(if-front-page
(empty-sosofo)
(sosofo-append
(if *has-header-nonburu*
MAKE-NONBURU (empty-sosofo))
(if *has-header-hasira*
(literal *hasira-verso*) (empty-sosofo)))))
right-header: (make sequence
font-size: (- *base-font-size* 1pt)
line-spacing: (cadddr *page-spec*)
font-posture: 'italic
(if-front-page
(sosofo-append
(if *has-header-hasira*
(literal *hasira-rect*) (empty-sosofo))
(if *has-header-nonburu*
MAKE-NONBURU (empty-sosofo)))
(empty-sosofo)))
left-footer: (make sequence
font-size: (- *base-font-size* 1pt)
line-spacing: (cadddr *page-spec*)
font-posture: 'italic
(if-front-page
(empty-sosofo)
(sosofo-append
(if *has-footer-nonburu*
MAKE-NONBURU (empty-sosofo))
(if *has-footer-hasira*
(literal *hasira-verso*) (empty-sosofo)))))
right-footer: (make sequence
font-size: (- *base-font-size* 1pt)
line-spacing: (cadddr *page-spec*)
font-posture: 'italic
(if-front-page
(sosofo-append
(if *has-footer-hasira*
(literal *hasira-rect*) (empty-sosofo))
(if *has-footer-nonburu*
MAKE-NONBURU (empty-sosofo)))
(empty-sosofo)))
top-margin: *page-region-y-offset*
bottom-margin: (- *paper-height* *page-region-height* *page-region-y-offset*)
left-margin: *page-region-x-offset*
right-margin: (- *paper-width* *page-region-width* *page-region-x-offset*)
header-margin: (- *page-region-y-offset* *header-height*)
footer-margin: *pr-y-off*
page-width: *page-region-width*
page-height: *page-region-height*
quadding: 'justify
page-n-columns: *column-number*
(process-children-trim)
))
;;;;;;; am..2000 (column-set-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Caracteristic definition for multi column-sets on simple-page-sequence.
(declare-characteristic page-n-columns
"UNREGISTERED::James Clark//Characteristic::page-n-columns" 1)
;;;;;;; am..2000 (page-sequence);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Function definition to make verso and recto have difference sosofo.
(define if-front-page
(external-procedure "UNREGISTERED::James Clark//Procedure::if-front-page"))
.
;; -*- Scheme -*- amendment html.dsl
;; ======================= NON-PRINTING ELEMENTS ========================
;; Note that HEAD includes TITLE, ISINDEX, BASE, META, STYLE,
;; SCRIPT, and LINK as possible children
;(default (empty-sosofo));; default element construction rule [171]
(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
(STANDARD-PAGE-SEQUENCE) ;; see pagemodel.dsl
)
(element BODY
(process-children-trim))
;; ========================== BLOCK ELEMENTS ============================
;; ............................ Generic DIV .............................
(define (align-attr attr)
(case attr
(("LEFT") 'start)
(("CENTER") 'center)
(("RIGHT") 'end)
(else 'justify)))
(element DIV
(let ((align (align-attr (attribute-string "align"))))
(make display-group
quadding: align
(process-children-trim))))
(element CENTER
(make display-group
quadding: 'center
(process-children-trim)))
;; ............................ headings ..............................
(element H1 (TITLE-LARGE)) ;; see function.dsl
(element H2 (TITLE-MEDIUM))
(element H3 (TITLE-SMALL))
(element H4 (TITLE-SMALL))
(element H5 (TITLE-SMALL))
(element H6 (TITLE-SMALL))
;; ............................ Paragraphs ..............................
(element P
(make paragraph
use: *fli-paragraph-style*
quadding: (PQUAD)
(process-children-trim)))
(element ADDRESS
(make paragraph
use: *paragraph-style*
start-indent: *indent-step*
(process-children-trim)))
(element BLOCKQUOTE
(make paragraph
start-indent: (+ (inherited-start-indent) *indent-step*)
end-indent: (+ (inherited-end-indent) *indent-step*)
(process-children-trim)))
(element PRE (MONO-SEQ))
(element XMP (MONO-SEQ))
(element LISTING (MONO-SEQ))
(element PLAINTEXT (MONO-SEQ))
(element BR
(make display-group (empty-sosofo)))
;; ............................ Lists ..............................
;;; UL LI DIR MENU DL DT DD
(element OL (LIST-CONTAINER))
(element UL (LIST-CONTAINER))
(element DIR (LIST-CONTAINER))
(element MENU (LIST-CONTAINER))
(element (OL LI) (LIST-ELEMENT
(make-numbering (child-number)
(case (modulo (length (hierarchical-number-recursive "OL")) 4)
((1) '(#f #f "(" last ")")) ; (1)...
((2) '(#f 'abc "(" last ")")) ; (a)...
((3) '(#f 'roma "(" last ")")) ; (i)...
((0) '(#f 'ABC "(" last ")")) ; (A)...
))))
(element (UL LI) (LIST-ELEMENT
(case (modulo (length (hierarchical-number-recursive "UL")) 4)
((1) "-")
((2) "・")
((3) "☆")
((0) "◎")
)))
(element (DIR LI) (LIST-ELEMENT " "))
(element (MENU LI) (LIST-ELEMENT " "))
(element DL (LIST-CONTAINER))
(element DT (make paragraph
use: *paragraph-style*
start-indent: (+ (inherited-start-indent)
(* *indent-factor* *base-font-size*))
first-line-start-indent: (- (* *indent-factor* *base-font-size*))
(process-children)
))
(element DD (make paragraph
use: *paragraph-style*
start-indent: (+ (inherited-start-indent)
(* *indent-factor* *base-font-size*))
first-line-start-indent: 0pt
(process-children)
))
;; ............................ seq ..............................
(element B (BOLD-SEQ))
(element EM (BOLD-SEQ))
(element STRONG (BOLD-SEQ))
(element I (ITALIC-SEQ))
(element CITE (ITALIC-SEQ))
(element VAR (ITALIC-SEQ))
(element DFN (BOLD-ITALIC-SEQ))
(element A (BOLD-ITALIC-SEQ))
(element TT (MONO-SEQ))
(element CODE (MONO-SEQ))
(element KBD (MONO-SEQ))
(element SAMP (MONO-SEQ))
(element STRIKE (STRIKE-SEQ))
(element U (UNDERLINE))
;(element SUB (SUBSCRIPT)) am..200x
(element SUB (SUBSCRIPT '())) ;am..2000
;(element SUP (SUPERSCRIPT '())) am..200x
(element SUP (SUPERSCRIPT '())) ;am..2000
;; (element BIG )
;; (element SMALL )
;; (element FONT )
;; ============================== 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))))
;; ============================== TABLES ================================
(element TABLE
;; number-of-columns is for future use
(let ((number-of-columns
(node-list-reduce (node-list-rest (children (current-node)))
(lambda (cols nd)
(max cols
(node-list-length (children nd))))
0)))
(make display-group
space-before: %block-sep%
space-after: %block-sep%
start-indent: %body-start-indent%
;; for debugging:
;; (make paragraph
;; (literal
;; (string-append
;; "Number of columns: "
;; (number->string number-of-columns))))
(with-mode table-caption-mode (process-first-descendant "CAPTION"))
(make table
(process-children)))))
(mode table-caption-mode
(element CAPTION
(make paragraph
use: para-style
font-weight: 'bold
space-before: %block-sep%
space-after: %para-sep%
start-indent: (inherited-start-indent);
(literal
(string-append
"Table "
(format-number
(element-number) "1") ". "))
(process-children-trim))))
(element CAPTION (empty-sosofo)) ; don't show caption inside the table
(element TR
(make table-row
(process-children-trim)))
(element TH
(make table-cell
;n-rows-spanned: (string->number (attribute-string "COLSPAN"))
(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
;n-rows-spanned: (string->number (attribute-string "COLSPAN"))
(make paragraph
space-before: 0.25em
space-after: 0.25em
start-indent: 0.25em
end-indent: 0.25em
quadding: 'start
(process-children-trim))))
;;;;;;; the following 113 lines am..2000 ;;;;;;;;;;;;;;;;;;;;;;;
(define (MONO-SEQ)
(make sequence
(process-children)))
(define %para-sep% (/ *base-font-size* 2.0))
(define %block-sep% (* %para-sep% 2.0))
(define %body-width% *page-region-width*)
(define (PQUAD)
(case (attribute-string "align")
(("LEFT") 'start)
(("CENTER") 'center)
(("RIGHT") 'end)
(else (inherited-quadding))))
;a definition of style
(define para-style
(style
font-size: *base-font-size*
line-spacing: (* *base-font-size* 1.1)))
;a definition of unit
(define-unit em *base-font-size*)
(define-unit pi (/ 1in 6))
(define-unit px (/ 1in 96))
(define-unit mm .001m)
(define-unit cm .01m)
;a definition of functions
(define (node-list-reduce nl combine init)
(if (node-list-empty? nl)
init
(node-list-reduce (node-list-rest nl)
combine
(combine init (node-list-first nl)))))
(define upperalpha '(A))
; (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 '(a))
; (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 (EQUIVLOWER c a1 a2)
(cond ((null? a1) '())
((char=? c (car a1)) (car a2))
((char=? c (car a2)) c)
(else (EQUIVLOWER c (cdr a1) (cdr a2)))))
(define (char-downcase c)
(EQUIVLOWER c upperalpha loweralpha))
(define (ISALPHA? c)
(if (or (member c upperalpha) (member c loweralpha)) #t #f))
(define (LOCASE slist)
(if (null? slist)
'()
(cons (char-downcase (car slist)) (LOCASE (cdr slist)))))
(define (STR2LIST s)
(let ((start 0)
(len (string-length s)))
(let loop ((i start) (l len))
(if (= i len)
'()
(cons (string-ref s i)(loop (+ i 1) l))))))
(define (LIST2STR x)
(apply string x))
(define (STRING-DOWNCASE s)
(LIST2STR (LOCASE (STR2LIST s))))
(define (UNAME-START-INDEX u last)
(let ((c (string-ref u last)))
(if (ISALPHA? c)
(if (= last 0)
0
(UNAME-START-INDEX u (- last 1)))
(+ last 1))))
(define (PARSEDUNIT u)
(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)
1pi
(if (= u-s-i strlen)
(* (string->number u) 1px)
(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))
(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))
;;;;;;; am..2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(element YOMI (YOMI))
(element FN (FOOTNOTE))
(element FN-CONTENTS (FOOTNOTE-CONTENTS))
.
One sheet of flexible disk of the MS-DOS style is attached to this technical report (JIS/TR). The file name of the file which this flexible disk is containing and the contents are shown in the next.
The Formation Program for Parameter Details which shows it in the Annex A of this technical report (JIS/TR).
The Functions which shows it in the Annex B of this technical report (JIS/TR).
The Page Models which shows it in the Annex C of this technical report (JIS/TR).
The Specifying DTD rule group which shows it in the Annex C of this technical report (JIS/TR).
The text file which a accessory showed the contents of the flexible disk in the same way as this attached document in.
the end of annex