farewell, typed quad
parent
4b7dcc2754
commit
a0335375d3
@ -1,18 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Typed versions of common library functions, to avoid require/typed
|
||||
|
||||
(: empty? (Any . -> . Boolean : Null))
|
||||
(define (empty? l)
|
||||
(null? l))
|
||||
|
||||
(: empty Null)
|
||||
(define empty '())
|
||||
|
||||
#;(: flatten (Any . -> . (Listof Any)))
|
||||
#;(define (flatten orig-sexp)
|
||||
(let loop ([sexp orig-sexp] [acc null])
|
||||
(cond [(null? sexp) acc]
|
||||
[(pair? sexp) (loop (car sexp) (loop (cdr sexp) acc))]
|
||||
[else (cons sexp acc)])))
|
||||
@ -1,44 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require (for-syntax typed/racket/base))
|
||||
(require typed/racket/date racket/match "world-typed.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-syntax-rule (define-orphan-logger name)
|
||||
(begin
|
||||
(define remember-cl (current-logger))
|
||||
(define dummy-cl (make-logger))
|
||||
(current-logger dummy-cl)
|
||||
(define-logger name)
|
||||
(current-logger remember-cl)))
|
||||
|
||||
(define levels '(none fatal error warning info debug))
|
||||
|
||||
(define-logger quad)
|
||||
|
||||
(define-syntax-rule (activate-logger logger)
|
||||
(begin
|
||||
(define logger-receiver (make-log-receiver logger (world:logging-level)))
|
||||
(define log-file (build-path (current-directory) (format "~a.txt" 'logger)))
|
||||
(with-output-to-file log-file #:exists 'truncate void)
|
||||
(void (thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(match (sync logger-receiver)
|
||||
[(vector event-level event-message event-value name)
|
||||
(define msg (format "[~a] ~a\n" event-level event-message))
|
||||
; (eprintf msg)
|
||||
(flush-output)
|
||||
(with-output-to-file log-file #:exists 'append (λ () (display msg)))])
|
||||
(loop))))
|
||||
(log-quad-info "started at ~a" (date->string (current-date) #t)))))
|
||||
|
||||
(define-syntax-rule (log-quad-debug-report x)
|
||||
(begin
|
||||
(log-quad-debug "~a = ~a" 'x x)
|
||||
x))
|
||||
|
||||
(: log-quad-debug* ((Listof String) . -> . Void))
|
||||
(define (log-quad-debug* xs)
|
||||
(when (equal? (world:logging-level) 'debug)
|
||||
((inst for-each String) (λ(x) (log-quad-debug x)) xs)))
|
||||
|
||||
@ -1,17 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require typed/sugar/debug)
|
||||
(require "main-typed.rkt" "logger-typed.rkt" "world-typed.rkt" "samples-typed.rkt" "quads-typed.rkt")
|
||||
|
||||
(require/typed profile
|
||||
[profile-thunk (All (A) ((-> A) [#:delay Float] -> A))])
|
||||
|
||||
(require "render-typed.rkt" typed/racket/class)
|
||||
(activate-logger quad-logger)
|
||||
|
||||
(parameterize ([world:quality-default world:draft-quality]
|
||||
[world:paper-width-default 600.0]
|
||||
[world:paper-height-default 700.0])
|
||||
(define sample (ti5))
|
||||
; (define to (time (profile-thunk #:delay 0.001 (λ () (typeset sample)))))
|
||||
(define to (time (typeset sample)))
|
||||
(time (send (new pdf-renderer%) render-to-file to "foo-typed.pdf")))
|
||||
@ -1,27 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require typed/rackunit)
|
||||
(require "main-typed.rkt" "quads-typed.rkt" "world-typed.rkt")
|
||||
|
||||
|
||||
(check-equal? (input->nested-blocks (input '() (block '() "1" (block-break) "2")))
|
||||
(list (list (list (list (word '() "1")) (list (word '() "2"))))))
|
||||
|
||||
(check-equal? (input->nested-blocks (input '() (block '() "1" (column-break) "2")))
|
||||
(list (list (list (list (word '() "1"))) (list (list (word '() "2"))))))
|
||||
|
||||
|
||||
(check-equal? (list (list (list (list (word '() "1")))) (list (list (list (word '() "2")))))
|
||||
(input->nested-blocks (input '() (block '() "1" (page-break) "2"))))
|
||||
|
||||
(check-equal? (merge-adjacent-within (line '() (word '() "b") (word '() "a") (word '() "r"))) (line '() (word '() "bar")))
|
||||
|
||||
(check-equal? (hyphenate-quad-except-last-word (box '() "snowman" "snowman")) (box '() "snow\u00ADman" "snowman"))
|
||||
|
||||
(define al-test-line (line (list world:line-looseness-key 42.0) (word '() "bar")))
|
||||
(define al-test-line2 (line (list world:line-looseness-key 30.0) (word '() "bar")))
|
||||
(check-equal? (average-looseness (list)) 0.0) ; default value for no lines
|
||||
(check-equal? (average-looseness (list al-test-line)) 0.0) ; default value for one line
|
||||
(check-equal? (average-looseness (list al-test-line al-test-line2)) 42.0) ; last line excluded by default
|
||||
(check-equal? (average-looseness (list al-test-line al-test-line2 al-test-line)) 36.0) ; last line excluded by default
|
||||
|
||||
(check-equal? (log-debug-lines (list (line (list world:line-looseness-key 42.0) (word '() "bar")))) '("0/1: \"bar\" 42.0"))
|
||||
@ -1,251 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require racket/list math/flonum typed/racket/class)
|
||||
(require typed/sugar/define typed/sugar/list)
|
||||
(require/typed csp
|
||||
[problem% (Class (init-field [solver Any])
|
||||
(field [_solver Any])
|
||||
(field [_variable-domains Any])
|
||||
(field [_constraints Any])
|
||||
[reset (-> Void)]
|
||||
[custom-print (Output-Port Integer -> Void)]
|
||||
[custom-display (Output-Port -> Void)]
|
||||
[custom-write (Output-Port -> Void)]
|
||||
[add-variable (Any (Listof Any) . -> . Void)]
|
||||
[add-variables ((Listof Any) Any . -> . Void)]
|
||||
[add-constraint ((Index . -> . Boolean) (Listof Any) . -> . Void)][get-solution (-> HashTableTop)]
|
||||
[get-solutions (-> (Listof (HashTable String Integer)))]
|
||||
[get-solution-iter (-> HashTableTop)]
|
||||
[set-solver (Any . -> . Void)]
|
||||
[get-solver (-> Any)])])
|
||||
(require "quads-typed.rkt" "utils-typed.rkt" "wrap-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt")
|
||||
|
||||
(define-type Block-Type (Listof Quad))
|
||||
(define-type Multicolumn-Type (Listof Block-Type))
|
||||
(define-type Multipage-Type (Listof Multicolumn-Type))
|
||||
|
||||
(define/typed (cons-reverse xs ys)
|
||||
(All (A B) ((Listof A) (Listof B) -> (Pairof (Listof A) (Listof B))))
|
||||
((inst cons (Listof A) (Listof B)) ((inst reverse A) xs) ys))
|
||||
|
||||
(define/typed+provide (input->nested-blocks i)
|
||||
(Quad . -> . (Listof Multipage-Type))
|
||||
(define-values (mps mcs bs b)
|
||||
(for/fold ([multipages : (Listof Multipage-Type) empty]
|
||||
[multicolumns : (Listof Multicolumn-Type) empty]
|
||||
[blocks : (Listof Block-Type) empty]
|
||||
[block-acc : Block-Type empty])
|
||||
([q (in-list (split-quad i))])
|
||||
(cond
|
||||
[(page-break? q) (values (cons-reverse (cons-reverse (cons-reverse block-acc blocks) multicolumns) multipages) empty empty empty)]
|
||||
[(column-break? q) (values multipages (cons-reverse (cons-reverse block-acc blocks) multicolumns) empty empty)]
|
||||
[(block-break? q) (values multipages multicolumns (cons-reverse block-acc blocks) empty)]
|
||||
[else (values multipages multicolumns blocks (cons q block-acc))])))
|
||||
(reverse (cons-reverse (cons-reverse ((inst cons-reverse Quad Block-Type) b bs) mcs) mps)))
|
||||
|
||||
(define/typed+provide (merge-adjacent-within q)
|
||||
(Quad . -> . Quad)
|
||||
(quad (quad-name q) (quad-attrs q) (join-quads (cast (quad-list q) (Listof Quad)))))
|
||||
|
||||
(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)))
|
||||
|
||||
(define/typed+provide (average-looseness lines)
|
||||
((Listof Quad) . -> . Float)
|
||||
(if (<= (length lines) 1)
|
||||
0.0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(round-float (/ (foldl fl+ 0.0 ((inst map Float Quad) (λ(line) (cast (quad-attr-ref line world:line-looseness-key 0.0) Float)) lines-to-measure)) (- (fl (length lines)) 1.0))))))
|
||||
|
||||
|
||||
(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)])
|
||||
(format "~a/~a: ~v ~a" idx
|
||||
(length lines)
|
||||
(quad->string line)
|
||||
(quad-attr-ref line world:line-looseness-key))))
|
||||
|
||||
|
||||
(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 (assert (quad-attr-ref/parameter b world:quality-key) Index?))
|
||||
(define/typed (wrap-quads qs)
|
||||
((Listof Quad) . -> . (Listof LineQuad))
|
||||
(define wrap-proc (cond
|
||||
[(>= quality world:max-quality) wrap-best]
|
||||
[(<= quality world:draft-quality) wrap-first]
|
||||
[else wrap-adaptive]))
|
||||
(wrap-proc qs))
|
||||
(log-quad-debug "wrapping lines")
|
||||
(log-quad-debug "quality = ~a" quality)
|
||||
(log-quad-debug "looseness tolerance = ~a" world:line-looseness-tolerance)
|
||||
(define wrapped-lines-without-hyphens (wrap-quads (cast (quad-list b) (Listof Quad)))) ; 100/150
|
||||
(log-quad-debug* (log-debug-lines wrapped-lines-without-hyphens))
|
||||
(define avg-looseness (average-looseness wrapped-lines-without-hyphens))
|
||||
(define gets-hyphenation? (and world:use-hyphenation?
|
||||
(fl> avg-looseness world:line-looseness-tolerance)))
|
||||
(log-quad-debug "average looseness = ~a" avg-looseness)
|
||||
(log-quad-debug (if gets-hyphenation? "hyphenating" "no hyphenation needed"))
|
||||
|
||||
(define wrapped-lines (if gets-hyphenation?
|
||||
(wrap-quads (split-quad (cast ((if world:allow-hyphenated-last-word-in-paragraph
|
||||
hyphenate-quad
|
||||
hyphenate-quad-except-last-word) (merge-adjacent-within b)) Quad)))
|
||||
wrapped-lines-without-hyphens))
|
||||
(when gets-hyphenation? (log-quad-debug* (log-debug-lines wrapped-lines)))
|
||||
|
||||
|
||||
(log-quad-debug "final looseness = ~a" (average-looseness wrapped-lines))
|
||||
(map insert-spacers-in-line
|
||||
(for/list : (Listof LineQuad) ([line-idx (in-naturals)][the-line (in-list wrapped-lines)])
|
||||
(apply line (attr-change (quad-attrs the-line) (list 'line-idx line-idx 'lines (length wrapped-lines))) (quad-list the-line)))))
|
||||
|
||||
|
||||
(define/typed+provide (number-pages ps)
|
||||
((Listof PageQuad) . -> . (Listof PageQuad))
|
||||
(for/list ([i (in-naturals)][p (in-list ps)])
|
||||
(apply page (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p))))
|
||||
|
||||
(define/typed+provide (pages->doc ps)
|
||||
((Listof PageQuad) . -> . DocQuad)
|
||||
;; todo: resolve xrefs and other last-minute tasks
|
||||
;; todo: generalize computation of widths and heights, recursively
|
||||
(define/typed (columns-mapper page-in)
|
||||
(PageQuad . -> . PageQuad)
|
||||
(apply page (quad-attrs page-in)
|
||||
(map add-vert-positions (for/list : (Listof ColumnQuad) ([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)
|
||||
|
||||
|
||||
(define/typed+provide (lines->columns lines)
|
||||
((Listof LineQuad) . -> . (Listof ColumnQuad))
|
||||
(define prob (new problem% [solver #f]))
|
||||
(define max-column-lines world:default-lines-per-column)
|
||||
(define-values (columns ignored-return-value)
|
||||
(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.
|
||||
;; 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/typed (greediness-constraint pl)
|
||||
(Index . -> . Boolean)
|
||||
(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" ((inst map Integer (HashTable String Integer)) (λ(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/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 (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?)
|
||||
(>= (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" ((inst map Integer (HashTable String Integer)) (λ(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/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 (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 (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 (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)
|
||||
(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 (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 (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 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)))
|
||||
(define (eof? x) (equal? x (current-eof)))
|
||||
|
||||
(define/typed (block-quads->lines qs)
|
||||
((Listof Quad) . -> . (Listof LineQuad))
|
||||
(block->lines (quads->block qs)))
|
||||
|
||||
(require typed/sugar/debug)
|
||||
(define/typed+provide (typeset x)
|
||||
(Quad . -> . DocQuad)
|
||||
(load-text-cache-file)
|
||||
|
||||
(define pages (append*
|
||||
(for/list : (Listof (Listof PageQuad))
|
||||
([multipage (in-list (input->nested-blocks x))])
|
||||
(columns->pages (append*
|
||||
(for/list : (Listof (Listof ColumnQuad))
|
||||
([multicolumn (in-list multipage)])
|
||||
(lines->columns (append*
|
||||
(for/list : (Listof (Listof LineQuad))
|
||||
([block-quads (in-list multicolumn)])
|
||||
(block-quads->lines block-quads))))))))))
|
||||
(define doc (pages->doc pages))
|
||||
(update-text-cache-file)
|
||||
doc)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,77 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require (for-syntax typed/racket/base))
|
||||
(require typed/racket/class math/flonum racket/list racket/file typed/racket/draw "core-types.rkt" typed/sugar/define)
|
||||
(require/typed racket/serialize [serialize (Any -> Any)]
|
||||
[deserialize (Any -> (HashTable (List String String Symbol Symbol) Measurement-Result-Type))])
|
||||
(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file)
|
||||
|
||||
|
||||
(define precision 4.0)
|
||||
(define base (expt 10.0 precision))
|
||||
(define max-size 1024.0)
|
||||
(define dc (new record-dc%))
|
||||
(define-type Measurement-Result-Type (List Float Float Float Float))
|
||||
(define mrt? (make-predicate Measurement-Result-Type))
|
||||
(define current-text-cache (make-parameter ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '())))
|
||||
(define current-font-cache (make-parameter ((inst make-hash (List Font-Name Font-Weight Font-Style) (Instance Font%)) '())))
|
||||
|
||||
(define/typed (round-float x)
|
||||
(Float -> Float)
|
||||
(/ (round (* base x)) base))
|
||||
|
||||
|
||||
(define/typed (get-cache-file-path)
|
||||
(-> Path)
|
||||
(build-path "font.cache"))
|
||||
|
||||
|
||||
(define/typed (update-text-cache-file)
|
||||
(-> Void)
|
||||
(write-to-file (serialize (current-text-cache)) (get-cache-file-path) #:exists 'replace))
|
||||
|
||||
|
||||
(define/typed (load-text-cache-file)
|
||||
(-> Void)
|
||||
(define cache-file-path (get-cache-file-path))
|
||||
(current-text-cache (if (file-exists? cache-file-path)
|
||||
(deserialize (file->value cache-file-path))
|
||||
((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '()))))
|
||||
|
||||
|
||||
(define/typed (get-cached-font font weight style)
|
||||
(Font-Name Font-Weight Font-Style -> (Instance Font%))
|
||||
(hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))))
|
||||
|
||||
|
||||
(define/typed (measure-max-size text font [weight 'normal] [style 'normal])
|
||||
((String Font-Name) (Font-Weight Font-Style) . ->* . Measurement-Result-Type)
|
||||
(: hash-updater (-> Measurement-Result-Type))
|
||||
(define (hash-updater)
|
||||
#;(current-text-cache-changed? #t)
|
||||
(define font-instance (get-cached-font font weight style))
|
||||
;; 'combine' boolean only makes a difference for two or more chars, so use (>= (string-length text) 1) for speed
|
||||
(define-values (width height descent extra) (send dc get-text-extent text font-instance (>= (string-length text) 1)))
|
||||
;; avoid `map` here because it requires a cast to ensure the type
|
||||
;; this seems like a bug in TR: doesn't recognize (List Float Float Float Float) as subtype of (Listof Float)?
|
||||
(list (fl width) (fl height) (fl descent) (fl extra)))
|
||||
((inst hash-ref! (List String String Symbol Symbol) Measurement-Result-Type) (current-text-cache) (list text font weight style) hash-updater))
|
||||
|
||||
(define-syntax-rule (width x) (first x))
|
||||
(define-syntax-rule (height x) (second x))
|
||||
(define-syntax-rule (descent x) (third x))
|
||||
#;(define-syntax-rule (extra x) (fourth x))
|
||||
|
||||
|
||||
;; works by taking max size and scaling it down. Allows caching of results.
|
||||
(define/typed (measure-text text size font weight style)
|
||||
(String Font-Size Font-Name Font-Weight Font-Style -> Float)
|
||||
(define raw-width (width (measure-max-size text font weight style)))
|
||||
(round-float (/ (* raw-width size) max-size)))
|
||||
|
||||
|
||||
;; works by taking max size and scaling it down. Allows caching of results.
|
||||
(define/typed (measure-ascent text size font [weight 'normal] [style 'normal])
|
||||
((String Font-Size Font-Name) (Font-Weight Font-Style) . ->* . Float)
|
||||
(define result-list : Measurement-Result-Type (measure-max-size text font weight style))
|
||||
(define raw-baseline-distance (- (height result-list) (descent result-list)))
|
||||
(round-float (/ (* raw-baseline-distance size) max-size)))
|
||||
@ -1,85 +0,0 @@
|
||||
#lang typed/racket
|
||||
(require "ocm-typed.rkt")
|
||||
(require typed/rackunit)
|
||||
(require math)
|
||||
|
||||
(define m0 (matrix ((25.0 42.0 57.0 78.0 90.0 103.0 123.0 142.0 151.0)
|
||||
(21.0 35.0 48.0 65.0 76.0 85.0 105.0 123.0 130.0)
|
||||
(13.0 26.0 35.0 51.0 58.0 67.0 86.0 100.0 104.0)
|
||||
(10.0 20.0 28.0 42.0 48.0 56.0 75.0 86.0 88.0)
|
||||
(20.0 29.0 33.0 44.0 49.0 55.0 73.0 82.0 80.0)
|
||||
(13.0 21.0 24.0 35.0 39.0 44.0 59.0 65.0 59.0)
|
||||
(19.0 25.0 28.0 38.0 42.0 44.0 57.0 61.0 52.0)
|
||||
(35.0 37.0 40.0 48.0 48.0 49.0 62.0 62.0 49.0)
|
||||
(37.0 36.0 37.0 42.0 39.0 39.0 51.0 50.0 37.0)
|
||||
(41.0 39.0 37.0 42.0 35.0 33.0 44.0 43.0 29.0)
|
||||
(58.0 56.0 54.0 55.0 47.0 41.0 50.0 47.0 29.0)
|
||||
(66.0 64.0 61.0 61.0 51.0 44.0 52.0 45.0 24.0)
|
||||
(82.0 76.0 72.0 70.0 56.0 49.0 55.0 46.0 23.0)
|
||||
(99.0 91.0 83.0 80.0 63.0 56.0 59.0 46.0 20.0)
|
||||
(124.0 116.0 107.0 100.0 80.0 71.0 72.0 58.0 28.0)
|
||||
(133.0 125.0 113.0 106.0 86.0 75.0 74.0 59.0 25.0)
|
||||
(156.0 146.0 131.0 120.0 97.0 84.0 80.0 65.0 31.0)
|
||||
(178.0 164.0 146.0 135.0 110.0 96.0 92.0 73.0 39.0))))
|
||||
(define m (matrix->list* m0))
|
||||
(define m2 (matrix->list* (matrix-transpose m0)))
|
||||
|
||||
|
||||
(check-true (smawky? m))
|
||||
(check-true (smawky? m2))
|
||||
|
||||
(: simple-entry->value Entry->Value-Type)
|
||||
(define (simple-entry->value e)
|
||||
(fl (cast e Real)))
|
||||
|
||||
;; proc must return a value even for out-of-bounds i and j
|
||||
(: simple-proc Matrix-Proc-Type)
|
||||
(define (simple-proc i j) (cast (fl (with-handlers [(exn:fail? (λ(exn) (* -1 i)))]
|
||||
((inst list-ref Value-Type) ((inst list-ref (Listof Value-Type)) m i) j))) Value-Type))
|
||||
(: simple-proc2 Matrix-Proc-Type)
|
||||
(define (simple-proc2 i j) (cast (fl (with-handlers [(exn:fail? (λ(exn) (* -1 i)))]
|
||||
((inst list-ref Value-Type) ((inst list-ref (Listof Value-Type)) m2 i) j))) Value-Type))
|
||||
(check-equal? (simple-proc 0 2) 57.0) ; 0th row, 2nd col
|
||||
(check-equal? (simple-proc2 2 0) 57.0) ; flipped
|
||||
|
||||
(define row-indices (cast (list->vector (range (length m))) (Vectorof Index-Type)))
|
||||
(define col-indices (cast (list->vector (range (length (car m)))) (Vectorof Index-Type)))
|
||||
(define result (concave-minima row-indices col-indices simple-proc simple-entry->value))
|
||||
|
||||
|
||||
(check-equal?
|
||||
(for/list : (Listof (List (U Index-Type Entry-Type) (U Index-Type Entry-Type))) ([j (in-vector col-indices)])
|
||||
(define h (cast (hash-ref result j) (HashTable Symbol (U Index-Type Entry-Type))))
|
||||
(list (hash-ref h minima-payload-key) (hash-ref h minima-idx-key)))
|
||||
'((10.0 3) (20.0 3) (24.0 5) (35.0 5) (35.0 9) (33.0 9) (44.0 9) (43.0 9) (20.0 13))) ; checked against SMAWK.py
|
||||
|
||||
(check-equal?
|
||||
(for/list : (Listof (List Entry-Type Index-Type)) ([j (in-vector col-indices)])
|
||||
(define h (cast (hash-ref result j) (HashTable Symbol Any)))
|
||||
(list (cast (hash-ref h minima-payload-key) Entry-Type) (cast (hash-ref h minima-idx-key) Index-Type)))
|
||||
'((10.0 3) (20.0 3) (24.0 5) (35.0 5) (35.0 9) (33.0 9) (44.0 9) (43.0 9) (20.0 13))) ; checked against SMAWK.py
|
||||
|
||||
|
||||
|
||||
(define o (make-ocm simple-proc simple-entry->value))
|
||||
|
||||
(check-equal?
|
||||
(for/list : (Listof (List Entry-Type (U Index-Type No-Value-Type))) ([j (in-vector col-indices)])
|
||||
(list (cast (ocm-min-entry o j) Entry-Type) (ocm-min-index o j)))
|
||||
'((0.0 none) (42.0 0) (48.0 1) (51.0 2) (48.0 3) (55.0 4) (59.0 5) (61.0 6) (49.0 7))) ; checked against SMAWK.py
|
||||
|
||||
|
||||
(define row-indices2 (cast (list->vector (range (length m2))) (Vectorof Index-Type)))
|
||||
(define col-indices2 (cast (list->vector (range (length (car m2)))) (Vectorof Index-Type)))
|
||||
(define result2 (concave-minima row-indices2 col-indices2 simple-proc2 simple-entry->value))
|
||||
(check-equal?
|
||||
(for/list : (Listof (List Entry-Type Index-Type)) ([j (in-vector col-indices2)])
|
||||
(define h (cast (hash-ref result2 j) (HashTable Symbol (U Index-Type Entry-Type))))
|
||||
(list (cast (hash-ref h minima-payload-key) Entry-Type) (cast (hash-ref h minima-idx-key) Index-Type)))
|
||||
'((25.0 0) (21.0 0) (13.0 0) (10.0 0) (20.0 0) (13.0 0) (19.0 0) (35.0 0) (36.0 1) (29.0 8) (29.0 8) (24.0 8) (23.0 8) (20.0 8) (28.0 8) (25.0 8) (31.0 8) (39.0 8))) ; checked against SMAWK.py
|
||||
|
||||
(define o2 (make-ocm simple-proc2 simple-entry->value))
|
||||
(check-equal?
|
||||
(for/list : (Listof (List Entry-Type (U Index-Type No-Value-Type))) ([j (in-vector col-indices2)])
|
||||
(list (cast (ocm-min-entry o2 j) Entry-Type) (ocm-min-index o2 j)))
|
||||
'((0.0 none) (21.0 0) (13.0 0) (10.0 0) (20.0 0) (13.0 0) (19.0 0) (35.0 0) (36.0 1) (29.0 8) (-9.0 9) (-10.0 10) (-11.0 11) (-12.0 12) (-13.0 13) (-14.0 14) (-15.0 15) (-16.0 16))) ; checked against SMAWK.py
|
||||
@ -1,240 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require (for-syntax typed/racket/base racket/syntax racket/string))
|
||||
(require "lib-typed.rkt" "core-types.rkt")
|
||||
;; note to self: a require/typed function with proper typing
|
||||
;; is faster than a generic function + type assertion at location of call
|
||||
(require/typed racket/list
|
||||
[flatten ((Listof QuadAttr) -> QuadAttrs)])
|
||||
(require/typed racket/string [string-append* ((Listof String) -> String)])
|
||||
(require typed/sugar/debug typed/sugar/string typed/sugar/list typed/sugar/define)
|
||||
(provide (all-defined-out) (all-from-out "core-types.rkt"))
|
||||
|
||||
(define-syntax-rule (even-members xs)
|
||||
(for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i))
|
||||
x))
|
||||
|
||||
(define/typed (quad-name q)
|
||||
(Quad -> QuadName)
|
||||
(car q))
|
||||
|
||||
(define/typed (quad-attrs q)
|
||||
(Quad -> QuadAttrs)
|
||||
(car (cdr q)))
|
||||
|
||||
(define/typed (make-quadattr k v)
|
||||
(QuadAttrKey QuadAttrValue -> QuadAttr)
|
||||
(cons k v))
|
||||
|
||||
(define/typed (quadattr-key qa)
|
||||
(QuadAttr -> QuadAttrKey)
|
||||
(car qa))
|
||||
|
||||
(define/typed (quadattr-value qa)
|
||||
(QuadAttr -> QuadAttrValue)
|
||||
(cdr qa))
|
||||
|
||||
(define/typed (quad-attr-keys qas)
|
||||
(QuadAttrs -> (Listof QuadAttrKey))
|
||||
(if (empty? qas)
|
||||
qas
|
||||
((inst map QuadAttrKey QuadAttr) car qas)))
|
||||
|
||||
(define/typed (quad-list q)
|
||||
(case->
|
||||
(GroupQuad -> GroupQuadList)
|
||||
(Quad -> QuadList))
|
||||
(cdr (cdr q)))
|
||||
|
||||
|
||||
(define/typed (quad-attr-ref q-or-qas key [default attr-missing])
|
||||
(((U Quad QuadAttrs) QuadAttrKey) (QuadAttrValue) . ->* . QuadAttrValue)
|
||||
(define qas (if (quad? q-or-qas) (quad-attrs q-or-qas) q-or-qas))
|
||||
(define qa-result (memf (λ([qap : QuadAttr]) (equal? key (car qap))) qas))
|
||||
(if qa-result
|
||||
;; car beacause result of memf is a list tail; cadr because second element in pair
|
||||
(quadattr-value (car qa-result))
|
||||
(if (not (equal? default attr-missing)) default (error 'quad-attr-ref (format "Key ~v not found in quad attributes ~v" key qas)))))
|
||||
|
||||
|
||||
(define-syntax (quad-attr-ref/parameter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ q key)
|
||||
(with-syntax ([world:key-default (format-id stx "~a-default" (string-trim (symbol->string (syntax->datum #'key)) "-key"))])
|
||||
#'(quad-attr-ref q key (world:key-default)))]))
|
||||
|
||||
|
||||
(define cannot-be-common-attrs '(width x y page))
|
||||
(define attr-missing (gensym))
|
||||
|
||||
(: quad-ends-with? (Quad String -> Boolean))
|
||||
(define (quad-ends-with? q str)
|
||||
(cond
|
||||
[(not (empty? (quad-list q)))
|
||||
(define last-item (list-ref (quad-list q) (sub1 (length (quad-list q)))))
|
||||
(cond
|
||||
[(string? last-item) (ends-with? last-item str)]
|
||||
[(quad? last-item) (quad-ends-with? last-item str)]
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
|
||||
(: quad-append (Quad QuadListItem -> Quad))
|
||||
(define (quad-append q new-item)
|
||||
(quad (quad-name q) (quad-attrs q) (append (quad-list q) (list new-item))))
|
||||
|
||||
|
||||
(: quad->string (Quad -> String))
|
||||
(define (quad->string x)
|
||||
(let loop : String ([x : (U Quad String) x])
|
||||
(cond
|
||||
[(string? x) x]
|
||||
;; else branch relies on fact that x is either Quad or String
|
||||
[else (string-append* ((inst map String QuadListItem) loop (quad-list x)))])))
|
||||
|
||||
(define/typed+provide (gather-common-attrs qs)
|
||||
((Listof Quad) -> QuadAttrs)
|
||||
(if (null? qs)
|
||||
qs
|
||||
(let loop
|
||||
([qs qs]
|
||||
;; start with the set of pairs in the first quad, then filter it down
|
||||
[candidate-attr-pairs : (Listof QuadAttr) (let ([first-attrs (quad-attrs (car qs))])
|
||||
(if first-attrs
|
||||
(for/fold ([caps : QuadAttrs null]) ([cap (in-list first-attrs)])
|
||||
(if (member (car cap) cannot-be-common-attrs)
|
||||
caps
|
||||
(cons cap caps)))
|
||||
null))])
|
||||
(cond
|
||||
[(null? candidate-attr-pairs) null] ; ran out of possible pairs, so return #f
|
||||
[(null? qs) candidate-attr-pairs] ; ran out of quads, so return common-attr-pairs
|
||||
;; todo: reconsider type interface between output of this function and input to quadattrs
|
||||
[else (loop (cdr qs) (filter (λ([cap : QuadAttr]) (member cap (quad-attrs (car qs)))) candidate-attr-pairs))]))))
|
||||
|
||||
(define/typed (make-quadattrs xs)
|
||||
;; no point typing the input as (U QuadAttrKey QuadAttrValue)
|
||||
;; because QuadAttrValue is Any, so that's the same as plain Any
|
||||
((Listof Any) -> QuadAttrs)
|
||||
(let-values ([(ks vs even?) (for/fold
|
||||
([ks : (Listof QuadAttrKey) null][vs : (Listof QuadAttrValue) null][even? : Boolean #t])
|
||||
([x (in-list xs)])
|
||||
(if (and even? (QuadAttrKey? x))
|
||||
(values (cons x ks) vs #f)
|
||||
(values ks (cons (assert x QuadAttrValue?) vs) #t)))])
|
||||
(when (not even?) (error 'quadattrs "odd number of elements in ~a" xs))
|
||||
;; use for/fold rather than for/list to impliedly reverse the list
|
||||
;; (having been reversed once above, this puts it back in order)
|
||||
(for/fold ([qas : QuadAttrs null])([k (in-list ks)][v (in-list vs)])
|
||||
(cons (make-quadattr k v) qas))))
|
||||
|
||||
|
||||
|
||||
(define-syntax (define-quad-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#'(define-quad-type id #f)]
|
||||
[(_ id wants-group?)
|
||||
(with-syntax ([id? (format-id #'id "~a?" #'id)]
|
||||
[IdQuad (format-id #'id "~aQuad" (string-titlecase (symbol->string (syntax->datum #'id))))]
|
||||
[IdQuad? (format-id #'id "~aQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))]
|
||||
[quads->id (format-id #'id "quads->~a" #'id)])
|
||||
#`(begin
|
||||
;; quad converter
|
||||
(define/typed (quads->id qs)
|
||||
((Listof Quad) -> IdQuad)
|
||||
(apply id (gather-common-attrs qs) qs))
|
||||
|
||||
(define-type IdQuad (List* 'id QuadAttrs #,(if (syntax->datum #'wants-group?)
|
||||
#'GroupQuadList
|
||||
#'QuadList)))
|
||||
(define-predicate IdQuad? IdQuad)
|
||||
(define id? IdQuad?)
|
||||
|
||||
(define/typed (id [attrs '()] #:zzz [zzz 0] . xs)
|
||||
(() ((U QuadAttrs HashableList) #:zzz Zero) #:rest #,(if (syntax->datum #'wants-group?)
|
||||
#'GroupQuadListItem
|
||||
#'QuadListItem) . ->* . IdQuad)
|
||||
(quad 'id (if (QuadAttrs? attrs)
|
||||
attrs
|
||||
(make-quadattrs attrs)) xs))))]))
|
||||
|
||||
(define/typed (whitespace? x [nbsp? #f])
|
||||
((Any) (Boolean) . ->* . Boolean)
|
||||
(cond
|
||||
[(quad? x) (whitespace? (quad-list x) nbsp?)]
|
||||
[(string? x) (or (and (regexp-match #px"\\p{Zs}" x) ; Zs = unicode whitespace category
|
||||
(or nbsp? (not (regexp-match #px"\u00a0" x)))))] ; 00a0: nbsp
|
||||
[(list? x) (and (not (empty? x)) (andmap (λ(x) (whitespace? x nbsp?)) x))] ; andmap returns #t for empty lists
|
||||
[else #f]))
|
||||
|
||||
(define (whitespace/nbsp? x)
|
||||
(whitespace? x #t))
|
||||
|
||||
(define-syntax (define-break-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#'(define-break-type id #f)]
|
||||
[(_ id wants-group?)
|
||||
(with-syntax ([split-on-id-breaks (format-id #'id "split-on-~a-breaks" #'id)]
|
||||
[id-break (format-id #'id "~a-break" #'id)]
|
||||
[id-break? (format-id #'id "~a-break?" #'id)]
|
||||
[multi-id (format-id #'id "multi~a" #'id)]
|
||||
[multi-id? (format-id #'id "multi~a?" #'id)]
|
||||
[quads->multi-id (format-id #'id "quads->multi~a" #'id)])
|
||||
#'(begin
|
||||
(define-quad-type id wants-group?)
|
||||
(define-quad-type id-break) ; break is not necessarily a group
|
||||
(define-quad-type multi-id wants-group?) ; multi-id is always a group
|
||||
;; breaker
|
||||
(: split-on-id-breaks ((Listof Quad) -> (Listof (Listof Quad))))
|
||||
(define (split-on-id-breaks xs)
|
||||
;; omit leading & trailing whitespace, because they're superfluous next to a break
|
||||
(map (λ([xs : (Listof Quad)]) (trimf xs whitespace?)) (filter-split xs id-break?)))))]))
|
||||
|
||||
(define quad= equal?)
|
||||
|
||||
|
||||
(define/typed (quad-car q)
|
||||
(Quad -> QuadListItem)
|
||||
(define ql (quad-list q))
|
||||
(if (not (empty? ql))
|
||||
((inst car QuadListItem QuadList) ql)
|
||||
(error 'quad-car "quad-list empty")))
|
||||
|
||||
(define/typed (quad-cdr q)
|
||||
(Quad -> QuadList)
|
||||
(define ql (quad-list q))
|
||||
(if (not (empty? ql))
|
||||
((inst cdr QuadListItem QuadList) ql)
|
||||
(error 'quad-car "quad-list empty")))
|
||||
|
||||
(: quad-has-attr? (Quad QuadAttrKey -> Boolean))
|
||||
(define (quad-has-attr? q key)
|
||||
(and ((inst member QuadAttrKey) key (quad-attr-keys (quad-attrs q))) #t))
|
||||
|
||||
|
||||
(define-quad-type box)
|
||||
|
||||
|
||||
(define-quad-type spacer)
|
||||
(define-quad-type kern)
|
||||
(define-quad-type optical-kern)
|
||||
(define-quad-type flag)
|
||||
(define-quad-type doc)
|
||||
(define-quad-type input)
|
||||
(define-quad-type piece #t)
|
||||
(define-quad-type run)
|
||||
|
||||
|
||||
(define-break-type word)
|
||||
(define/typed (word-string c)
|
||||
(Quad -> String)
|
||||
(define ql (quad-list c))
|
||||
(if (and (not (null? ql)) (string? (car ql)))
|
||||
(car ql)
|
||||
""))
|
||||
|
||||
|
||||
(define-break-type page #t)
|
||||
(define-break-type column #t)
|
||||
(define-break-type block)
|
||||
(define-break-type line #t)
|
||||
@ -1,4 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require "quads-typed.rkt" racket/file racket/string racket/list racket/include typed/sugar/define)
|
||||
(provide (all-defined-out))
|
||||
(include "quick-sample.rktd")
|
||||
@ -1,24 +1,10 @@
|
||||
#lang racket/base
|
||||
|
||||
(module quick-test-typed typed/racket/base
|
||||
(require "main-typed.rkt" "world-typed.rkt" "quick-sample-typed.rkt"
|
||||
"render-typed.rkt" typed/racket/class)
|
||||
(parameterize ([world:quality-default world:draft-quality])
|
||||
(displayln "Typed Quad")
|
||||
(displayln "Typesetting:")
|
||||
(define to (time (typeset (quick-sample))))
|
||||
(displayln "PDF rendering:")
|
||||
(time (send (new pdf-renderer%) render-to-file to "quick-test-typed.pdf"))))
|
||||
|
||||
(module quick-test-untyped racket/base
|
||||
(require "main.rkt" "world.rkt" "quick-sample.rkt"
|
||||
(require "main.rkt" "world.rkt" "quick-sample.rkt"
|
||||
"render.rkt" racket/class)
|
||||
(parameterize ([world:quality-default world:draft-quality])
|
||||
(displayln "Untyped Quad")
|
||||
(displayln "Typesetting:")
|
||||
(define to (time (typeset (quick-sample))))
|
||||
(displayln "PDF rendering:")
|
||||
(time (send (new pdf-renderer%) render-to-file to "quick-test-untyped.pdf"))))
|
||||
|
||||
(require 'quick-test-typed)
|
||||
(require 'quick-test-untyped)
|
||||
(time (send (new pdf-renderer%) render-to-file to "quick-test-untyped.pdf")))
|
||||
@ -1,118 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require typed/racket/class racket/file racket/list typed/racket/draw typed/sugar/cache typed/sugar/debug)
|
||||
(require "utils-typed.rkt" "quads-typed.rkt" "world-typed.rkt" "core-types.rkt")
|
||||
|
||||
(define abstract-renderer%
|
||||
|
||||
(class object%
|
||||
(super-new)
|
||||
|
||||
(define renderable-quads '(word box))
|
||||
|
||||
;; hash implementation
|
||||
(: render (Quad -> Any))
|
||||
(define/public (render doc-quad)
|
||||
(finalize
|
||||
(let ([rendering-input (flatten-quad (setup doc-quad))])
|
||||
(define page-quad-hash ((inst make-hash Nonnegative-Integer (Listof Quad))))
|
||||
(for ([q (in-list rendering-input)])
|
||||
(when (member (quad-name q) renderable-quads)
|
||||
((inst hash-update! Nonnegative-Integer (Listof Quad)) page-quad-hash (cast (quad-attr-ref q world:page-key) Nonnegative-Integer) (λ(v) ((inst cons Quad (Listof Quad)) q v)) (λ() (cast null (Listof Quad))))))
|
||||
(map (λ([k : Nonnegative-Integer]) (render-page ((inst hash-ref Nonnegative-Integer (Listof Quad) (Listof Quad)) page-quad-hash k))) (sort (hash-keys page-quad-hash) <)))))
|
||||
|
||||
(: render-element (Quad -> Any))
|
||||
(define/public (render-element q)
|
||||
(cond
|
||||
[(word? q) (render-word q)]
|
||||
[else q]))
|
||||
|
||||
(: setup (Quad -> Quad))
|
||||
(define/public (setup q) q)
|
||||
|
||||
;; use in lieu of 'abstract' definition
|
||||
(: render-page ((Listof Quad) -> Void))
|
||||
(define/public (render-page qs) (void))
|
||||
|
||||
;; use in lieu of 'abstract' definition
|
||||
(: render-word (Quad -> Any))
|
||||
(define/public (render-word x) (word))
|
||||
|
||||
(: finalize (Any -> Any))
|
||||
(define/public (finalize x) x)))
|
||||
|
||||
(define-syntax-rule (map/send method xs)
|
||||
(map (λ([x : Quad]) (method x)) xs))
|
||||
|
||||
;; this is outside class def'n because if inside,
|
||||
;; (define dc ...) can't see it and type it correctly.
|
||||
;; there may be a better way, but for now this is OK
|
||||
(: dc-output-port Output-Port)
|
||||
(define dc-output-port (open-output-bytes))
|
||||
|
||||
|
||||
(provide pdf-renderer%)
|
||||
(define pdf-renderer%
|
||||
(class abstract-renderer%
|
||||
(super-new)
|
||||
|
||||
(send* (current-ps-setup) (set-margin 0 0) (set-scaling 1.0 1.0))
|
||||
|
||||
(define dc (new pdf-dc% [interactive #f][use-paper-bbox #f][as-eps #f]
|
||||
[output dc-output-port]
|
||||
[width (world:paper-width-default)][height (world:paper-height-default)]))
|
||||
|
||||
|
||||
(define/override (setup tx)
|
||||
(send* dc
|
||||
(start-doc "boing")
|
||||
(set-pen "black" 1 'solid)
|
||||
(set-brush "black" 'transparent)) ; no fill by default
|
||||
tx)
|
||||
|
||||
(inherit render-element)
|
||||
|
||||
|
||||
(define font-cache ((inst make-hash (List String Nonnegative-Flonum Font-Style Font-Weight) (Instance Font%)) '()))
|
||||
(: get-cached-font (String Nonnegative-Flonum Font-Style Font-Weight -> (Instance Font%)))
|
||||
(define (get-cached-font font size style weight)
|
||||
(hash-ref! font-cache (list font size style weight) (λ () (make-font #:face font #:size size #:style style #:weight weight))))
|
||||
|
||||
|
||||
(define/override (render-word w)
|
||||
(define word-font (cast (quad-attr-ref/parameter w world:font-name-key) String))
|
||||
(define word-size (cast (quad-attr-ref/parameter w world:font-size-key) Nonnegative-Float))
|
||||
(define word-style (cast (quad-attr-ref/parameter w world:font-style-key) Font-Style))
|
||||
(define word-weight (cast (quad-attr-ref/parameter w world:font-weight-key) Font-Weight))
|
||||
(define word-color (cast (quad-attr-ref/parameter w world:font-color-key) String))
|
||||
(define word-background (cast (quad-attr-ref/parameter w world:font-background-key) String))
|
||||
(send dc set-font (get-cached-font word-font word-size word-style word-weight))
|
||||
(define foreground-color (send the-color-database find-color word-color))
|
||||
(when foreground-color
|
||||
(send dc set-text-foreground foreground-color))
|
||||
(define background-color (send the-color-database find-color word-background))
|
||||
(if background-color ; all invalid color-string values will return #f
|
||||
(send* dc (set-text-mode 'solid) (set-text-background background-color))
|
||||
(send dc set-text-mode 'transparent))
|
||||
|
||||
(define word-text (cast (quad-car w) String))
|
||||
(send dc draw-text word-text (cast (quad-attr-ref w world:x-position-key) Float)
|
||||
;; we want to align by baseline rather than top of box
|
||||
;; thus, subtract ascent from y to put baseline at the y coordinate
|
||||
(- (cast (quad-attr-ref w world:y-position-key) Float) (cast (quad-attr-ref w world:ascent-key 0) Float)) #t))
|
||||
|
||||
(define/override (render-page elements)
|
||||
(send dc start-page)
|
||||
(map/send render-element (filter-not whitespace/nbsp? elements))
|
||||
(send dc end-page))
|
||||
|
||||
(define/override (finalize xs)
|
||||
(send dc end-doc)
|
||||
(get-output-bytes dc-output-port))
|
||||
|
||||
(: render-to-file (Quad Path-String -> Void))
|
||||
(define/public (render-to-file doc-quad path)
|
||||
(define result-bytes (send this render doc-quad))
|
||||
(display-to-file result-bytes path #:exists 'replace #:mode 'binary))
|
||||
|
||||
|
||||
))
|
||||
@ -1,4 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require "quads-typed.rkt" racket/file racket/string racket/list racket/include typed/sugar/define)
|
||||
(provide (all-defined-out))
|
||||
(include "samples-base.rktd")
|
||||
@ -1,94 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require "utils-typed.rkt" "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt" racket/list racket/format)
|
||||
(require typed/rackunit)
|
||||
|
||||
(check-equal? (join-attrs (list (box '(width 10.0)) (quad-attrs (box '(x 10.0))) (list 'width 20.0)))
|
||||
(list (cons 'width 10.0) (cons 'x 10.0) (cons 'width 20.0)))
|
||||
|
||||
(check-equal? (flatten-attrs (box '(foo bar)) '(xray 10.0)) '((xray . 10.0) (foo . bar)))
|
||||
(check-equal? (flatten-attrs (box '(foo bar)) '(x 10.0)) '((x . 10.0) (foo . bar))) ; flatten-attrs moves x and y to front
|
||||
(check-equal? (flatten-attrs '(x -5.0) '(x 10.0)) '((x . 5.0)))
|
||||
|
||||
(check-equal? (flatten-attrs '(dup 100) '(dup 200)) '((dup . 200))) ; later overrides earlier
|
||||
|
||||
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar goo rab)))) '((foo . bar)))
|
||||
(check-equal? (gather-common-attrs (list (box '(foo bar zim zam)) (box '(foo bar)))) '((foo . bar)))
|
||||
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar zim zam)))) '((foo . bar)))
|
||||
(check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) empty)
|
||||
(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) empty)
|
||||
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo zam)))) empty)
|
||||
|
||||
(define b1 (box '(x 10.0) "1st" (box '(foo bar) "2nd") "3rd"))
|
||||
(define b1-flattened (list (box '(x 10.0) "1st") (box '(x 10.0 foo bar) "2nd") (box '(x 10.0) "3rd")))
|
||||
(define b3 (box '() (word) (line) (page)))
|
||||
|
||||
(check-true (quad= (flatten-quad b1) b1-flattened))
|
||||
|
||||
(define b2 (box '(x 10.0) (spacer) (box '(x 15.0) (spacer) (spacer)) (spacer)))
|
||||
(define b2-flattened (list (spacer '(x 10.0)) (spacer '(x 25.0)) (spacer '(x 25.0)) (spacer '(x 10.0))))
|
||||
|
||||
(check-true (quad= (flatten-quad b2) b2-flattened))
|
||||
|
||||
(check-true (quad= (split-quad b2) b2-flattened))
|
||||
|
||||
(check-true (quad= (flatten-quad (box '(foo 10) (spacer) (box) (spacer))) (list (spacer '(foo 10)) (box '(foo 10)) (spacer '(foo 10)))))
|
||||
|
||||
|
||||
|
||||
(check-equal? (compute-absolute-positions (page '(x 100.0 y 100.0) (line '(x 10.0 y 10.0) (word '(x 1.0 y 1.0) "hello")
|
||||
(word '(x 2.0 y 2.0) "world"))))
|
||||
(page '(x 100.0 y 100.0) (line '(x 110.0 y 110.0) (word '(x 111.0 y 111.0) "hello")(word '(x 112.0 y 112.0) "world"))))
|
||||
|
||||
(define b2-exploded (list (word '(x 10.0) "1") (word '(x 10.0) "s") (word '(x 10.0) "t") (word '(x 10.0 foo bar) "2") (word '(x 10.0 foo bar) "n") (word '(x 10.0 foo bar) "d") (word '(x 10.0) "3") (word '(x 10.0) "r") (word '(x 10.0) "d")))
|
||||
|
||||
(check-true (quad= (split-quad b1) b2-exploded))
|
||||
|
||||
(check-false (quad-has-attr? (box) 'foo))
|
||||
(check-true (quad-has-attr? (box '(foo bar)) 'foo))
|
||||
|
||||
(check-equal? (quad-attr-set (box '(foo bar)) 'foo 'zam) (box '(foo zam)))
|
||||
(check-equal? (quad-attr-set (box) 'foo 'zam) (box '(foo zam)))
|
||||
(check-equal? (quad-attr-set* (box) '(foo zam bar boo)) (box '(foo zam bar boo)))
|
||||
(check-equal? (quad-attr-set* (box '(foo bar)) '(foo zam bar boo)) (box '(foo zam bar boo)))
|
||||
|
||||
(check-equal? (quad-attr-remove (box '(foo bar zim zam)) 'foo) (box '(zim zam)))
|
||||
(check-equal? (quad-attr-remove (box) 'zim) (box))
|
||||
(check-equal? (quad-attr-remove* (box '(foo bar zim zam ding dong)) 'foo 'ding) (box '(zim zam)))
|
||||
(check-equal? (quad-attr-remove* (box) 'zim) (box))
|
||||
|
||||
|
||||
(check-true (quad-ends-with? (box '() "foo") "foo"))
|
||||
(check-false (quad-ends-with? (box '() "foo") "food"))
|
||||
(check-false (quad-ends-with? (box '() (box '() "foo")) "food"))
|
||||
(check-true (quad-ends-with? (box '() (box '() "foo")) "foo"))
|
||||
(check-true (quad-ends-with? (box '() (box '() "foo")) "o"))
|
||||
(check-true (quad-ends-with? (box '() (box '() (box '() (box '() (box '() "foo-"))))) "-"))
|
||||
|
||||
(check-equal? (quad-append (box '() "foo") "bar") (box '() "foo" "bar"))
|
||||
(check-equal? (quad-append (box '() "foo") (box '() "bar")) (box '() "foo" (box '() "bar")))
|
||||
|
||||
(check-equal? (quad-last-char (box '() (box '() "foo") "food")) "d")
|
||||
(check-equal? (quad-last-char (box '() (box '() "foo"))) "o")
|
||||
(check-equal? (quad-last-char (box '() "foo")) "o")
|
||||
(check-false (quad-last-char (box)))
|
||||
|
||||
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box '() "foo")) "f")
|
||||
(check-false (quad-first-char (box)))
|
||||
|
||||
(check-equal? (quad->string (box '(width 100) "foo")) "foo")
|
||||
(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar"))) "foobar")
|
||||
(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar") "ino")) "foobarino")
|
||||
(check-equal? (quad->string (box '(width 100))) "")
|
||||
|
||||
(check-false (whitespace? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (word '() (~a #\u00A0))))
|
||||
(check-false (whitespace? (format " ~a " #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (format " ~a " #\u00A0)))
|
||||
;(define funny-unicode-spaces (map ~a (list #\u2000 #\u2007 #\u2009 #\u200a #\u202f)))
|
||||
;(check-true (andmap whitespace? funny-unicode-spaces))
|
||||
;(check-true (andmap whitespace/nbsp? funny-unicode-spaces))
|
||||
|
||||
(check-equal? (measure-text "foobar" 10.0 "Courier" 'normal 'normal) 36.0059)
|
||||
@ -1,596 +0,0 @@
|
||||
#lang typed/racket/base
|
||||
(require (for-syntax racket/base racket/syntax))
|
||||
(require typed/sugar/list typed/sugar/define)
|
||||
(require math/flonum (except-in racket/list flatten) racket/vector math/statistics racket/bool)
|
||||
(require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))])
|
||||
(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt" "utils-typed.rkt")
|
||||
|
||||
;; predicate for the soft hyphen
|
||||
(define/typed (soft-hyphen? x)
|
||||
(String -> Boolean)
|
||||
(equal? (format "~a" world:soft-hyphen) x))
|
||||
|
||||
;; visible characters that also mark possible breakpoints
|
||||
(define/typed (visible-breakable? x)
|
||||
(String -> Boolean)
|
||||
(and (member x world:hyphens-and-dashes) #t))
|
||||
|
||||
;; invisible characters that denote possible breakpoints
|
||||
(define/typed (invisible-breakable? x)
|
||||
(String -> Boolean)
|
||||
(and (member x (cons world:empty-string world:spaces)) #t))
|
||||
|
||||
;; union of visible & invisible
|
||||
(define/typed (breakable? x)
|
||||
(Any -> Boolean)
|
||||
(cond
|
||||
[(string? x) (or (visible-breakable? x) (invisible-breakable? x))]
|
||||
;; word? should have a filter that returns a Quad type, then the Quad? check will be unnecessary
|
||||
[(and (Quad? x) (word? x)) (breakable? (word-string x))]
|
||||
[else #f]))
|
||||
|
||||
;; used by insert-spacers to determine which characters
|
||||
;; can be surrounded by stretchy spacers
|
||||
(define/typed (takes-justification-space? x)
|
||||
(Any -> Boolean)
|
||||
(whitespace/nbsp? x))
|
||||
|
||||
;; test if a quad can be a word break:
|
||||
;; either it's an explicit word break,
|
||||
;; or it's breakable (and can be converted to a word break)
|
||||
(define/typed (possible-word-break-quad? q)
|
||||
(Quad -> Boolean)
|
||||
(or (word-break? q) (breakable? q)))
|
||||
|
||||
|
||||
;; convert a possible word break into an actual one
|
||||
(define/typed (convert-to-word-break q)
|
||||
(Quad -> Quad)
|
||||
(when (not (possible-word-break-quad? q))
|
||||
(error 'convert-to-word-break "input is not a possible word break:" q))
|
||||
(define result (cond
|
||||
[(word-break? q) q]
|
||||
[(word? q)
|
||||
(define str (word-string q)) ; str will be one character long, because we've exploded our input
|
||||
(apply word-break
|
||||
(merge-attrs q ; take q's attributes for formatting purposes
|
||||
(cond
|
||||
;; a space is ordinarily visible, but disappears at the end of a line
|
||||
[(equal? str " ") (list world:no-break-key " " world:before-break-key "")]
|
||||
;; soft hyphen is ordinarily invisible, but appears at the end of a line
|
||||
[(soft-hyphen? str) (list world:no-break-key "" world:before-break-key "-")]
|
||||
;; a visible breakable character is always visible
|
||||
[(visible-breakable? str) (list world:no-break-key str world:before-break-key str)]
|
||||
[else (world:default-word-break-list)])) (quad-list q))]
|
||||
[else #f]))
|
||||
(or result (error 'convert-to-word-break "result was a not word break for input:" q)))
|
||||
|
||||
(define/typed (make-unbreakable q)
|
||||
(Quad -> Quad)
|
||||
(quad-attr-set q world:unbreakable-key #t))
|
||||
|
||||
|
||||
;; take list of atomic quads and gather them into pieces
|
||||
;; a piece is an indivisible chunk of a line.
|
||||
;; meaning, a line can wrap at a piece boundary, but not elsewhere.
|
||||
;; hyphenation produces more, smaller pieces, which means more linebreak opportunities
|
||||
;; but this also makes wrapping slower.
|
||||
(define-type Make-Pieces-Type ((Listof Quad) -> (Listof PieceQuad)))
|
||||
(define/typed (make-pieces qs)
|
||||
Make-Pieces-Type
|
||||
(define-values (breakable-items items-to-make-unbreakable) (split-at-right qs (min world:minimum-last-line-chars (length qs))))
|
||||
(define unbreak-qs (append breakable-items (map make-unbreakable items-to-make-unbreakable)))
|
||||
(define lists-of-quads (slicef-after unbreak-qs (λ([q : Quad]) (and (possible-word-break-quad? q) (not (quad-attr-ref q world:unbreakable-key #f))))))
|
||||
(define-values (first-lists-of-quads last-list-of-quads) (split-last lists-of-quads))
|
||||
(define/typed (make-first-pieces qs)
|
||||
((Listof Quad) -> PieceQuad)
|
||||
(let-values ([(first-qs last-q) ((inst split-last Quad) qs)])
|
||||
(apply piece (list world:word-break-key (convert-to-word-break last-q)) first-qs)))
|
||||
(append (map make-first-pieces first-lists-of-quads)
|
||||
(list (apply piece null last-list-of-quads))))
|
||||
|
||||
|
||||
;; extract font attributes from quad, or get default values
|
||||
(define/typed (font-attributes-with-defaults q)
|
||||
(Quad -> (List Font-Size Font-Name Font-Weight Font-Style))
|
||||
(list
|
||||
(assert (let ([size (quad-attr-ref/parameter q world:font-size-key)])
|
||||
(if (exact-integer? size) (fl size) size)) Font-Size?)
|
||||
(assert (quad-attr-ref/parameter q world:font-name-key) Font-Name?)
|
||||
(assert (quad-attr-ref/parameter q world:font-weight-key) Font-Weight?)
|
||||
(assert (quad-attr-ref/parameter q world:font-style-key) Font-Style?)))
|
||||
|
||||
|
||||
;; get the width of a quad.
|
||||
;; Try the attr first, and if it's not available, compute the width.
|
||||
;; comes in fast or slow versions.
|
||||
;; not designed to update the source quad.
|
||||
(define-type Measure-Quad-Type (Quad -> Float))
|
||||
(define/typed (quad-width q)
|
||||
Measure-Quad-Type
|
||||
(cond
|
||||
[(quad-has-attr? q world:width-key) (fl (assert (quad-attr-ref q world:width-key) flonum?))]
|
||||
[(ormap (λ([pred : (Any -> Boolean)]) (pred q)) (list char? run? word? word-break?))
|
||||
(apply measure-text (word-string q)
|
||||
(font-attributes-with-defaults q))]
|
||||
[(LineQuad? q) (foldl fl+ 0.0 (map quad-width (quad-list q)))]
|
||||
[else 0.0]))
|
||||
|
||||
;; get the ascent (distance from top of text to baseline)
|
||||
;; used by renderer to align text runs baseline-to-baseline.
|
||||
;; consult the attrs, and if not available, compute it.
|
||||
;; not designed to update the source quad.
|
||||
(define/typed (ascent q)
|
||||
(Quad -> Float)
|
||||
(define ascent-value-or-false (quad-attr-ref q world:ascent-key #f))
|
||||
(if (and ascent-value-or-false (flonum? ascent-value-or-false))
|
||||
ascent-value-or-false
|
||||
(cond
|
||||
[(ormap (λ([pred : (Any -> Boolean)]) (pred q)) (list char? run? word? word-break?))
|
||||
(apply measure-ascent (word-string q) (font-attributes-with-defaults q))]
|
||||
[else 0.0])))
|
||||
|
||||
|
||||
;; convert a piece into its final form, which depends on location.
|
||||
;; if a piece appears at the end of a line, it is rendered in "before break" mode.
|
||||
;; if a piece appears elsewhere in a line, it is rendered in "no break" mode.
|
||||
;; this allows the appearance of a piece to change depending on whether it's at the end.
|
||||
;; and thus give correct behavior to trailing word spaces, soft hyphens, etc.
|
||||
|
||||
(define/typed (render-piece p [before-break? #f])
|
||||
((PieceQuad) (Boolean) . ->* . PieceQuad)
|
||||
;; a piece doesn't necessarily have a word-break item in it.
|
||||
;; only needs it if the appearance of the piece changes based on location.
|
||||
;; so words are likely to have a word-break item; boxes not.
|
||||
;; the word break item contains the different characters needed to finish the piece.
|
||||
(define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Word-BreakQuad? v)))))
|
||||
(let ([p (apply piece (attr-delete (quad-attrs p) world:word-break-key) (quad-list p))]) ; so it doesn't propagate into subquads
|
||||
(if the-word-break
|
||||
(apply piece (quad-attrs p)
|
||||
(append (quad-list p) (let ([rendered-wb ((if before-break?
|
||||
word-break->before-break
|
||||
word-break->no-break) the-word-break)])
|
||||
(if (> (string-length (word-string rendered-wb)) 0) ; if rendered-wb is "", don't append it
|
||||
(list rendered-wb)
|
||||
empty))))
|
||||
p)))
|
||||
|
||||
|
||||
;; shorthand
|
||||
(define/typed (render-piece-before-break p)
|
||||
(PieceQuad -> PieceQuad)
|
||||
(render-piece p #t))
|
||||
|
||||
|
||||
;; helper macro to convert quad into word-break.
|
||||
;; look up the break character and convert the quad based on what is found.
|
||||
(define/typed (render-word-break wb key)
|
||||
(Word-BreakQuad Symbol -> Quad)
|
||||
(let ([break-char (quad-attr-ref wb key)])
|
||||
(quad (if (whitespace? break-char) 'word-break 'word)
|
||||
(quad-attrs (quad-attr-remove* wb world:no-break-key world:before-break-key)) (list (assert (quad-attr-ref wb key) string?)))))
|
||||
|
||||
;; uses macro above in no-break mode.
|
||||
(define/typed (word-break->no-break wb)
|
||||
(Word-BreakQuad -> Quad)
|
||||
(render-word-break wb world:no-break-key))
|
||||
|
||||
;; uses macro above in before-break mode.
|
||||
(define/typed (word-break->before-break wb)
|
||||
(Word-BreakQuad -> Quad)
|
||||
(render-word-break wb world:before-break-key))
|
||||
|
||||
;; is this the last line? compare current line-idx to total lines
|
||||
(define/typed (last-line? line)
|
||||
(Quad -> Boolean)
|
||||
(define line-idx (assert (quad-attr-ref line world:line-index-key #f) Index?))
|
||||
(define lines (assert (quad-attr-ref line world:total-lines-key #f) Index?))
|
||||
(and line-idx lines (= (add1 line-idx) lines)))
|
||||
|
||||
;; optical kerns are automatically inserted at the beginning and end of a line
|
||||
;; (by the pieces->line function)
|
||||
;; but may also be found elsewhere, imperatively (e.g., before an indent)
|
||||
;; they allow certain characters to hang over the line margin.
|
||||
;; optical kerns aren't considered when the line is being composed,
|
||||
;; rather they are an adjustment added to a composed line.
|
||||
;; the optical kern doesn't have left- or right-handed versions.
|
||||
;; it just looks at quads on both sides and kerns them if appropriate.
|
||||
;; in practice, only one will likely be used.
|
||||
(define/typed (render-optical-kerns exploded-line-quads)
|
||||
((Listof Quad) -> (Listof Quad))
|
||||
(define/typed (overhang-width q)
|
||||
((U Quad False) -> Float)
|
||||
(if (and (word? q) (member (word-string q) world:hanging-chars))
|
||||
(* -1.0 (world:optical-overhang) (apply measure-text (word-string q) (font-attributes-with-defaults q)))
|
||||
0.0))
|
||||
(cond
|
||||
[(not (empty? exploded-line-quads))
|
||||
;; after exploding, each quad will have a string with one character.
|
||||
(define shifted-lists (shifts exploded-line-quads '(1 -1)))
|
||||
(define lefts (first shifted-lists))
|
||||
(define rights (second shifted-lists))
|
||||
(for/list : (Listof Quad) ([q-left (in-list lefts)][q (in-list exploded-line-quads)][q-right (in-list rights)])
|
||||
(if (optical-kern? q)
|
||||
(quad-attr-set q world:width-key (fl+ (overhang-width q-left) (overhang-width q-right)))
|
||||
q))]
|
||||
[else exploded-line-quads]))
|
||||
|
||||
|
||||
;; ultimately every line is filled to fit the whole measure.
|
||||
;; 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.
|
||||
(define/typed+provide (insert-spacers-in-line line-in [alignment-override #f])
|
||||
((LineQuad) ((Option Symbol)) . ->* . LineQuad)
|
||||
;; important principle: avoid peeking into quad-list to get attributes.
|
||||
;; because non-attributed quads may be added.
|
||||
;; here, we know that common attributes are hoisted into the line.
|
||||
;; so rely on line attributes to get horiz alignment.
|
||||
(define key-to-use (if (and (last-line? line-in) (quad-has-attr? line-in world:horiz-alignment-last-line-key))
|
||||
world:horiz-alignment-last-line-key
|
||||
world:horiz-alignment-key))
|
||||
|
||||
(define horiz-alignment (or alignment-override (quad-attr-ref line-in key-to-use (world:horiz-alignment-default))))
|
||||
(define default-spacer (spacer))
|
||||
(define-values (before middle after) (case horiz-alignment
|
||||
[(left) (values #f #f default-spacer)]
|
||||
[(right) (values default-spacer #f #f)]
|
||||
[(center) (values default-spacer #f default-spacer)]
|
||||
[(justified justify) (values #f default-spacer #f)]
|
||||
[else (values #f #f #f)]))
|
||||
|
||||
(define/typed (copy-with-attrs q attr-source)
|
||||
(Quad Quad -> Quad)
|
||||
(define keys-to-ignore '(width)) ; width will be determined during fill routine
|
||||
(define filtered-attrs (and (quad-attrs attr-source)
|
||||
(quad-attrs (apply quad-attr-remove* attr-source keys-to-ignore))))
|
||||
(quad (quad-name q) (merge-attrs (or filtered-attrs null) q) (quad-list q)))
|
||||
|
||||
(apply line (quad-attrs line-in)
|
||||
(flatten-quadtree (let ([qs (quad-list line-in)])
|
||||
(if (not (empty? qs))
|
||||
(list (if before (copy-with-attrs before (first qs)) null)
|
||||
(map (λ([q : Quad]) (if (and middle (takes-justification-space? q))
|
||||
(let ([interleaver (copy-with-attrs middle q)])
|
||||
(list interleaver q interleaver))
|
||||
(list q))) qs)
|
||||
(if after (copy-with-attrs after (last qs)) null))
|
||||
qs)))))
|
||||
|
||||
|
||||
;; installs the width in the quad.
|
||||
;; this becomes the value reported by quad-width.
|
||||
(define/typed (embed-width q w)
|
||||
(Quad Float -> Quad)
|
||||
(quad-attr-set q world:width-key w))
|
||||
|
||||
;; installs the ascent in the quad.
|
||||
(define/typed (record-ascent q)
|
||||
(Quad -> Quad)
|
||||
(quad-attr-set q world:ascent-key (ascent q)))
|
||||
|
||||
;; helper function: doesn't need contract because it's already covered by the callers
|
||||
(define/typed (render-pieces ps)
|
||||
((Listof PieceQuad) -> (Listof PieceQuad))
|
||||
(define-values (initial-ps last-p) ((inst split-last PieceQuad) ps))
|
||||
(snoc (map render-piece initial-ps) (render-piece-before-break last-p)))
|
||||
|
||||
|
||||
(define/typed (calc-looseness total-width measure)
|
||||
(Float Float -> Float)
|
||||
(round-float (fl/ (fl- measure total-width) measure)))
|
||||
|
||||
|
||||
;; compose pieces into a finished line.
|
||||
;; take the contents of the rendered pieces and merge them.
|
||||
;; compute looseness for line as a whole.
|
||||
;; also add ascent to each component quad, which can be different depending on font & size.
|
||||
(define-type Compose-Line-Type ((Listof PieceQuad) (Quad -> Float) -> LineQuad))
|
||||
(define/typed (pieces->line ps measure-quad-proc)
|
||||
Compose-Line-Type
|
||||
(define rendered-pieces (render-pieces ps))
|
||||
(cond
|
||||
[(not (empty? rendered-pieces))
|
||||
;; handle optical kerns here to avoid resplitting and rejoining later.
|
||||
(define line-quads (assert (append-map quad-list rendered-pieces) (λ(lqs) (not (empty? lqs)))))
|
||||
(define line-quads-maybe-with-opticals
|
||||
(if world:use-optical-kerns?
|
||||
(render-optical-kerns
|
||||
(let ([my-ok (list (optical-kern (quad-attrs (first line-quads))))]) ; take attrs from line, incl measure
|
||||
(append my-ok line-quads my-ok)))
|
||||
line-quads))
|
||||
(define merged-quads (assert (join-quads line-quads-maybe-with-opticals) (λ(mqs) (not (empty? mqs)))))
|
||||
(define merged-quad-widths (map measure-quad-proc merged-quads)) ; 10% of function time
|
||||
|
||||
(log-quad-debug "making pieces into line = ~v" (apply string-append (map quad->string merged-quads)))
|
||||
|
||||
;; if measure key isn't present, allow an error, because that's weird
|
||||
(when (not (quad-has-attr? (first merged-quads) world:measure-key))
|
||||
(error 'pieces->line "quad has no measure key: ~a" (first merged-quads)))
|
||||
|
||||
(define measure (let ([val (quad-attr-ref (first merged-quads) world:measure-key)])
|
||||
(if (flonum? val)
|
||||
val
|
||||
(error "got bad value for measure"))))
|
||||
(define looseness (calc-looseness (foldl fl+ 0.0 merged-quad-widths) measure))
|
||||
|
||||
;; quads->line function hoists common attributes into the line
|
||||
(let* ([new-line-quads (map embed-width merged-quads merged-quad-widths)]
|
||||
[new-line-quads (map record-ascent new-line-quads)]
|
||||
[new-line (quads->line new-line-quads)]
|
||||
[new-line (apply line (attr-change (quad-attrs new-line) (list world:line-looseness-key looseness)) (quad-list new-line))])
|
||||
new-line)]
|
||||
[else (line)]))
|
||||
|
||||
|
||||
;; a faster line-measuring function used by the wrapping function to test lines.
|
||||
(define/typed (measure-potential-line ps)
|
||||
((Listof PieceQuad) -> Float)
|
||||
(foldl fl+ 0.0 (append-map (λ([rp : PieceQuad]) (map quad-width (quad-list rp))) (render-pieces ps))))
|
||||
|
||||
|
||||
(define/typed (vector-break-at vec bps)
|
||||
((Vectorof Any) (Listof Nonnegative-Integer) -> (Listof (Vectorof Any)))
|
||||
(define-values (vecs _) ;; loop backward
|
||||
(for/fold ([vecs : (Listof (Vectorof Any)) empty][end : Nonnegative-Integer (vector-length vec)])([start (in-list (reverse (cons 0 bps)))])
|
||||
(if (= start end)
|
||||
(values vecs start)
|
||||
(values (cons ((inst vector-copy Any) vec start end) vecs) start))))
|
||||
vecs)
|
||||
|
||||
|
||||
;; makes a wrap function by combining component functions.
|
||||
(define-type Wrap-Proc-Type (((Listof Quad)) (Float) . ->* . (Listof LineQuad)))
|
||||
(define/typed (make-wrap-proc
|
||||
make-pieces-proc
|
||||
measure-quad-proc
|
||||
compose-line-proc
|
||||
find-breakpoints-proc)
|
||||
((Make-Pieces-Type Measure-Quad-Type Compose-Line-Type Find-Breakpoints-Type) () . ->* . Wrap-Proc-Type)
|
||||
(λ(qs [measure #f])
|
||||
(if (not (empty? qs))
|
||||
(let* ([measure (or measure (assert (quad-attr-ref/parameter (car qs) world:measure-key) flonum?))]
|
||||
[qs (if (quad-has-attr? (car qs) world:measure-key)
|
||||
qs
|
||||
((inst map Quad Quad) (λ(q) (quad-attr-set q world:measure-key measure)) qs))])
|
||||
(log-quad-debug "wrapping on measure = ~a" measure)
|
||||
(define pieces (make-pieces-proc qs))
|
||||
(define bps (find-breakpoints-proc (list->vector pieces) measure))
|
||||
(define broken-pieces (break-at pieces bps))
|
||||
(map (λ([broken-piece : (Listof PieceQuad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces))
|
||||
(list (line)))))
|
||||
|
||||
(define width? flonum?)
|
||||
(define measure? flonum?)
|
||||
(define (breakpoints? x) (and (list? x) (andmap integer? x)))
|
||||
|
||||
(define/typed (install-measurement-keys p)
|
||||
(GroupQuad -> Quad)
|
||||
(define basic-width (round-float
|
||||
(foldl fl+ 0.0 (map quad-width (quad-list p)))))
|
||||
(define p-word-break (assert (quad-attr-ref p world:word-break-key #f) quad?))
|
||||
(define before-break-width (fl+ basic-width (if p-word-break
|
||||
(quad-width (word (quad-attrs p-word-break) (assert (quad-attr-ref p-word-break world:before-break-key) QuadListItem?)))
|
||||
0.0)))
|
||||
(define no-break-width (fl+ basic-width (if p-word-break
|
||||
(quad-width (word (quad-attrs p-word-break) (assert (quad-attr-ref p-word-break world:no-break-key) QuadListItem?)))
|
||||
0.0)))
|
||||
(quad-attr-set* p (list 'bb-width before-break-width 'nb-width no-break-width)))
|
||||
|
||||
(require sugar/debug)
|
||||
(define/typed (make-piece-vectors pieces)
|
||||
((Vectorof PieceQuad) -> (values (Vectorof Float) (Vectorof Float)))
|
||||
(define pieces-measured
|
||||
(for/list : (Listof (Vector Float Float Float)) ([p (in-vector pieces)])
|
||||
(define wb (assert (quad-attr-ref p world:word-break-key #f) (λ(wb) (or (false? wb) (quad? wb)))))
|
||||
(vector
|
||||
;; throw in 0.0 in case for/list returns empty
|
||||
(foldl fl+ 0.0 (for/list : (Listof Float) ([q (in-list (quad-list p))])
|
||||
(define str (quad->string q))
|
||||
(if (equal? str "")
|
||||
(assert (quad-attr-ref q world:width-key 0.0) flonum?)
|
||||
(apply measure-text (quad->string q) (font-attributes-with-defaults q)))))
|
||||
(if wb (apply measure-text (assert (quad-attr-ref wb world:no-break-key) string?) (font-attributes-with-defaults wb)) 0.0)
|
||||
(if wb (apply measure-text (assert (quad-attr-ref wb world:before-break-key) string?) (font-attributes-with-defaults wb)) 0.0))))
|
||||
(values
|
||||
(for/vector : (Vectorof Float) ([p (in-list pieces-measured)])
|
||||
(fl+ (vector-ref p 0) (vector-ref p 1))) ; first = word length, second = nb length
|
||||
(for/vector : (Vectorof Float) ([p (in-list pieces-measured)])
|
||||
(fl+ (vector-ref p 0) (vector-ref p 2))))) ; first = word length, third = bb length
|
||||
|
||||
|
||||
(define/typed (make-trial-line pieces-rendered-widths pieces-rendered-before-break-widths i j)
|
||||
((Vectorof Float) (Vectorof Float) Breakpoint Breakpoint -> (Vectorof Float))
|
||||
(let ([vec (vector-copy pieces-rendered-widths i j)])
|
||||
(vector-set! vec (sub1 (vector-length vec)) (vector-ref pieces-rendered-before-break-widths (sub1 j)))
|
||||
vec))
|
||||
|
||||
(define/typed (get-line-width line)
|
||||
((Vectorof Float) -> Float)
|
||||
(round-float (foldl + 0.0 (vector->list line))))
|
||||
|
||||
(struct $penalty ([hyphens : Nonnegative-Integer][width : Value-Type]) #:transparent)
|
||||
|
||||
;; top-level adaptive wrap proc.
|
||||
;; first-fit and best-fit are variants.
|
||||
(define-type Find-Breakpoints-Type ((Vectorof PieceQuad) Float -> (Listof Breakpoint)))
|
||||
(define/typed (adaptive-fit-proc pieces measure [use-first? #t] [use-best? #t])
|
||||
(((Vectorof PieceQuad) Float) (Boolean Boolean) . ->* . (Listof Breakpoint))
|
||||
|
||||
;; this is the winning performance strategy: extract the numbers first, then just wrap on those.
|
||||
;; todo: how to avoid re-measuring pieces later?
|
||||
;; todo: how to retain information about words per line and hyphen at end?
|
||||
(define-values (pieces-rendered-widths pieces-rendered-before-break-widths)
|
||||
(make-piece-vectors pieces))
|
||||
(define pieces-with-word-space (vector-map (λ([piece : PieceQuad]) (and (quad-has-attr? piece world:word-break-key) (equal? (quad-attr-ref (assert (quad-attr-ref piece world:word-break-key) quad?) world:no-break-key) " "))) pieces))
|
||||
|
||||
(define (make-first-fit-bps-and-widths)
|
||||
(define-values (reversed-bps reversed-widths)
|
||||
;; breakpoints get stacked onto bps, so (car bps) is always the next starting point
|
||||
;; thus use '(0) as a starting value to indicate that the first line starts at bp 0
|
||||
;; bps will end up with at least two values (if all pieces fit on first line, bps = 0 and last bp)
|
||||
(for/fold ([bps : (Pairof Breakpoint (Listof Breakpoint)) '(0) ]
|
||||
[line-widths : (Listof Value-Type) empty])
|
||||
([j-1 : Breakpoint (in-range (vector-length pieces))])
|
||||
(define line-starting-bp (car bps))
|
||||
(define line-width (get-line-width (make-trial-line pieces-rendered-widths
|
||||
pieces-rendered-before-break-widths
|
||||
line-starting-bp (add1 j-1))))
|
||||
(if (fl> line-width (fl* world:allowed-overfull-ratio measure))
|
||||
(values (cons j-1 bps) (cons line-width line-widths))
|
||||
(values bps line-widths))))
|
||||
(define bps (reverse reversed-bps))
|
||||
(values (if (not (empty? bps)) (cdr bps) empty) (reverse reversed-widths)))
|
||||
|
||||
(define (fu-formula)
|
||||
(define line-count (length trial-line-widths))
|
||||
(cond
|
||||
[(<= line-count 2) 1.0] ; signals that first-fit is always OK with 1 or 2 lines
|
||||
[else ; only measure middle lines. we know bps has at least 2 bps
|
||||
(define looseness-stddev (fl (stddev ((inst map Float Float) (λ(x) (calc-looseness x measure)) (drop-right (drop trial-line-widths 1) 1)))))
|
||||
(define piece-count (vector-length pieces-rendered-widths))
|
||||
(define pieces-per-line (/ piece-count (sub1 line-count))) ; todo: more accurate to count only pieces in middle
|
||||
(foldl fl+ 0.0 (list 2.2 (fllog (flabs looseness-stddev)) (fl* 0.09 (fl pieces-per-line))))])) ; the FU FORMULA
|
||||
|
||||
;; only buy first-fit-bps if use-first? is true.
|
||||
;; use (values '(0) '(0.0)) as void-ish values that will typecheck properly.
|
||||
(define-values (first-fit-bps trial-line-widths) (if use-first? (make-first-fit-bps-and-widths) (values '(0) '(0.0))))
|
||||
|
||||
(cond
|
||||
;; possible outcomes at this branch:
|
||||
;; adaptive wrap: use-first and use-best are true, so first-fit-bps will exist, and fu-formula will be used.
|
||||
;; first-fit wrap: use-first is true but not use-best. So first-fit-bps will be returned regardless.
|
||||
;; best-fit wrap: use-first is false but use-best is true. So first-fit-bps will be skipped, and move on to best-fit.
|
||||
[(and use-first? (if use-best? (fl> (fu-formula) 0.0) #t))
|
||||
(log-quad-debug "first-fit breakpoints = ~a" first-fit-bps)
|
||||
first-fit-bps]
|
||||
[else
|
||||
|
||||
(define/typed ($penalty->value x)
|
||||
($penalty -> Value-Type)
|
||||
($penalty-width x))
|
||||
(define initial-value ($penalty 0 0.0))
|
||||
|
||||
(log-quad-debug "~a pieces to wrap = ~v" (vector-length pieces) (vector-map quad->string pieces))
|
||||
|
||||
(define/typed (penalty i j)
|
||||
Matrix-Proc-Type
|
||||
(cond
|
||||
[(or (>= i j) ; implies negative or zero length line
|
||||
(> j (vector-length pieces))) ; exceeds available pieces
|
||||
($penalty 0 (fl* -1.0 (fl i)))] ; ocm out of bounds signal
|
||||
[else
|
||||
(define penalty-up-to-i (assert (ocm-min-entry ocm i) $penalty?))
|
||||
(define last-piece-to-test (vector-ref pieces (sub1 j)))
|
||||
(define new-hyphen?
|
||||
(and (quad-has-attr? last-piece-to-test world:word-break-key)
|
||||
(equal? (assert (quad-attr-ref (assert (quad-attr-ref last-piece-to-test world:word-break-key) quad?) world:before-break-key) string?) "-")))
|
||||
(define cumulative-hyphens (if (not new-hyphen?)
|
||||
0
|
||||
(add1 ($penalty-hyphens penalty-up-to-i))))
|
||||
|
||||
($penalty
|
||||
cumulative-hyphens
|
||||
(round-float
|
||||
(apply + (list
|
||||
(if (> cumulative-hyphens world:hyphen-limit)
|
||||
(fl world:hyphen-penalty)
|
||||
0.0)
|
||||
(fl world:new-line-penalty)
|
||||
($penalty->value penalty-up-to-i)
|
||||
(let ([line-width (get-line-width (make-trial-line pieces-rendered-widths pieces-rendered-before-break-widths i j))])
|
||||
(cond
|
||||
;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity.
|
||||
;; multiply by -1 because line-width is longer than measure, thus diff is negative
|
||||
[(fl> line-width (fl* world:allowed-overfull-ratio measure))
|
||||
(fl* (fl- line-width measure) (flexpt 10.0 7.0))]
|
||||
;; standard penalty, optionally also applied to last line (by changing operator)
|
||||
[((if world:last-line-can-be-short < <=) j (vector-length pieces))
|
||||
(define words (fl (vector-count (λ(x) x) (vector-copy pieces-with-word-space i (sub1 j)))))
|
||||
(fl/ (flexpt (fl- measure line-width) 2.0) (flmax 1.0 words))]
|
||||
;; only option left is (= j (vector-length pieces)), meaning we're on the last line.
|
||||
;; 0 penalty means any length is ok.
|
||||
;[(< (length pieces-to-test) (world:minimum-last-line-pieces)) 50000]
|
||||
[else 0.0]))))))]))
|
||||
|
||||
(define ocm : OCM-Type (make-ocm penalty (cast $penalty->value Entry->Value-Type) initial-value))
|
||||
|
||||
;; starting from last position, ask ocm for position of row minimum (= new-pos)
|
||||
;; collect this value, and use it as the input next time
|
||||
;; until you reach first position.
|
||||
(define first-position 0)
|
||||
(define last-position (vector-length pieces))
|
||||
(define result (let loop : (Listof Breakpoint) ([pos : Breakpoint last-position][acc : (Listof Breakpoint) null])
|
||||
(let ([next-pos (assert (ocm-min-index ocm pos) Breakpoint?)]) ; first look ahead ...
|
||||
(if (= next-pos first-position) ; therefore we're done
|
||||
acc
|
||||
(loop next-pos (cons next-pos acc))))))
|
||||
|
||||
(log-quad-debug "best-fit breakpoints = ~a" result)
|
||||
result]))
|
||||
|
||||
|
||||
;; wrap proc based on greedy 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 : (Vectorof PieceQuad)] [y : Float]) (adaptive-fit-proc x y #t #f))))
|
||||
|
||||
;; wrap proc based on penalty function
|
||||
(define+provide wrap-best (make-wrap-proc
|
||||
make-pieces
|
||||
quad-width
|
||||
pieces->line
|
||||
(λ([x : (Vectorof PieceQuad)] [y : Float]) (adaptive-fit-proc x y #f #t)))) ; note difference in boolean args
|
||||
|
||||
(define+provide wrap-adaptive (make-wrap-proc
|
||||
make-pieces
|
||||
quad-width
|
||||
pieces->line
|
||||
adaptive-fit-proc))
|
||||
|
||||
|
||||
(define/typed (fixed-width? q)
|
||||
(Quad -> Boolean)
|
||||
(quad-has-attr? q world:width-key))
|
||||
|
||||
|
||||
;; build quad out to a given width by distributing excess into spacers
|
||||
;; todo: adjust this to work recursively, so that fill operation cascades down
|
||||
;; and broaden type from just LineQuad
|
||||
(define/typed+provide (fill starting-quad [target-width? #f])
|
||||
((LineQuad) ((Option Float)) . ->* . LineQuad)
|
||||
(define target-width (or target-width? (assert (quad-attr-ref starting-quad world:measure-key) flonum?)))
|
||||
(define subquads (quad-list starting-quad))
|
||||
(define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers.
|
||||
(define width-used (foldl fl+ 0.0 (map quad-width fixed-subquads)))
|
||||
(define width-remaining (round-float (- target-width width-used)))
|
||||
(cond
|
||||
;; check for zero condition because we want to divide by this number
|
||||
;; if there's no spacers, put one in
|
||||
;; todo: go in two rounds, once for word spacers, and once for line spacers?
|
||||
;; or separate the line alignment & word-spacing properties?
|
||||
[(fl= 0.0 (fl (length flexible-subquads))) (fill (insert-spacers-in-line starting-quad (world:horiz-alignment-default)) target-width)]
|
||||
[else (define width-per-flexible-quad (round-float (fl/ width-remaining (fl (length flexible-subquads)))))
|
||||
(define new-quad-list ((inst map Quad Quad) (λ(q) (if (spacer? q)
|
||||
(quad-attr-set q world:width-key width-per-flexible-quad)
|
||||
q)) subquads))
|
||||
|
||||
(apply line (quad-attrs (quad-attr-set starting-quad world:width-key target-width)) new-quad-list)]))
|
||||
|
||||
|
||||
;; add x positions to a list of fixed-width quads
|
||||
;; todo: adjust this to work recursively, so that positioning operation cascades down
|
||||
(define/typed+provide (add-horiz-positions starting-quad)
|
||||
(GroupQuad -> GroupQuad)
|
||||
(define-values (new-quads final-width)
|
||||
(for/fold ([new-quads : (Listof Quad) empty][width-so-far : Float 0.0])([q (in-list (quad-list starting-quad))])
|
||||
(values (cons (quad-attr-set q world:x-position-key width-so-far) new-quads) (round-float (fl+ (quad-width q) width-so-far)))))
|
||||
(quad (quad-name starting-quad) (quad-attrs starting-quad) (reverse new-quads)))
|
||||
|
||||
Loading…
Reference in New Issue