considerations

main
Matthew Butterick 10 years ago
parent c8446e58d8
commit e8e4e74fe9

@ -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))))

@ -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)

@ -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))))

Loading…
Cancel
Save