From 71491efc4579d79fe6617c70200512961a200ebd Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 12 Mar 2015 14:26:00 -0700 Subject: [PATCH] partial typing --- quad/main-typed-tests.rkt | 4 -- quad/main-typed.rkt | 108 +++++++++++++++++++++++++++++++++----- quad/main.rkt | 4 +- quad/quads-typed.rkt | 19 +++++-- quad/utils-typed.rkt | 94 +++++++++++++++++---------------- quad/wrap-typed.rkt | 31 ++++++----- 6 files changed, 180 insertions(+), 80 deletions(-) diff --git a/quad/main-typed-tests.rkt b/quad/main-typed-tests.rkt index 732e20e2..e2ae58e8 100644 --- a/quad/main-typed-tests.rkt +++ b/quad/main-typed-tests.rkt @@ -23,7 +23,3 @@ (check-equal? (log-debug-lines (list (line (list world:line-looseness-key 42.0) (word #f "bar")))) '("0/1: \"bar\" 42.0")) - - -;; todo next: debug this line -(block->lines (block #f (word '(measure 50.0) "Meg is an ally."))) \ No newline at end of file diff --git a/quad/main-typed.rkt b/quad/main-typed.rkt index 050d6a70..abdd8c1a 100644 --- a/quad/main-typed.rkt +++ b/quad/main-typed.rkt @@ -10,8 +10,7 @@ (All (A B) ((Listof A) (Listof B) -> (Pairof (Listof A) (Listof B)))) ((inst cons (Listof A) (Listof B)) ((inst reverse A) xs) ys)) -(provide input->nested-blocks) -(define/typed (input->nested-blocks i) +(define/typed+provide (input->nested-blocks i) (Quad . -> . (Listof Multipage-Type)) (define-values (mps mcs bs b) (for/fold ([multipages : (Listof Multipage-Type) empty] @@ -26,20 +25,17 @@ [else (values multipages multicolumns blocks (cons q block-acc))]))) (reverse (cons-reverse (cons-reverse ((inst cons-reverse Quad Block-Type) b bs) mcs) mps))) -(provide merge-adjacent-within) -(define/typed (merge-adjacent-within q) +(define/typed+provide (merge-adjacent-within q) (Quad . -> . Quad) (quad (quad-name q) (quad-attrs q) (join-quads (cast (quad-list q) (Listof Quad))))) -(provide hyphenate-quad-except-last-word) -(define/typed (hyphenate-quad-except-last-word q) +(define/typed+provide (hyphenate-quad-except-last-word q) (Quad . -> . Quad) (log-quad-debug "last word will not be hyphenated") (define-values (first-quads last-quad) ((inst split-last QuadListItem) (quad-list q))) (quad (quad-name q) (quad-attrs q) (snoc ((inst map QuadListItem QuadListItem) hyphenate-quad first-quads) last-quad))) -(provide average-looseness) -(define/typed (average-looseness lines) +(define/typed+provide (average-looseness lines) ((Listof Quad) . -> . Flonum) (if (<= (length lines) 1) 0.0 @@ -47,8 +43,7 @@ (round-float (/ (foldl fl+ 0.0 ((inst map Flonum Quad) (λ(line) (cast (quad-attr-ref line world:line-looseness-key 0.0) Flonum)) lines-to-measure)) (- (fl (length lines)) 1.0)))))) -(provide log-debug-lines) -(define/typed (log-debug-lines lines) +(define/typed+provide (log-debug-lines lines) ((Listof Quad) . -> . (Listof String)) (log-quad-debug "line report:") (for/list : (Listof String) ([(line idx) (in-indexed lines)]) @@ -58,8 +53,7 @@ (quad-attr-ref line world:line-looseness-key)))) -(provide block->lines) -(define/typed (block->lines b) +(define/typed+provide (block->lines b) (Quad . -> . (Listof Quad)) ;; todo: introduce a Quad subtype where quad-list is guaranteed to be all Quads (no strings) (define quality (cast (quad-attr-ref/parameter b world:quality-key) Real)) (define/typed (wrap-quads qs) @@ -93,3 +87,93 @@ (map insert-spacers-in-line (for/list : (Listof Quad) ([line-idx (in-naturals)][line (in-list wrapped-lines)]) (quad-attr-set* line 'line-idx line-idx 'lines (length wrapped-lines))))) + + +(define/typed+provide (number-pages ps) + ((Listof Quad) . -> . (Listof Quad)) + (for/list ([i (in-naturals)][p (in-list ps)]) + (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p)))) + +(define/typed+provide (pages->doc ps) + ((Listof Quad) . -> . Quad) + ;; todo: resolve xrefs and other last-minute tasks + ;; todo: generalize computation of widths and heights, recursively + (define (columns-mapper page) + (quad-map (compose1 add-vert-positions (λ(xs) (quad-map (λ(x) (compute-line-height (add-horiz-positions (fill (cast x Quad))))) (cast xs Quad)))) (cast page Quad))) + (define mapped-pages (map columns-mapper (number-pages ps))) + (define doc (quads->doc mapped-pages)) + doc) + +(require racket/class) +(require/typed csp + [problem% (Class (init-field) + (get-solution (-> HashTableTop)))]) +(define/typed+provide (lines->columns lines) + ((Listof Quad) . -> . (Listof Quad)) ; (lines? . -> . columns?) + (define prob (new problem%)) + #;(define max-column-lines world:default-lines-per-column) + (define-values (columns ignored-return-value) + (for/fold ([columns : (Listof Quad) empty][lines-remaining : (Listof Quad) lines]) + ([col-idx : Nonnegative-Integer (stop-before (in-naturals) (λ(x) (empty? lines-remaining)))]) + #;(log-quad-info "making column ~a" (add1 col-idx)) + ;; domain constraint is best way to simplify csp, because it limits the search space. + ;; search from largest possible value to smallest. + ;; largest possible is the minimum of the max column lines, or + ;; the number of lines left (modulo minimum page lines) ... + #;(define viable-column-range + (range (min max-column-lines (max + (length lines-remaining) + (- (length lines-remaining) world:minimum-lines-per-column))) + ;; ... and the smallest possible is 1, or the current minimum lines. + ;; (sub1 insures that range is inclusive of last value.) + (sub1 (min 1 world:minimum-lines-per-column)) -1)) + + #;(log-quad-debug "viable number of lines for this column to start =\n~a" viable-column-range) + #;(send prob add-variable "column-lines" viable-column-range) + + + ;; greediness constraint: leave enough lines for next page, or take all + #;(define (greediness-constraint pl) + (define leftover (- (length lines-remaining) pl)) + (or (= leftover 0) (>= leftover world:minimum-lines-per-column))) + #;(send prob add-constraint greediness-constraint '("column-lines")) + + #;(log-quad-debug "viable number of lines after greediness constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions))) + + ;; last lines constraint: don't take page that will end with too few lines of last paragraph. + #;(define (last-lines-constraint pl) + (define last-line-of-page (list-ref lines-remaining (sub1 pl))) + (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) + (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) + (define (paragraph-too-short-to-meet-constraint?) + (< lines-in-this-paragraph world:min-last-lines)) + (or (paragraph-too-short-to-meet-constraint?) + (>= (add1 line-index-of-last-line) world:min-last-lines))) + #;(send prob add-constraint last-lines-constraint '("column-lines")) + + #;(log-quad-debug "viable number of lines after last-lines constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions))) + + ;; first lines constraint: don't take page that will leave too few lines at top of next page + #;(define (first-lines-constraint pl lines-remaining) + (define last-line-of-page (list-ref lines-remaining (sub1 pl))) + (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) + (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) + (define lines-that-will-remain (- lines-in-this-paragraph (add1 line-index-of-last-line))) + (define (paragraph-too-short-to-meet-constraint?) + (< lines-in-this-paragraph world:min-first-lines)) + (or (paragraph-too-short-to-meet-constraint?) + (= 0 lines-that-will-remain) ; ok to use all lines ... + (>= lines-that-will-remain world:min-first-lines))) ; but if any remain, must be minimum number. + #;(send prob add-constraint (λ(x) (first-lines-constraint x lines-remaining)) '("column-lines")) + + #;(log-quad-debug "viable number of lines after first-lines constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions))) + + + (define s (send prob get-solution)) + (define how-many-lines-to-take (cast (hash-ref s "column-lines") Positive-Index)) + (define-values (lines-to-take lines-to-leave) (split-at lines-remaining how-many-lines-to-take)) + #;(log-quad-debug "taking ~a lines for column ~a:" how-many-lines-to-take (add1 col-idx)) + #;(map (λ(idx line) (log-quad-debug "~a:~a ~v" (add1 col-idx) (add1 idx) (quad->string line))) (range how-many-lines-to-take) lines-to-take) + #;(send prob reset) + (values (cons (quad-attr-set (quads->column lines-to-take) world:column-index-key col-idx) columns) lines-to-leave))) + (reverse columns)) diff --git a/quad/main.rkt b/quad/main.rkt index ca4cfd57..255e7fb9 100644 --- a/quad/main.rkt +++ b/quad/main.rkt @@ -80,9 +80,7 @@ (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p)))) (define+provide/contract (pages->doc ps) - (pages? . -> . doc?) - (map quad-attrs (quad-list (first ps))) - + (pages? . -> . doc?) ;; todo: resolve xrefs and other last-minute tasks ;; todo: generalize computation of widths and heights, recursively (define (columns-mapper page) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 176cdb86..7dc7ef14 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -21,6 +21,20 @@ (: proc-name type-expr) (define proc-name body ...))])) +(define-syntax (define/typed+provide stx) + (syntax-case stx () + [(_ (proc-name arg ... . rest-arg) type-expr body ...) + #'(begin + (provide proc-name) + (define/typed proc-name type-expr + (λ(arg ... . rest-arg) body ...)))] + [(_ proc-name type-expr body ...) + #'(begin + (provide proc-name) + (begin + (: proc-name type-expr) + (define proc-name body ...)))])) + (define-syntax-rule (even-members xs) (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i)) @@ -98,9 +112,8 @@ [(string? x) x] [else ""]))) -(provide gather-common-attrs) -(: gather-common-attrs ((Listof Quad) . -> . (U False HashableList))) -(define (gather-common-attrs qs) +(define/typed+provide (gather-common-attrs qs) + ((Listof Quad) . -> . (U False HashableList)) (: check-cap (QuadAttrPair . -> . Boolean)) (define (check-cap cap) (equal? (quad-attr-ref (car qs) (car cap) attr-missing) (cdr cap))) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 9130563e..7b8a294c 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -5,8 +5,7 @@ (require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool racket/function math/flonum) (require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt") -(provide quad-map) -(define/typed (quad-map proc q) +(define/typed+provide (quad-map proc q) ((QuadListItem . -> . QuadListItem) Quad . -> . Quad) (quad (quad-name q) (quad-attrs q) (map proc (quad-list q)))) @@ -22,9 +21,8 @@ ;; push together multiple attr sources into one list of pairs. ;; mostly a helper function for the two attr functions below. -(provide join-attrs) -(: join-attrs ((Listof (U Quad QuadAttrs HashableList)) . -> . (Listof QuadAttrPair))) -(define (join-attrs quads-or-attrs-or-lists) +(define/typed+provide (join-attrs quads-or-attrs-or-lists) + ((Listof (U Quad QuadAttrs HashableList)) . -> . (Listof QuadAttrPair)) ((inst append-map QuadAttrPair QuadAttrs) (inst hash->list QuadAttrKey QuadAttrValue) (map (λ(x) (cond [(quad? x) (quad-attrs x)] @@ -36,9 +34,8 @@ ;; flatten merges attributes, but applies special logic suitable to flattening ;; for instance, resolving x and y coordinates. -(provide flatten-attrs) -(: flatten-attrs ((U Quad QuadAttrs) * . -> . QuadAttrs)) -(define (flatten-attrs . quads-or-attrs-or-falses) +(define/typed+provide (flatten-attrs . quads-or-attrs-or-falses) + ((U Quad QuadAttrs) * . -> . QuadAttrs) (define all-attrs (join-attrs quads-or-attrs-or-falses)) (define-values (x-attrs y-attrs other-attrs-reversed) (for/fold ([xas : (Listof QuadAttrPair) null] @@ -61,9 +58,8 @@ ;; merge concatenates attributes, with later ones overriding earlier. ;; most of the work is done by join-attrs. -(provide merge-attrs) -(: merge-attrs ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs)) -(define (merge-attrs . quads-or-attrs-or-lists) +(define/typed+provide (merge-attrs . quads-or-attrs-or-lists) + ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs) (for/hash : QuadAttrs ([kv-pair (in-list (join-attrs quads-or-attrs-or-lists))]) (values (car kv-pair) (cdr kv-pair)))) @@ -71,9 +67,8 @@ ;; pushes attributes down from parent quads to children, ;; resulting in a flat list of quads. -(provide flatten-quad) -(: flatten-quad (Quad . -> . (Listof Quad))) -(define (flatten-quad q) +(define/typed+provide (flatten-quad q) + (Quad . -> . (Listof Quad)) (cast (flatten (let loop : (Treeof Quad) ([x : QuadListItem q][parent : Quad (box)]) @@ -93,9 +88,8 @@ ;; flatten quad as above, ;; then dissolve it into individual character quads while copying attributes ;; input is often large, so macro allows us to avoid allocation -(provide split-quad) -(: split-quad (Quad . -> . (Listof Quad))) -(define (split-quad q) +(define/typed+provide (split-quad q) + (Quad . -> . (Listof Quad)) (: do-explode ((QuadListItem) (Quad) . ->* . (Treeof Quad))) (define (do-explode x [parent (box)]) (cond @@ -112,8 +106,7 @@ ;; if two quads are mergeable types, and have the same attributes, ;; they get merged. ;; input is often large, so macro allows us to avoid allocation -(provide join-quads) -(define/typed (join-quads qs-in) +(define/typed+provide (join-quads qs-in) ((Listof Quad) . -> . (Listof Quad)) (let ([make-matcher (λ ([base-q : Quad]) @@ -148,9 +141,8 @@ ;; propagate x and y adjustments throughout the tree, ;; using parent x and y to adjust children, and so on. -(provide compute-absolute-positions) -(: compute-absolute-positions (Quad . -> . Quad)) -(define (compute-absolute-positions qli) +(define/typed+provide (compute-absolute-positions qli) + (Quad . -> . Quad) (define result (let loop : QuadListItem ([qli : QuadListItem qli][parent-x : Flonum 0.0][parent-y : Flonum 0.0]) (cond @@ -166,39 +158,34 @@ ;; functionally update a quad attr. Similar to hash-set -(provide quad-attr-set) -(: quad-attr-set (Quad QuadAttrKey QuadAttrValue . -> . Quad)) -(define (quad-attr-set q k v) +(define/typed+provide (quad-attr-set q k v) + (Quad QuadAttrKey QuadAttrValue . -> . Quad) (quad (quad-name q) (merge-attrs (quad-attrs q) (list k v)) (quad-list q))) ;; functionally update multiple quad attrs. Similar to hash-set* -(provide quad-attr-set*) -(: quad-attr-set* (Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad)) -(define (quad-attr-set* q . kvs) +(define/typed+provide (quad-attr-set* q . kvs) + (Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad) (for/fold ([current-q q])([kv-list (in-list (slice-at kvs 2))]) (apply quad-attr-set current-q kv-list))) ;; functionally remove a quad attr. Similar to hash-remove -(provide quad-attr-remove) -(: quad-attr-remove (Quad QuadAttrKey . -> . Quad)) -(define (quad-attr-remove q k) +(define/typed+provide (quad-attr-remove q k) + (Quad QuadAttrKey . -> . Quad) (if (quad-attrs q) (quad (quad-name q) (hash-remove (quad-attrs q) k) (quad-list q)) q)) ;; functionally remove multiple quad attrs. Similar to hash-remove* -(provide quad-attr-remove*) -(: quad-attr-remove* (Quad QuadAttrKey * . -> . Quad)) -(define (quad-attr-remove* q . ks) +(define/typed+provide (quad-attr-remove* q . ks) + (Quad QuadAttrKey * . -> . Quad) (for/fold ([current-q q])([k (in-list ks)]) (quad-attr-remove current-q k))) ;; the last char of a quad -(provide quad-last-char) -(: quad-last-char (Quad . -> . (Option String))) -(define (quad-last-char q) +(define/typed+provide (quad-last-char q) + (Quad . -> . (Option String)) (define split-qs (split-quad q)) ; split makes it simple, but is it too expensive? (if (or (empty? split-qs) (empty? (quad-list (last split-qs)))) #f @@ -208,9 +195,8 @@ result)))) ;; the first char of a quad -(provide quad-first-char) -(: quad-first-char (Quad . -> . (Option String))) -(define (quad-first-char q) +(define/typed+provide (quad-first-char q) + (Quad . -> . (Option String)) (define split-qs (split-quad q)) ; explosion makes it simple, but is it too expensive? (if (or (empty? split-qs) (empty? (quad-list (first split-qs)))) #f @@ -220,9 +206,30 @@ result)))) +;; todo: how to guarantee line has leading key? +(define/typed+provide (compute-line-height line) + (Quad . -> . Quad) + (quad-attr-set line world:height-key (quad-attr-ref/parameter line world:leading-key))) + +(define/typed (fixed-height? q) + (Quad . -> . Boolean) + (quad-has-attr? q world:height-key)) + +(define/typed+provide (quad-height q) + (Quad . -> . Flonum) + (cast (quad-attr-ref q world:height-key 0.0) Flonum)) + +;; use heights to compute vertical positions +(define/typed+provide (add-vert-positions starting-quad) + (Quad . -> . Quad) + (define-values (new-quads final-height) + (for/fold ([new-quads : (Listof Quad) empty][height-so-far : Flonum 0.0])([q (in-list (cast (quad-list starting-quad) (Listof Quad)))]) + (values (cons (quad-attr-set q world:y-position-key height-so-far) new-quads) + (round-float (+ height-so-far (quad-height q)))))) + (quad (quad-name starting-quad) (quad-attrs starting-quad) (reverse new-quads))) + ;; recursively hyphenate strings in a quad -(provide hyphenate-quad) -(define/typed (hyphenate-quad x) +(define/typed+provide (hyphenate-quad x) (QuadListItem . -> . QuadListItem) (cond [(quad? x) (quad-map hyphenate-quad x)] @@ -233,8 +240,7 @@ [else x])) ;; just because it comes up a lot -(provide split-last) -(define/typed (split-last xs) +(define/typed+provide (split-last xs) (All (A) ((Listof A) -> (values (Listof A) A))) (let-values ([(first-list last-list) ((inst split-at-right A) xs 1)]) (values first-list (car last-list)))) diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index d38476cd..ed2ee4c1 100644 --- a/quad/wrap-typed.rkt +++ b/quad/wrap-typed.rkt @@ -222,8 +222,7 @@ ;; spacers are used to soak up extra space left over in a line. ;; depending on where the spacers are inserted, different formatting effects are achieved. ;; e.g., left / right / centered / justified. -(provide insert-spacers-in-line) -(define/typed (insert-spacers-in-line line [alignment-override #f]) +(define/typed+provide (insert-spacers-in-line line [alignment-override #f]) ((Quad) ((Option Symbol)) . ->* . Quad) ;; important principle: avoid peeking into quad-list to get attributes. ;; because non-attributed quads may be added. @@ -252,12 +251,14 @@ (quad (quad-name line) (quad-attrs line) (cast (flatten (let ([qs (cast (quad-list line) (Listof Quad))]) - `(,@(cast (if before (copy-with-attrs before (first qs)) null) (Listof Quad)) + ;; (first qs) is a single quad, but wrap it in a list to make it spliceable + `(,@(cast (if before (list (copy-with-attrs before (first qs))) null) (Listof Quad)) ,@(map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) (let ([interleaver (copy-with-attrs middle q)]) (list interleaver q interleaver)) q)) qs) - ,@(cast (if after (copy-with-attrs after (last qs)) null) (Listof Quad)) + ;; (last qs) is a single quad, but wrap it in a list to make it spliceable + ,@(cast (if after (list (copy-with-attrs after (last qs))) null) (Listof Quad)) ))) QuadList))) @@ -524,23 +525,25 @@ ;; wrap proc based on greedy proc -(provide wrap-first) -(define wrap-first (make-wrap-proc +(define-syntax-rule (define+provide name expr ...) + (begin + (provide name) + (define name expr ...))) + +(define+provide wrap-first (make-wrap-proc make-pieces quad-width pieces->line (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #t #f)))) ;; wrap proc based on penalty function -(provide wrap-best) -(define wrap-best (make-wrap-proc +(define+provide wrap-best (make-wrap-proc make-pieces quad-width pieces->line - (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #f #t)))) + (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #f #t)))) ; note difference in boolean args -(provide wrap-adaptive) -(define wrap-adaptive (make-wrap-proc +(define+provide wrap-adaptive (make-wrap-proc make-pieces quad-width pieces->line @@ -554,8 +557,8 @@ ;; build quad out to a given width by distributing excess into spacers ;; todo: adjust this to work recursively, so that fill operation cascades down -(define/typed (fill starting-quad [target-width? #f]) - ((Quad) ((U False Flonum)) . ->* . Quad) +(define/typed+provide (fill starting-quad [target-width? #f]) + ((Quad) ((Option Flonum)) . ->* . Quad) (define target-width (fl (or target-width? (cast (quad-attr-ref starting-quad world:measure-key) Flonum)))) (define subquads (cast (quad-list starting-quad) (Listof Quad))) (define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers. @@ -577,7 +580,7 @@ ;; add x positions to a list of fixed-width quads ;; todo: adjust this to work recursively, so that positioning operation cascades down -(define/typed (add-horiz-positions starting-quad) +(define/typed+provide (add-horiz-positions starting-quad) (Quad . -> . Quad) (define-values (new-quads final-width) (for/fold ([new-quads : (Listof Quad) empty][width-so-far : Flonum 0.0])([qi (in-list (quad-list starting-quad))])