diff --git a/quad/main.rkt b/quad/main.rkt index a0cf4fc6..09ba3dd5 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 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+provide/contract (block->lines token-refs) + ((listof integer?) . -> . lines?) + + (define quality (report (calc-attrs (car token-refs)))) + (error 'zam) + (define b #f) (define (wrap-quads qs) (define wrap-proc (cond [(>= quality world:max-quality) wrap-best] @@ -214,33 +214,14 @@ [else x])) -(define-syntax-rule (cons-reverse x y) - (cons (reverse x) y)) - ;; page breaks > column breaks > block breaks > line breaks -(define/contract (typeset2 x) +(define/contract (typeset2 q) (coerce/input? . -> . any) - (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))))))) - + (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)))) + (module+ main (require "render.rkt" racket/class profile) @@ -249,6 +230,6 @@ (parameterize ([world:quality-default world:draft-quality] [world:paper-width-default 600] [world:paper-height-default 700]) - (define ti (block '(measure 54 leading 18) "Meg is" (block-break) " ally.")) + (define ti (block '(measure 54 quality 0) "Meg is an ally.")) (define j (jude0)) (time (typeset2 ti)))) \ No newline at end of file diff --git a/quad/quads.rkt b/quad/quads.rkt index 32578d16..428bbb8f 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)) - (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)))] + (~a (quad-attrs b)) + (if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) " ")) (void)))) " ")) port)))] #:property prop:sequence (λ(q) (quad-list q))) @@ -52,10 +52,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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) (hash? x))) -(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (and (string? xi) (< 0 (string-length xi))))) 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 (quads? x) (and (list? x) (andmap quad? x))) (define (lists-of-quads? x) (and (list? x) (andmap quads? x))) @@ -169,7 +170,8 @@ ;; 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?) - (quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs)) + (with-handlers ([exn:fail? (λ(exn) (error 'id "constructor failure with args: ~v ~v" attrs xs))]) + (quad 'id 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 56d6b952..d45e7ece 100644 --- a/quad/tokenize.rkt +++ b/quad/tokenize.rkt @@ -49,22 +49,43 @@ (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 (quad->current-tokens q) +(define+provide (input->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 (calc-attrs tref) + +(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) (map attr-ref-hash (filter (λ(attr) (<= (attr-ref-start attr) tref (sub1 (attr-ref-end attr)))) (current-token-attrs))))