From 28b6cdaca669977b7ae69c4272f4c121372cb776 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Oct 2008 00:15:43 +0200 Subject: Separate `justify' module from Info engine. --- src/guile/skribilo/engine/info.scm | 428 +---------------------------------- src/guile/skribilo/utils/justify.scm | 425 ++++++++++++++++++++++++++++++++++ 2 files changed, 426 insertions(+), 427 deletions(-) create mode 100644 src/guile/skribilo/utils/justify.scm diff --git a/src/guile/skribilo/engine/info.scm b/src/guile/skribilo/engine/info.scm index de2cab6..e4d3ceb 100644 --- a/src/guile/skribilo/engine/info.scm +++ b/src/guile/skribilo/engine/info.scm @@ -32,6 +32,7 @@ :autoload (skribilo evaluator) (evaluate-document) :autoload (skribilo output) (output) :autoload (skribilo debug) (*debug*) + :autoload (skribilo utils justify) (make-justifier) :use-module (srfi srfi-8) :use-module (srfi srfi-13) @@ -701,430 +702,3 @@ (output label e) (output ")" e)))) - - -;=============== ~/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)) - diff --git a/src/guile/skribilo/utils/justify.scm b/src/guile/skribilo/utils/justify.scm new file mode 100644 index 0000000..8e069af --- /dev/null +++ b/src/guile/skribilo/utils/justify.scm @@ -0,0 +1,425 @@ +;=============== ~/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)) + -- cgit v1.2.3