mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

next: import all of csp interface

Browse Source
main
Matthew Butterick 10 years ago
parent b29473fcd7
commit 89c265957a
2 changed files with 24 additions and 25 deletions
Show Stats Download Patch File Download Diff File

45
quad/main-typed.rkt
Unescape Escape View File

@ -56,7 +56,7 @@
(define/typed+provide (block->lines b)
(BlockQuad . -> . (Listof LineQuad)) ;; 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 quality (assert (quad-attr-ref/parameter b world:quality-key) Index?))
(define/typed (wrap-quads qs)
((Listof Quad) . -> . (Listof LineQuad))
(define wrap-proc (cond
@ -101,9 +101,9 @@
(define/typed (columns-mapper page-in)
(PageQuad . -> . PageQuad)
(apply page (quad-attrs page-in)
(for/list : (Listof Quad) ([pq (in-list (quad-list page-in))])
(add-vert-positions (for/list : (Listof Quad) ([x (in-list (quad-list pq))])
(compute-line-height (add-horiz-positions (fill (cast x Quad)))))))))
(for/list : (Listof Quad) ([col (in-list (quad-list page-in))])
(assert col ColumnQuad?)
(apply column (quad-attrs col) (map (λ([ln : Quad]) (assert ln LineQuad?) (compute-line-height (add-horiz-positions (fill ln)))) (quad-list col))))))
(define mapped-pages (map columns-mapper (number-pages ps)))
(define doc (quads->doc mapped-pages))
doc)
@ -121,7 +121,7 @@
(define prob (new problem%))
(define max-column-lines world:default-lines-per-column)
(define-values (columns ignored-return-value)
(for/fold ([columns : (Listof ColumnQuad) empty][lines-remaining : (Listof Quad) lines])
(for/fold ([columns : (Listof ColumnQuad) empty][lines-remaining : (Listof LineQuad) 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.
@ -153,8 +153,8 @@
(define/typed (last-lines-constraint pl)
(Index . -> . Boolean)
(define last-line-of-page ((inst list-ref Quad) lines-remaining (sub1 pl)))
(define lines-in-this-paragraph (cast (quad-attr-ref last-line-of-page world:total-lines-key) Index))
(define line-index-of-last-line (cast (quad-attr-ref last-line-of-page world:line-index-key) Index))
(define lines-in-this-paragraph (assert (quad-attr-ref last-line-of-page world:total-lines-key) Index?))
(define line-index-of-last-line (assert (quad-attr-ref last-line-of-page world:line-index-key) Index?))
(define (paragraph-too-short-to-meet-constraint?)
(< lines-in-this-paragraph world:min-last-lines))
(or (paragraph-too-short-to-meet-constraint?)
@ -167,47 +167,48 @@
(define/typed (first-lines-constraint pl lines-remaining)
(Index (Listof Quad) . -> . Boolean)
(define last-line-of-page (list-ref lines-remaining (sub1 pl)))
(define lines-in-this-paragraph (cast (quad-attr-ref last-line-of-page world:total-lines-key) Integer))
(define line-index-of-last-line (cast (quad-attr-ref last-line-of-page world:line-index-key) Integer))
(define lines-in-this-paragraph (assert (quad-attr-ref last-line-of-page world:total-lines-key) integer?))
(define line-index-of-last-line (assert (quad-attr-ref last-line-of-page world:line-index-key) integer?))
(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 (cast x Index) lines-remaining)) '("column-lines"))
(send prob add-constraint (λ(x) (first-lines-constraint (assert x Index?) lines-remaining)) '("column-lines"))
(log-quad-debug "viable number of lines after first-lines constraint =\n~a" ((inst map Integer (HashTable String Integer)) (λ(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 how-many-lines-to-take (assert (hash-ref s "column-lines") 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 : Index] [line : LineQuad]) (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)))
(define new-column (quads->column lines-to-take))
(values (cons (apply column (attr-change (quad-attrs new-column) (list world:column-index-key col-idx)) (quad-list new-column)) columns) lines-to-leave)))
(reverse columns))
(define/typed+provide (columns->pages cols)
((Listof ColumnQuad) . -> . (Listof PageQuad))
(define columns-per-page (cast (quad-attr-ref/parameter (car cols) world:column-count-key) Positive-Integer))
(define column-gutter (cast (quad-attr-ref/parameter (car cols) world:column-gutter-key) Float))
(define column-gutter (assert (quad-attr-ref/parameter (car cols) world:column-gutter-key) flonum?))
;; don't use default value here. If the col doesn't have a measure key,
;; it deserves to be an error, because that means the line was composed incorrectly.
(when (not (quad-has-attr? (car cols) world:measure-key))
(error 'columns->pages "column attrs contain no measure key: ~a ~a" (quad-attrs (car cols)) (quad-car (car cols))))
(define column-width (cast (quad-attr-ref (car cols) world:measure-key) Float))
(define column-width (assert (quad-attr-ref (car cols) world:measure-key) flonum?))
(define width-of-printed-area (+ (* columns-per-page column-width) (* (sub1 columns-per-page) column-gutter)))
(define result-pages
((inst map Quad (Listof Quad)) (λ(cols) (quads->page cols))
(for/list : (Listof (Listof Quad)) ([page-cols (in-list (slice-at cols columns-per-page))])
(define-values (last-x cols)
(for/fold ([current-x : Float (/ (- (world:paper-width-default) width-of-printed-area) 2.0)]
[cols : (Listof Quad) empty])
([col (in-list page-cols)][idx (in-naturals)])
(values (+ current-x column-width column-gutter) (cons (cast (quad-attr-set* col 'x current-x 'y 40.0 world:column-index-key idx) Quad) cols))))
(reverse cols))))
((inst map PageQuad (Listof Quad)) (λ(cols) (quads->page cols))
(for/list : (Listof (Listof Quad)) ([page-cols (in-list (slice-at cols columns-per-page))])
(define-values (last-x cols)
(for/fold ([current-x : Float (/ (- (world:paper-width-default) width-of-printed-area) 2.0)]
[cols : (Listof Quad) empty])
([col (in-list page-cols)][idx (in-naturals)])
(values (foldl fl+ 0.0 (list current-x column-width column-gutter)) (cons (quad-attr-set* col (list 'x current-x 'y 40.0 world:column-index-key idx)) cols))))
(reverse cols))))
result-pages)
(define current-eof (make-parameter (gensym)))

4
quad/utils-typed.rkt
Unescape Escape View File

@ -255,12 +255,10 @@
;; use heights to compute vertical positions
(define/typed+provide (add-vert-positions starting-quad)
(Quad . -> . Quad)
(GroupQuad . -> . GroupQuad)
(define-values (new-quads final-height)
(for/fold ([new-quads : (Listof Quad) empty][height-so-far : Float 0.0])
([q (in-list (quad-list starting-quad))])
(display 'foom2)
(assert q 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)))

Write Preview
Loading…
Cancel
Save