diff --git a/quad/main.rkt b/quad/main.rkt index 09ba3dd5..a0cf4fc6 100644 --- a/quad/main.rkt +++ b/quad/main.rkt @@ -45,12 +45,12 @@ (quad->string line) (quad-attr-ref line world:line-looseness-key)))) (require racket/trace) -(define+provide/contract (block->lines token-refs) - ((listof integer?) . -> . lines?) - - (define quality (report (calc-attrs (car token-refs)))) - (error 'zam) - (define b #f) +(define+provide/contract (block->lines b-in) + (block? . -> . lines?) + (define b (if (ormap string? (quad-list b-in)) + (quads->block (split-quad b-in)) + b-in)) + (define quality (quad-attr-ref/parameter b world:quality-key)) (define (wrap-quads qs) (define wrap-proc (cond [(>= quality world:max-quality) wrap-best] @@ -214,14 +214,33 @@ [else x])) +(define-syntax-rule (cons-reverse x y) + (cons (reverse x) y)) + ;; page breaks > column breaks > block breaks > line breaks -(define/contract (typeset2 q) +(define/contract (typeset2 x) (coerce/input? . -> . any) - (input->current-tokens q) - (define mps (current-tokens->multipages)) - (for* ([mp (in-list (reverse mps))][mc (in-list mp)][b (in-list mc)]) - (block->lines (report b)))) - + (quad->current-tokens x) + (define-values (mps mcs mbs b) + (for/fold ([multipages empty][multicolumns empty][multiblocks empty][block empty]) + ([token (in-vector (current-tokens))]) + (cond + [(or (page-break? token) (eof? token)) (values (cons (cons (cons block multiblocks) multicolumns) multipages) empty empty empty)] + [(column-break? token) (values multipages (cons (cons block multiblocks) multicolumns) empty empty)] + [(block-break? token) (values multipages multicolumns (cons block multiblocks) empty)] + [else (values multipages multicolumns multiblocks (cons token block))]))) + mps) + +(define/contract (typeset3 x) + (coerce/input? . -> . any) + (quad->current-tokens x) + (for/last ([token (in-vector (current-tokens))]) + (for/list ([mp (in-naturals)]) + (for/list ([mc (in-naturals)] #:break (or (page-break? token) (eof? token))) + (for/list ([mb (in-naturals)] #:break (column-break? token)) + (for/list ([b (in-naturals)] #:break (block-break? token)) + (report token))))))) + (module+ main (require "render.rkt" racket/class profile) @@ -230,6 +249,6 @@ (parameterize ([world:quality-default world:draft-quality] [world:paper-width-default 600] [world:paper-height-default 700]) - (define ti (block '(measure 54 quality 0) "Meg is an ally.")) + (define ti (block '(measure 54 leading 18) "Meg is" (block-break) " ally.")) (define j (jude0)) (time (typeset2 ti)))) \ No newline at end of file diff --git a/quad/quads.rkt b/quad/quads.rkt index 428bbb8f..32578d16 100644 --- a/quad/quads.rkt +++ b/quad/quads.rkt @@ -10,8 +10,8 @@ [(define write-proc (λ(b port mode) (display (format "(~a)" (string-join (filter-not void? (list (~a (quad-name b)) - (~a (quad-attrs b)) - (if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) " ")) (void)))) " ")) port)))] + (if (and (hash? (quad-attrs b)) (> (length (hash-keys (quad-attrs b))) 0)) (~v (flatten (hash->list (quad-attrs b)))) (void)) + (if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) "")) (void)))) " ")) port)))] #:property prop:sequence (λ(q) (quad-list q))) @@ -52,11 +52,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (token-ref? x) (integer? x)) (define (quad-name? x) (symbol? x)) (define (hashable-list? x) (and (list? x) (even? (length x)))) -(define (quad-attrs? x) (or (false? x) (token-ref? x))) -(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (token-ref? xi) (and (string? xi) (< 0 (string-length xi))))) x))) +(define (quad-attrs? x) (or (false? x) (hash? x))) +(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (and (string? xi) (< 0 (string-length xi))))) x))) (define (quads? x) (and (list? x) (andmap quad? x))) (define (lists-of-quads? x) (and (list? x) (andmap quads? x))) @@ -170,8 +169,7 @@ ;; but don't put a separate contract on struct, because it's superfluous. (define/contract (id [attrs #f] . xs) (() ((or/c quad-attrs? hashable-list?)) #:rest quad-list? . ->* . id?) - (with-handlers ([exn:fail? (λ(exn) (error 'id "constructor failure with args: ~v ~v" attrs xs))]) - (quad 'id attrs xs))) + (quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs)) ;; quad list predicate and list-of-list predicate. ;; These are faster than the listof contract combinator. (define (ids? x) diff --git a/quad/tokenize.rkt b/quad/tokenize.rkt index d45e7ece..56d6b952 100644 --- a/quad/tokenize.rkt +++ b/quad/tokenize.rkt @@ -49,43 +49,22 @@ (values (list->vector (reverse (cons (current-eof) (flatten all-tokens)))) (flatten all-attrs))) + (define+provide current-tokens (make-parameter #f)) (define+provide current-token-attrs (make-parameter #f)) (define+provide current-eof (make-parameter (gensym))) (define+provide (eof? x) (equal? x (current-eof))) -(define+provide (input->current-tokens q) +(define+provide (quad->current-tokens q) (define-values (tokens attrs) (make-tokens-and-attrs q)) (current-tokens tokens) (current-token-attrs attrs)) -(define+provide (token-ref i) (vector-ref (current-tokens) i)) - -(define+provide (print-token-tree x) - (cond - [(list? x) (map print-token-tree x)] - [else (format "~a" (token-ref x))])) - ;(filter (λ(idx) (box? (vector-ref tokens idx))) (range (vector-length tokens))) (define (attr-ref-hash a) (vector-ref a 0)) (define (attr-ref-start a) (vector-ref a 1)) (define (attr-ref-end a) (vector-ref a 2)) - -(define-syntax-rule (cons-reverse x y) - (cons (reverse x) y)) - -(define+provide (current-tokens->multipages) - (define-values (mps mcs bs b) - (for/fold ([multipages empty][multicolumns empty][blocks empty][block-acc empty]) - ([(token tidx) (in-indexed (current-tokens))]) - (cond - [(or (page-break? token) (eof? token)) (values (cons-reverse (cons-reverse (cons-reverse block-acc blocks) multicolumns) multipages) empty empty empty)] - [(column-break? token) (values multipages (cons-reverse (cons-reverse block-acc blocks) multicolumns) empty empty)] - [(block-break? token) (values multipages multicolumns (cons-reverse block-acc blocks) empty)] - [else (values multipages multicolumns blocks (cons tidx block-acc))]))) - (reverse mps)) - -(define+provide (calc-attrs tref) +(define (calc-attrs tref) (map attr-ref-hash (filter (λ(attr) (<= (attr-ref-start attr) tref (sub1 (attr-ref-end attr)))) (current-token-attrs))))