aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
authorLudovic Courtès2008-10-08 00:08:14 +0200
committerLudovic Courtès2008-10-08 00:08:14 +0200
commitfedf8932e3aeb9664c4f3064a4a257b2a379a259 (patch)
tree387b4b1c3a8b9c3ad939b986842ca15ecf6d94b6 /src/guile
parentc11b1e0a95510c12f5f387d8b54e77bceea36569 (diff)
downloadskribilo-fedf8932e3aeb9664c4f3064a4a257b2a379a259.tar.gz
skribilo-fedf8932e3aeb9664c4f3064a4a257b2a379a259.tar.lz
skribilo-fedf8932e3aeb9664c4f3064a4a257b2a379a259.zip
Add Scribe's original Info "engine".
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/engine/info.scm1217
1 files changed, 1217 insertions, 0 deletions
diff --git a/src/guile/skribilo/engine/info.scm b/src/guile/skribilo/engine/info.scm
new file mode 100644
index 0000000..1449b30
--- /dev/null
+++ b/src/guile/skribilo/engine/info.scm
@@ -0,0 +1,1217 @@
+;*=====================================================================*/
+;* serrano/prgm/project/scribe/scribetext/info.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Sep 23 14:03:53 2001 */
+;* Last change : Mon Oct 21 10:59:41 2002 (serrano) */
+;* Copyright : 2001-02 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The translator scribe->text */
+;*=====================================================================*/
+
+
+;*---------------------------------------------------------------------*/
+;* info-dest ... */
+;*---------------------------------------------------------------------*/
+(define (info-dest)
+ (if (string? *scribe-dest*)
+ *scribe-dest*
+ "anonymous.info"))
+
+;*---------------------------------------------------------------------*/
+;* info-node ... */
+;*---------------------------------------------------------------------*/
+(define (info-node node next prev up)
+ (print "")
+ (print "File: " (info-dest)
+ ", Node: " node
+ ", Next: " next
+ ", Prev: " prev
+ ", Up: " up)
+ (newline))
+
+;*---------------------------------------------------------------------*/
+;* node-next+prev+top ::%container ... */
+;*---------------------------------------------------------------------*/
+(define-generic (node-next+prev+top obj::%container))
+
+;*---------------------------------------------------------------------*/
+;* node-next+prev+top ::%document ... */
+;*---------------------------------------------------------------------*/
+(define-method (node-next+prev+top obj::%document)
+ (with-access::%container obj (children)
+ (let loop ((c children))
+ (cond
+ ((null? c)
+ (values "Top" "(dir)" "(dir)"))
+ ((or (%chapter? (car c)) (%section? (car c)))
+ (values (block-title (car c)) "(dir)" "(dir)"))
+ (else
+ (loop (cdr c)))))))
+
+;*---------------------------------------------------------------------*/
+;* node-next+prev+top ... */
+;*---------------------------------------------------------------------*/
+(define-method (node-next+prev+top obj::%block)
+ (with-access::%block obj (parent)
+ (let ((top (if (%document? parent)
+ "Top"
+ (block-title parent))))
+ (let loop ((els (%container-children parent))
+ (prev #f))
+ (cond
+ ((null? els)
+ (values top top top))
+ ((eq? (car els) obj)
+ (let ((p (if prev
+ (block-title prev)
+ top))
+ (n (if (null? (cdr els))
+ top
+ (block-title (cadr els)))))
+ (values p n top)))
+ (else
+ (loop (cdr els) (car els))))))))
+
+;*---------------------------------------------------------------------*/
+;* node-menu ... */
+;*---------------------------------------------------------------------*/
+(define (node-menu obj::%container)
+ (with-access::%container obj (children)
+ (if (pair? (filter (lambda (x) (or (%chapter? x) (%section? x)))
+ children))
+ (begin
+ (newline)
+ (print "* Menu:")
+ (newline)
+ (for-each (lambda (c)
+ (if (%block? c)
+ (print "* " (block-title c) "::")))
+ (reverse children))))
+ (newline)))
+
+;*---------------------------------------------------------------------*/
+;* block-title ::%block ... */
+;*---------------------------------------------------------------------*/
+(define-generic (block-title obj::%block)
+ "")
+
+;*---------------------------------------------------------------------*/
+;* block-title ::%chapter ... */
+;*---------------------------------------------------------------------*/
+(define-method (block-title obj::%chapter)
+ (with-access::%chapter obj (title subtitle)
+ (let ((title (if title title subtitle)))
+ (if (string? title)
+ title
+ (with-output-to-string
+ (lambda () (info title)))))))
+
+;*---------------------------------------------------------------------*/
+;* block-title ::%section ... */
+;*---------------------------------------------------------------------*/
+(define-method (block-title obj::%section)
+ (with-access::%section obj (title)
+ (if (string? title)
+ title
+ (with-output-to-string
+ (lambda () (info title))))))
+
+;*---------------------------------------------------------------------*/
+;* block-title ::%subsection ... */
+;*---------------------------------------------------------------------*/
+(define-method (block-title obj::%subsection)
+ (with-access::%subsection obj (title)
+ (if (string? title)
+ title
+ (with-output-to-string
+ (lambda () (info title))))))
+
+;*---------------------------------------------------------------------*/
+;* block-title ::%subsection ... */
+;*---------------------------------------------------------------------*/
+(define-method (block-title obj::%subsubsection)
+ (with-access::%subsubsection obj (title)
+ (if (string? title)
+ title
+ (with-output-to-string
+ (lambda () (info title))))))
+
+;*---------------------------------------------------------------------*/
+;* *text-string-processor* ... */
+;*---------------------------------------------------------------------*/
+(define *text-string-processor*
+ (lambda (x) x))
+
+;*---------------------------------------------------------------------*/
+;* info ::obj ... */
+;*---------------------------------------------------------------------*/
+(define-generic (info obj::obj)
+ (cond
+ ((and (procedure? obj) (correct-arity? obj 0))
+ (info (obj)))
+ ((string? obj)
+ (output (*text-string-processor* obj)))
+ ((number? obj)
+ (output (*text-string-processor* (number->string obj))))
+ ((char? obj)
+ (output (*text-string-processor* (string obj))))
+ ((eq? obj #unspecified)
+ obj)
+ ((list? obj)
+ (for-each info obj))
+ ((or (symbol? obj) (boolean? obj))
+ "")
+ (else
+ (with-access::%node obj (loc)
+ (error/location "info"
+ "Can't find method for node"
+ (find-runtime-type obj)
+ (car loc)
+ (cdr loc))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%document ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%document)
+ (with-document
+ obj
+ (lambda ()
+ (with-access::%document obj (title authors body footnotes)
+ (scribe-document->info obj (if title title "") authors body)
+ (if (pair? footnotes)
+ (begin
+ (with-justification
+ (make-justifier *text-column-width* 'left)
+ (lambda ()
+ (newline)
+ (newline)
+ (print "-------------")
+ (for-each (lambda (fn)
+ (with-access::%footnote fn (number note id)
+ (output (string-append
+ "*"
+ (number->string number)
+ ": "))
+ (info note)
+ (output-newline)))
+ footnotes)))))))))
+
+;*---------------------------------------------------------------------*/
+;* scribe-document->info ... */
+;*---------------------------------------------------------------------*/
+(define (scribe-document->info obj title authors body)
+ (define (info-authors1 author)
+ (info author)
+ (output-newline)
+ (output-newline))
+ (define (info-authorsN authors cols first)
+ (define (make-row authors . opt)
+ (apply tr (map (lambda (v)
+ (apply td :align 'center :valign 'top v opt))
+ authors)))
+ (define (make-rows authors)
+ (let loop ((authors authors)
+ (rows '())
+ (row '())
+ (cnum 0))
+ (cond
+ ((null? authors)
+ (reverse! (cons (make-row (reverse! row)) rows)))
+ ((= cnum cols)
+ (loop authors
+ (cons (make-row (reverse! row)) rows)
+ '()
+ 0))
+ (else
+ (loop (cdr authors)
+ rows
+ (cons (car authors) row)
+ (+fx cnum 1))))))
+ (info (apply table
+ (if first
+ (cons (make-row (list (car authors)) :colspan cols)
+ (make-rows (cdr authors)))
+ (make-rows authors)))))
+ (define (info-authors authors)
+ (if (pair? authors)
+ (begin
+ (output-newline)
+ (output "--o-0-o--")
+ (output-newline)
+ (output-newline)
+ (let ((len (length authors)))
+ (case len
+ ((1)
+ (info-authors1 (car authors)))
+ ((2 3)
+ (info-authorsN authors len #f))
+ ((4)
+ (info-authorsN authors 2 #f))
+ (else
+ (info-authorsN authors 3 #t)))))))
+ ;; display the title and the authors
+ (define (info-title title authors)
+ (with-justification
+ (make-justifier (justification-width) 'center)
+ (lambda ()
+ (output (make-string *text-column-width* #\=))
+ (output-newline)
+ (if (string? title)
+ (output (list->string
+ (apply append
+ (map (lambda (c) (list c #a008))
+ (string->list title)))))
+ (info title))
+ (output-newline)
+ (info-authors authors)
+ (output (make-string *text-column-width* #\=))
+ (output-newline)
+ (output-newline)
+ (output-flush *margin*))))
+;; display the footer
+ (define (info-footer)
+ (if *scribe-footer* (info *scribe-footer*)))
+ ;; the main node
+ (multiple-value-bind (next prev top)
+ (node-next+prev+top obj)
+ (newline)
+ (info-node "Top" next prev top))
+ ;; the title
+ (info-title title authors)
+ (output-flush 0)
+ ;; the main info menu
+ (node-menu obj)
+ ;; the body
+ (info body)
+ (output-flush 0)
+ ;; the footer of the document
+ (info-footer)
+ (output-flush 0)
+ ;; we are done
+ (newline)
+ (newline))
+
+;*---------------------------------------------------------------------*/
+;* info ::%author ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%author)
+ (with-access::%author obj (name title affiliation email url address phone)
+ (if (or (pair? name) (string? name))
+ (info name))
+ (if title (begin (output-newline) (output title)))
+ (if affiliation (begin (output-newline) (output affiliation)))
+ (if (pair? address)
+ (for-each (lambda (x) (output-newline) (output x)) address))
+ (if email (begin (output-newline) (output email)))
+ (if url (begin (output-newline) (output url)))
+ (if phone (begin (output-newline) (output phone)))
+ (output-newline)))
+
+;*---------------------------------------------------------------------*/
+;* scribe->html ::%toc ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%toc)
+ (node-menu (current-document)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%text ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%text)
+ (info (%text-body obj)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%linebreak ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%linebreak)
+ (let loop ((num (%linebreak-repetition obj)))
+ (output-newline)
+ (if (>fx num 1)
+ (begin
+ (output-newline)
+ (loop (-fx num 1))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%center ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%center)
+ (with-justification (make-justifier (justification-width) 'center)
+ (lambda ()
+ (info (%center-body obj)))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%flush ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%flush)
+ (with-access::%flush obj (side)
+ (with-justification (make-justifier (justification-width) side)
+ (lambda ()
+ (info (%flush-body obj))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%atom ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%atom)
+ (output (%atom-value obj)))
+
+;*---------------------------------------------------------------------*/
+;* *ornaments* ... */
+;*---------------------------------------------------------------------*/
+(define *ornaments*
+ `((bold "{\\textbf{" "}}")
+ (emph "*" "*")
+ (underline "_" "_")
+ (it "{\\textit{" "}}")
+ (samp "{\\textit{" "}}")
+ (sc "{\\sc{" "}}")
+ (sup "^" "")
+ (sub "_" "")
+ (code "`" "'")
+ (samp "`" "'")))
+
+;*---------------------------------------------------------------------*/
+;* info ::%ornament ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%ornament)
+ (with-access::%ornament obj (body kind)
+ (case kind
+ ((var)
+ (let ((old *text-string-processor*))
+ (set! *text-string-processor* string-upcase)
+ (let ((res (info body)))
+ (set! *text-string-processor* old)
+ res)))
+ (else
+ (let ((d (assq kind *ornaments*)))
+ (if (not (pair? d))
+ (info body)
+ (let ((start (cadr d))
+ (stop (caddr d)))
+ (display start)
+ (info body)
+ (display stop))))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%pre ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%pre)
+ (with-justification (make-justifier *text-column-width* 'verbatim)
+ (lambda ()
+ (info (%pre-body obj))
+ (output-newline))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%mark ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%mark)
+ #unspecified)
+
+;*---------------------------------------------------------------------*/
+;* info ::%reference ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%reference)
+ (with-access::%reference obj (body anchor)
+ (multiple-value-bind (file mark)
+ (find-reference obj (current-document))
+ (if (not mark)
+ (begin
+ (warning "ref" "Can't find reference -- " anchor)
+ (output "reference:???"))
+ (begin
+ (output "*Note ")
+ (info body)
+ (output ":: "))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%sui-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%sui-ref)
+ (info (scribe-url-ref obj)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%url-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%url-ref)
+ (with-access::%url-ref obj (url anchor body)
+ (if (and body (not (equal? body url)))
+ (begin
+ (output "*Note ")
+ (info body)
+ (output " (")))
+ (info url)
+ (if (or (pair? anchor)
+ (and (string? anchor) (>fx (string-length anchor) 0)))
+ (begin
+ (output "#")
+ (info anchor)))
+ (if (and body (not (equal? body url))) (output ")"))
+ (output ":: ")))
+
+;*---------------------------------------------------------------------*/
+;* info ::%chapter-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%chapter-ref)
+ (multiple-value-bind (_ chapter)
+ (find-reference obj (current-document))
+ (if (not chapter)
+ (with-access::%chapter-ref obj (anchor)
+ (warning "ref" "Can't find chapter -- " anchor)
+ (output "chapter:???"))
+ (info-chapter-ref chapter))))
+
+;*---------------------------------------------------------------------*/
+;* info-chapter-ref ... */
+;*---------------------------------------------------------------------*/
+(define (info-chapter-ref obj::%chapter)
+ (output "*Note ")
+ (output (block-title obj))
+ (output ":: "))
+
+;*---------------------------------------------------------------------*/
+;* info ::%section-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%section-ref)
+ (multiple-value-bind (_ section)
+ (find-reference obj (current-document))
+ (if (not (%section? section))
+ (with-access::%section-ref obj (anchor)
+ (warning "ref" "Can't find section -- " anchor)
+ (output "section:???"))
+ (info-section-ref section))))
+
+;*---------------------------------------------------------------------*/
+;* info-section-ref ... */
+;*---------------------------------------------------------------------*/
+(define (info-section-ref obj::%section)
+ (with-access::%section obj (title)
+ (output "*Note ")
+ (output title)
+ (output ":: ")))
+
+;*---------------------------------------------------------------------*/
+;* info ::%subsection-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%subsection-ref)
+ (multiple-value-bind (_ subsection)
+ (find-reference obj (current-document))
+ (if (not (%subsection? subsection))
+ (with-access::%subsection-ref obj (anchor)
+ (warning "ref" "Can't find subsection -- " anchor)
+ (output "subsection:???"))
+ (info-subsection-ref subsection))))
+
+;*---------------------------------------------------------------------*/
+;* info-subsection-ref ... */
+;*---------------------------------------------------------------------*/
+(define (info-subsection-ref obj::%subsection)
+ (with-access::%subsection obj (title)
+ (output "*Note ")
+ (output title)
+ (output ":: ")))
+
+;*---------------------------------------------------------------------*/
+;* info ::%subsubsection-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%subsubsection-ref)
+ (multiple-value-bind (_ subsubsection)
+ (find-reference obj (current-document))
+ (if (not (%subsubsection? subsubsection))
+ (with-access::%subsubsection-ref obj (anchor)
+ (warning "ref" "Can't find subsubsection -- " anchor)
+ (output "subsubsection:???"))
+ (info-subsubsection-ref subsubsection))))
+
+;*---------------------------------------------------------------------*/
+;* info-subsubsection-ref ... */
+;*---------------------------------------------------------------------*/
+(define (info-subsubsection-ref obj::%subsubsection)
+ (with-access::%subsubsection obj (title)
+ (output "*Note ")
+ (output title)
+ (output ":: ")))
+
+;*---------------------------------------------------------------------*/
+;* info ::%biblio-ref ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%biblio-ref)
+ (with-access::%biblio-ref obj (anchor body)
+ (if body (info body))
+ (output " [")
+ (let loop ((a+ anchor))
+ (if (null? a+)
+ (output "]")
+ (let ((a (car a+)))
+ (cond
+ ((%bibentry? a)
+ (output (number->string (%bibentry-number a))))
+ ((string? a)
+ (output "???")
+ (output a)
+ (output "???"))
+ (else
+ (display "bibref:???")))
+ (if (pair? (cdr a+))
+ (output ","))
+ (loop (cdr a+)))))))
+
+;*---------------------------------------------------------------------*/
+;* mailto ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%mailto)
+ (with-access::%mailto obj (email body)
+ (if (pair? body)
+ (info body)
+ (output email))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%item ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%item)
+ (with-access::%item obj (value body)
+ (if (not (null? value))
+ (begin
+ (info value)
+ (display ": ")))
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%list ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%list)
+ (with-access::%list obj (items kind)
+ (case kind
+ ((itemize)
+ (for-each (lambda (item)
+ (with-justification (make-justifier
+ (-fx (justification-width) 3)
+ 'left)
+ (lambda ()
+ (output "- ")
+ (info item))
+ 3))
+ items))
+ ((enumerate)
+ (let loop ((num 1)
+ (items items))
+ (if (pair? items)
+ (let ((item (car items)))
+ (with-justification (make-justifier
+ (-fx (justification-width) 3)
+ 'left)
+ (lambda ()
+ (output (integer->string num))
+ (output " - ")
+ (info item))
+ 3)
+ (loop (+fx num 1) (cdr items))))))
+ ((description)
+ (for-each (lambda (item)
+ (with-justification
+ (make-justifier
+ (-fx (justification-width) 3)
+ 'left)
+ (lambda ()
+ (with-access::%item item (value body)
+ (output "*")
+ (if (pair? value)
+ (let loop ((vs value))
+ (info (car vs))
+ (if (pair? (cdr vs))
+ (begin
+ (output " ")
+ (loop (cdr vs)))))
+ (info value))
+ (output "* ")
+ (info body)))
+ 3))
+ items))
+ (else
+ (error "info" "Illegal list" kind)))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%section ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%section)
+ (with-access::%section obj (body title)
+ (output-newline)
+ (output-flush *margin*)
+ (let ((t (block-title obj)))
+ (multiple-value-bind (next prev top)
+ (node-next+prev+top obj)
+ (info-node t next prev top)
+ (print t)
+ (print (make-string (string-length t) #\=))))
+ (node-menu obj)
+ (with-justification (make-justifier *text-column-width*
+ *text-justification*)
+ (lambda () (info body)))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%subsection ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%subsection)
+ (with-access::%subsection obj (body title)
+ (output-flush *margin*)
+ (let ((t (block-title obj)))
+ (multiple-value-bind (next prev top)
+ (node-next+prev+top obj)
+ (info-node t next prev top)
+ (print t)
+ (print (make-string (string-length t) #\-))))
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%subsubsection ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%subsubsection)
+ (with-access::%subsubsection obj (body title)
+ (output-flush *margin*)
+ (let ((t (block-title obj)))
+ (multiple-value-bind (next prev top)
+ (node-next+prev+top obj)
+ (info-node t next prev top)
+ (print t)
+ (print (make-string (string-length t) #\~))))
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%paragraph ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%paragraph)
+ (with-access::%paragraph obj (body)
+ (output-newline)
+ (output-flush *margin*)
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%chapter ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%chapter)
+ (with-access::%chapter obj (body file title subtitle)
+ (output-newline)
+ (output-flush *margin*)
+ (let ((t (block-title obj)))
+ (multiple-value-bind (next prev top)
+ (node-next+prev+top obj)
+ (info-node t next prev top)
+ (print t)
+ (print (make-string (string-length t) #\*))))
+ (node-menu obj)
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%hrule ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%hrule)
+ (with-access::%hrule obj (width)
+ (let ((w (if (= width 100)
+ (justification-width)
+ (inexact->exact (* (exact->inexact (justification-width))
+ (/ (exact->inexact width) 100.))))))
+ (output (make-string w #\-)))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%font ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%font)
+ (with-access::%font obj (body)
+ (info body)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%image ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%image)
+ #unspecified)
+
+;*---------------------------------------------------------------------*/
+;* info ::%table ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%table)
+ (with-access::%table obj (border loc)
+ (output-flush *margin*)
+ (if border
+ (border-table->info obj)
+ (table->ascii obj info))
+ (output-flush *margin*)))
+
+;*---------------------------------------------------------------------*/
+;* border-table->info ... */
+;*---------------------------------------------------------------------*/
+(define (border-table->info table)
+ (table->ascii table info))
+
+;*---------------------------------------------------------------------*/
+;* info ::%character ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%character)
+ (case (%character-value obj)
+ ((copyright)
+ (display "(c)"))
+ ((#\space)
+ (display #\space))
+ ((#\tab)
+ (display #\tab))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%hook ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%hook)
+ (with-access::%hook obj (body before after process)
+ (if (procedure? before)
+ (let ((bef (before)))
+ (if process (info bef))))
+ (call-next-method)
+ (if (procedure? after)
+ (let ((af (after)))
+ (if process (info af))))))
+
+;*---------------------------------------------------------------------*/
+;* info ::%figure ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%figure)
+ (with-access::%figure obj (body legend number)
+ (output-newline)
+ (info body)
+ (output-newline)
+ (output-newline)
+ (output "Fig. ")
+ (output (number->string number))
+ (output ": ")
+ (info legend)
+ (output-newline)))
+
+;*---------------------------------------------------------------------*/
+;* info ::%footnote ... */
+;*---------------------------------------------------------------------*/
+(define-method (info obj::%footnote)
+ (with-access::%footnote obj (number note body)
+ (info body)
+ (output (string-append "(*" (number->string number) ")"))))
+
+
+
+;=============== ~/prgm/project/scribe/scribetext/justify.scm ================
+
+;-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----
+;*=====================================================================*/
+;* serrano/prgm/project/scribe/scribetext/justify.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Thu Nov 1 09:21:20 2001 */
+;* Last change : Sun Dec 9 14:59:11 2001 (serrano) */
+;* Copyright : 2001 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The justifiers */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module __scribetext_justify
+
+ (export (make-justifier::procedure ::int ::symbol)
+ (output-flush ::int)
+
+ *text-column-width*
+ *text-justification*
+ *margin*
+
+ (output ::bstring)
+ (output-token ::bstring)
+ (output-center ::bstring)
+ (output-newline)
+ (justification-width::int)
+ (with-justification ::procedure ::procedure . margin)
+ (with-justification/noflush ::procedure ::procedure . margin))
+
+ (eval (export *text-column-width*)
+ (export *text-justification*)))
+
+;*---------------------------------------------------------------------*/
+;* *text-column-width* ... */
+;*---------------------------------------------------------------------*/
+(define *text-column-width* 79)
+(define *text-justification* 'left)
+
+;*---------------------------------------------------------------------*/
+;* text-string ... */
+;*---------------------------------------------------------------------*/
+(define (text-string str)
+ (let ((len (string-length str)))
+ (let loop ((r 0))
+ (cond
+ ((=fx r len)
+ str)
+ ((char=? (string-ref str r) #a008)
+ (string-set! str r #\Space)
+ (loop (+fx r 1)))
+ (else
+ (loop (+fx r 1)))))))
+
+;*---------------------------------------------------------------------*/
+;* string-replace ... */
+;*---------------------------------------------------------------------*/
+(define (string-replace str1 c1 c2)
+ (let* ((len (string-length str1))
+ (str2 (make-string len)))
+ (let loop ((r 0))
+ (if (=fx r len)
+ str2
+ (let ((c (string-ref str1 r)))
+ (if (char=? c c1)
+ (string-set! str2 r c2)
+ (string-set! str2 r c))
+ (loop (+fx r 1)))))))
+
+;*---------------------------------------------------------------------*/
+;* output-center ... */
+;*---------------------------------------------------------------------*/
+(define (output-center str)
+ (let ((justifier (make-justifier (justification-width) 'center)))
+ (with-justification justifier
+ (lambda ()
+ (output str)))))
+
+;*---------------------------------------------------------------------*/
+;* *justifiers* ... */
+;*---------------------------------------------------------------------*/
+(define *justifiers* (list (make-justifier *text-column-width*
+ *text-justification*)))
+(define *margin* 0)
+
+;*---------------------------------------------------------------------*/
+;* output ... */
+;*---------------------------------------------------------------------*/
+(define (output str)
+ ((car *justifiers*) 'output str))
+
+;*---------------------------------------------------------------------*/
+;* output-token ... */
+;* ------------------------------------------------------------- */
+;* Display one string as if it is one token. No matter if it */
+;* contains #\spaces. */
+;*---------------------------------------------------------------------*/
+(define (output-token str)
+ ((car *justifiers*) 'output (string-replace str #\space #a008)))
+
+;*---------------------------------------------------------------------*/
+;* output-newline ... */
+;*---------------------------------------------------------------------*/
+(define (output-newline)
+ ((car *justifiers*) 'newline))
+
+;*---------------------------------------------------------------------*/
+;* pre-output ... */
+;*---------------------------------------------------------------------*/
+(define (pre-output val)
+ ((car *justifiers*) 'pre val))
+
+;*---------------------------------------------------------------------*/
+;* post-output ... */
+;*---------------------------------------------------------------------*/
+(define (post-output val)
+ ((car *justifiers*) 'post val))
+
+;*---------------------------------------------------------------------*/
+;* output-flush ... */
+;*---------------------------------------------------------------------*/
+(define (output-flush margin)
+ (for-each (if (>fx margin 0)
+ (let ((m (make-string margin #\space)))
+ (lambda (x) (print m (text-string x))))
+ (lambda (x) (print (text-string x))))
+ ((car *justifiers*) 'flush)))
+
+;*---------------------------------------------------------------------*/
+;* justification-width ... */
+;*---------------------------------------------------------------------*/
+(define (justification-width)
+ ((car *justifiers*) 'width))
+
+;*---------------------------------------------------------------------*/
+;* with-justification ... */
+;*---------------------------------------------------------------------*/
+(define (with-justification justifier thunk . margin)
+ (output-flush *margin*)
+ (let ((old-margin *margin*))
+ (if (pair? margin) (set! *margin* (+fx *margin* (car margin))))
+ (set! *justifiers* (cons justifier *justifiers*))
+ (thunk)
+ (output-flush *margin*)
+ (set! *justifiers* (cdr *justifiers*))
+ (set! *margin* old-margin)))
+
+;*---------------------------------------------------------------------*/
+;* with-justification/noflush ... */
+;*---------------------------------------------------------------------*/
+(define (with-justification/noflush justifier thunk . margin)
+ (let ((old-margin *margin*))
+ (if (pair? margin) (set! *margin* (+fx *margin* (car margin))))
+ (set! *justifiers* (cons justifier *justifiers*))
+ (thunk)
+ (let ((res ((car *justifiers*) 'flush)))
+ (set! *justifiers* (cdr *justifiers*))
+ (set! *margin* old-margin)
+ res)))
+
+;*---------------------------------------------------------------------*/
+;* *spaces* ... */
+;*---------------------------------------------------------------------*/
+(define *spaces* '(#\Space #\Tab #\Newline))
+
+;*---------------------------------------------------------------------*/
+;* strtok ... */
+;*---------------------------------------------------------------------*/
+(define (strtok str delims)
+ (reverse (kotrts str delims)))
+
+;*---------------------------------------------------------------------*/
+;* kotrts ... */
+;*---------------------------------------------------------------------*/
+(define (kotrts str::bstring delims::pair)
+ (let ((stop (string-length str)))
+ (let loop ((cur 0)
+ (mark #f)
+ (acc '()))
+ (cond
+ ((= cur stop)
+ (if (number? mark)
+ (cons (substring str mark cur) acc)
+ acc))
+ ((memq (string-ref str cur) delims)
+ (loop (+ cur 1)
+ #f
+ (if (number? mark)
+ (cons (substring str mark cur)
+ acc)
+ acc)))
+ (else
+ (loop (+ cur 1)
+ (if (number? mark) mark cur)
+ acc))))))
+
+;*---------------------------------------------------------------------*/
+;* string-insert! ... */
+;*---------------------------------------------------------------------*/
+(define (string-insert! str-to::bstring str-from::bstring offset::int)
+ (let ((len1 (string-length str-to))
+ (len2 (string-length str-from)))
+ (if (> (+ len2 offset) len1)
+ (error "string-insert!" "String too long" str-from)
+ (let loop ((i 0))
+ (if (= i len2)
+ str-to
+ (begin
+ (string-set! str-to
+ (+ i offset)
+ (string-ref str-from i))
+ (loop (+ i 1))))))))
+
+;*---------------------------------------------------------------------*/
+;* make-justified-line ... */
+;*---------------------------------------------------------------------*/
+(define (make-justified-line tokens::pair-nil width::int)
+ (let ((result (make-string width #\space)))
+ (cond
+ ((null? tokens)
+ result)
+ ((null? (cdr tokens))
+ (string-insert! result (car tokens) 0))
+ (else
+ (let* ((nb-tokens (length tokens))
+ (nb-chars (apply + (map string-length
+ tokens)))
+ (all-spaces (- width nb-chars))
+ (one-spaces (/ all-spaces
+ (- nb-tokens 1)))
+ (cursor (string-length (car tokens))))
+ (string-insert! result (car tokens) 0)
+ (let loop ((tokens (cdr tokens))
+ (cursor cursor))
+ (if (null? (cdr tokens))
+ (let* ((len (string-length
+ (car tokens)))
+ (cursor (- width len)))
+ (string-insert! result
+ (car tokens)
+ cursor)
+ result)
+ (let* ((token (car tokens))
+ (token-ln (string-length token))
+ (n-cursor (+ cursor
+ token-ln
+ one-spaces))
+ (offset (inexact->exact
+ (round
+ (+ cursor
+ one-spaces)))))
+ (string-insert! result token offset)
+ (loop (cdr tokens) n-cursor)))))))))
+
+;*---------------------------------------------------------------------*/
+;* make-formated-line ... */
+;*---------------------------------------------------------------------*/
+(define (make-formated-line tokens::pair-nil width::int cursor::int)
+ (let ((result (make-string width #\space)))
+ (if (null? tokens)
+ result
+ (let loop ((toks tokens)
+ (cur cursor))
+ (if (null? toks)
+ result
+ (begin
+ (string-insert! result (car toks) cur)
+ (loop (cdr toks)
+ (+ 1
+ cur
+ (string-length
+ (car toks))))))))))
+
+;*---------------------------------------------------------------------*/
+;* make-centered-line ... */
+;*---------------------------------------------------------------------*/
+(define (make-centered-line tokens::pair-nil width::int)
+ (make-formated-line tokens
+ width
+ (quotient (- width
+ (+ (apply + (map string-length tokens))
+ (- (length tokens) 1)))
+ 2)))
+
+;*---------------------------------------------------------------------*/
+;* make-flushleft-line ... */
+;*---------------------------------------------------------------------*/
+(define (make-flushleft-line tokens::pair-nil width::int)
+ (make-formated-line tokens width 0))
+
+;*---------------------------------------------------------------------*/
+;* make-flushright-line ... */
+;*---------------------------------------------------------------------*/
+(define (make-flushright-line tokens::pair-nil width::int)
+ (make-formated-line tokens
+ width
+ (- width
+ (+ (apply + (map string-length tokens))
+ (- (length tokens) 1)))))
+
+;*---------------------------------------------------------------------*/
+;* tokens-justify ... */
+;*---------------------------------------------------------------------*/
+(define (tokens-justify justifier::procedure tokens::pair-nil width::int)
+ (define (reverse-line lines)
+ (let ((nl (string #\Newline)))
+ (let loop ((ls lines)
+ (acc ""))
+ (if (null? ls)
+ acc
+ (loop (cdr ls) (string-append (car ls) nl acc))))))
+ (let loop ((tokens tokens)
+ (line-len 0)
+ (line '())
+ (acc '()))
+ (if (null? tokens)
+ (reverse! (cons (justifier (reverse line) width) acc))
+ (let ((tok (car tokens)))
+ (cond
+ ((eq? tok 'NEWLINE)
+ (loop (cdr tokens)
+ 0
+ '()
+ (cons (justifier (reverse line) width) acc)))
+ (else
+ (let ((toklen (string-length tok)))
+ (cond
+ ((>= toklen width)
+ (let ((jl (justifier (list (substring tok 0 width))
+ width))
+ (ll (if (pair? line)
+ (cons (justifier (reverse line) width)
+ acc)
+ acc)))
+ (loop (cdr tokens)
+ 0
+ '()
+ (cons jl ll))))
+ ((>= (+ toklen line-len) width)
+ (loop tokens
+ 0
+ '()
+ (cons (justifier (reverse line) width) acc)))
+ (else
+ (loop (cdr tokens)
+ (+ line-len toklen 1)
+ (cons tok line)
+ acc))))))))))
+
+;*---------------------------------------------------------------------*/
+;* make-justifier ... */
+;*---------------------------------------------------------------------*/
+(define (make-justifier width policy)
+ (let ((tokens '()))
+ (if (eq? policy 'verbatim)
+ (lambda (cmd . vals)
+ (case cmd
+ ((output)
+ (set! tokens (append (reverse vals) tokens)))
+ ((newline)
+ (set! tokens (cons "\n" tokens)))
+ ((flush)
+ (let ((str (apply string-append (reverse! tokens))))
+ (set! tokens '())
+ (list str)))
+ ((width)
+ width)))
+ (let ((justifier (case policy
+ ((center)
+ make-centered-line)
+ ((flushleft left)
+ make-flushleft-line)
+ ((flushright right)
+ make-flushright-line)
+ ((justify)
+ make-justified-line)
+ (else
+ make-justified-line)))
+ (last ""))
+ (lambda (cmd . vals)
+ (case cmd
+ ((newline)
+ (set! tokens (cons 'NEWLINE
+ (append (kotrts last *spaces*) tokens)))
+ (set! last ""))
+ ((output)
+ (if (pair? vals)
+ (let* ((val0 (string-append last (car vals)))
+ (vals (cons val0 (cdr vals))))
+ (let loop ((vals vals)
+ (toks tokens))
+ (cond
+ ((null? vals)
+ (set! last "")
+ (set! tokens toks))
+ ((and (null? (cdr vals))
+ (string? (car vals)))
+ (set! last (car vals))
+ (set! tokens toks))
+ (else
+ (loop (cdr vals)
+ (append (kotrts (car vals) *spaces*)
+ toks))))))))
+ ((flush)
+ (let ((ntokens (append (kotrts last *spaces*) tokens)))
+ (set! last "")
+ (if (pair? ntokens)
+ (let ((toks (reverse! ntokens)))
+ (set! tokens '())
+ (tokens-justify justifier toks width))
+ '())))
+ ((width)
+ width)
+ (else
+ (error "justifier" "Illegal command" cmd))))))))
+
+(define (my-string-append . s)
+ (newline (current-error-port))
+ (fprint (current-error-port) "s: " s)
+ (apply string-append s))
+