diff --git a/quad/lib-typed.rkt b/quad/lib-typed.rkt deleted file mode 100644 index 58833c7b..00000000 --- a/quad/lib-typed.rkt +++ /dev/null @@ -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)]))) \ No newline at end of file diff --git a/quad/logger-typed.rkt b/quad/logger-typed.rkt deleted file mode 100644 index 6dd094cc..00000000 --- a/quad/logger-typed.rkt +++ /dev/null @@ -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))) - diff --git a/quad/main-typed-sample.rkt b/quad/main-typed-sample.rkt deleted file mode 100644 index 532a50c1..00000000 --- a/quad/main-typed-sample.rkt +++ /dev/null @@ -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"))) \ No newline at end of file diff --git a/quad/main-typed-tests.rkt b/quad/main-typed-tests.rkt deleted file mode 100644 index 7539dc36..00000000 --- a/quad/main-typed-tests.rkt +++ /dev/null @@ -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")) diff --git a/quad/main-typed.rkt b/quad/main-typed.rkt deleted file mode 100644 index fc180998..00000000 --- a/quad/main-typed.rkt +++ /dev/null @@ -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) - - - - diff --git a/quad/measure-typed.rkt b/quad/measure-typed.rkt deleted file mode 100644 index 448d087b..00000000 --- a/quad/measure-typed.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/quad/ocm-typed-test.rkt b/quad/ocm-typed-test.rkt deleted file mode 100644 index 4c25131f..00000000 --- a/quad/ocm-typed-test.rkt +++ /dev/null @@ -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 \ No newline at end of file diff --git a/quad/ocm-typed.rkt b/quad/ocm-typed.rkt deleted file mode 100644 index 83d1d6e6..00000000 --- a/quad/ocm-typed.rkt +++ /dev/null @@ -1,331 +0,0 @@ -#lang typed/racket/base -(require (for-syntax racket/base racket/syntax)) -(require racket/list typed/sugar/debug typed/sugar/define racket/function racket/vector "logger-typed.rkt") -(define-logger ocm) - -(provide minima-idx-key minima-payload-key smawky? Entry->Value-Type Value-Type No-Value-Type Entry-Type Index-Type Matrix-Proc-Type OCM-Type make-ocm reduce reduce2 concave-minima (prefix-out ocm- (combine-out min-entry min-value min-index))) - -(define/typed (select-elements xs is) - ((Listof Any) (Listof Index-Type) -> (Listof Any)) - (map (λ([i : Index-Type]) ((inst list-ref Any) xs i)) is)) - -(define/typed (odd-elements xs) - ((Listof Any) -> (Listof Any)) - (select-elements xs (range 1 (length xs) 2))) - -(define/typed (vector-odd-elements xs) - ((Vectorof Any) -> (Vectorof Any)) - (for/vector ([i (in-range (vector-length xs))] #:when (odd? i)) - (vector-ref xs i))) - -(define/typed (even-elements xs) - ((Listof Any) -> (Listof Any)) - (select-elements xs (range 0 (length xs) 2))) - - -;; Wrapper for the matrix procedure -;; that automatically maintains a hash cache of previously-calculated values -;; because the minima operations tend to hit the same values. -;; Assuming here that (matrix i j) is invariant -;; and that the matrix function is more expensive than the cache lookup. - - -(define-syntax-rule (vector-append-item xs value) - ((inst vector-append Any) xs (vector value))) - -(define-syntax-rule (vector-append-entry xs value) - ((inst vector-append Entry-Type) xs (vector value))) - -(define-syntax-rule (vector-append-index xs value) - ((inst vector-append (U Index-Type No-Value-Type)) xs (vector value))) - - -(define/typed (vector-set vec idx val) - (All (a) ((Vectorof a) Integer a -> (Vectorof a))) - (vector-set! vec idx val) - vec) - -(define-syntax-rule (vector-cdr vec) - (vector-drop vec 1)) - -(define-syntax-rule (vector-empty? vec) - (= 0 (vector-length vec))) - - -(define (integers? x) (and (list? x) (andmap integer? x))) - -;; Reduce phase: make number of rows at most equal to number of cols -(define/typed (reduce row-indices col-indices matrix-proc entry->value) - ((Vectorof Index-Type) (Vectorof Index-Type) Matrix-Proc-Type Entry->Value-Type -> (Vectorof Index-Type)) - ;(vector? vector? procedure? procedure? -> vector?) - (log-ocm-debug "starting reduce phase with") - (log-ocm-debug "row-indices = ~a" row-indices) - (log-ocm-debug "col-indices = ~a" col-indices) - - (: process-stack ((Vectorof Index-Type) Index-Type -> (Vectorof Index-Type))) - (define (process-stack stack row-idx) - (log-ocm-debug "row stack = ~a" stack) - (let ([last-stack-idx (sub1 (vector-length stack))]) - (cond - [(and (>= (vector-length stack) 1) - (log-ocm-debug "comparing row values at column ~a" (vector-ref col-indices last-stack-idx)) - (log-ocm-debug "end of row stack (~a) value at column ~a = ~a" (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx) (entry->value (matrix-proc (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx)))) - (log-ocm-debug "challenger row (~a) value at column ~a = ~a" row-idx (vector-ref col-indices last-stack-idx) (entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx)))) - (> (entry->value (matrix-proc (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx))) - (entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx))))) - - (log-ocm-debug "challenger row (~a) wins with a new minimum ~a, so end of row stack (~a) is removed" row-idx (entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx))) (vector-ref stack last-stack-idx)) - (process-stack (vector-drop-right stack 1) row-idx)] - [else - (log-ocm-debug (if (< (vector-length stack) 1) - (format "row stack too short for challenge, pushing row ~a" row-idx) - (format "challenger row (~a) loses to end of row stack (~a), so ~a joins stack" row-idx (vector-ref stack last-stack-idx) row-idx))) - stack]))) - - (define reduced-row-indexes - (for/fold : (Vectorof Index-Type) ([stack (cast (vector) (Vectorof Index-Type))]) ([row-idx (in-vector row-indices)]) - (let ([stack (process-stack stack row-idx)]) - (if (= (vector-length stack) (vector-length col-indices)) - stack - ((inst vector-append Index-Type) stack (vector row-idx)))))) - (log-ocm-debug "finished reduce. row indexes = ~v" reduced-row-indexes) - reduced-row-indexes) - -(: reduce2 ((Vectorof Index-Type) (Vectorof Index-Type) Matrix-Proc-Type Entry->Value-Type -> (Vectorof Index-Type))) -(define (reduce2 row-indices col-indices matrix-proc entry->value) - (let find-survivors ([rows row-indices][survivors : (Listof Index-Type) empty]) - (cond - [(vector-empty? rows) ((inst list->vector Index-Type) (reverse survivors))] - [else - (define challenger-row (vector-ref rows 0)) - (cond - ;; no survivors yet, so push first row and keep going - [(empty? survivors) (find-survivors (vector-cdr rows) (cons challenger-row survivors))] - [else - (define index-of-last-survivor (sub1 (length survivors))) - (define col-head (vector-ref col-indices index-of-last-survivor)) - (define-syntax-rule (test-function r) (entry->value (matrix-proc r col-head))) - (cond - ;; this is the challenge: is the head cell of challenger a new minimum? - ;; use < not <=, so the recorded winner is the earliest row with the new minimum, not the latest row - ;; if yes, challenger wins. pop element from stack, and let challenger try again (= leave rows alone) - [(< (test-function challenger-row) (test-function (car survivors))) (find-survivors rows (cdr survivors))] - - ;; if not, challenger lost. - ;; If we're in the last column, ignore the loser by recurring on the same values - [(= col-head (vector-last col-indices)) (find-survivors (vector-cdr rows) survivors)] - - ;; otherwise challenger lost and we're not in last column, - ;; so add challenger to survivor stack - [else (find-survivors (vector-cdr rows) (cons challenger-row survivors))])])]))) - -;; define a special type so it can be reused in `interpolate` -;; it is (cons value row-idx) - -(define minima-idx-key 'row-idx) -(define minima-payload-key 'entry) - -(define-type Make-Minimum-Input (Pair Any Index-Type)) -(define/typed (make-minimum value-rowidx-pair) - (Make-Minimum-Input -> (HashTable Any Any)) - (define ht ((inst make-hash Any Any))) - (! ht minima-payload-key (car value-rowidx-pair)) - (! ht minima-idx-key (cdr value-rowidx-pair)) - ht) - - -;; Interpolate phase: in the minima hash, add results for even rows - -(define-syntax-rule (vector-last v) - (vector-ref v (sub1 (vector-length v)))) - -(define/typed (interpolate minima row-indices col-indices matrix-proc entry->value) - ((HashTable Any Any) (Vectorof Index-Type) (Vectorof Index-Type) Matrix-Proc-Type Entry->Value-Type -> (HashTable Any Any)) - ;(hash? vector? vector? procedure? procedure? -> hash?) - (for ([col-idx (in-range 0 (vector-length col-indices) 2)]) ;; even-col-indices - (define col (vector-ref col-indices col-idx)) - (define idx-of-last-row - (cast (if (= col-idx (sub1 (vector-length col-indices))) - (vector-last row-indices) - (hash-ref (cast (hash-ref minima (vector-ref col-indices (add1 col-idx))) HashTableTop) minima-idx-key)) Index-Type)) - - (define smallest-value-entry - ((inst vector-argmin Make-Minimum-Input) (λ(x) (entry->value (car x))) - (for/vector : (Vectorof Make-Minimum-Input) - ([row-idx (in-list ((inst dropf-right Index-Type) (vector->list row-indices) (λ(x) (not (= x idx-of-last-row)))))]) - (cons (matrix-proc row-idx col) row-idx)))) - - (! minima col (make-minimum smallest-value-entry))) - minima) - -(define/typed (interpolate2 minima row-indices col-indices matrix-proc entry->value) - ((HashTable Any Any) (Vectorof Index-Type) (Vectorof Index-Type) Matrix-Proc-Type Entry->Value-Type -> (HashTable Any Any)) - (define idx-of-last-col (sub1 (vector-length col-indices))) - (define (smallest-value-entry [col : Index-Type] [idx-of-last-row : Index-Type]) - ((inst argmin Make-Minimum-Input) (λ(x) (entry->value (car x))) - (for/list ([row-idx (stop-after (in-vector row-indices) (λ(x) (= idx-of-last-row x)))]) - (cons (matrix-proc row-idx col) row-idx)))) - - (for ([([col : Index-Type] col-idx) (in-indexed col-indices)] #:when (even? col-idx)) - (define idx-of-last-row (cast (if (= col-idx idx-of-last-col) - (vector-last row-indices) - (hash-ref (cast (hash-ref minima (vector-ref col-indices (add1 col-idx))) HashTableTop) minima-idx-key)) Index-Type)) - (! minima col (make-minimum (smallest-value-entry col idx-of-last-row)))) - minima) - - -;; The return value `minima` is a hash: -;; the keys are col-indices (integers) -;; the values are pairs of (value row-index). -(define/typed (concave-minima row-indices col-indices matrix-proc entry->value) - ((Vectorof Index-Type) (Vectorof Index-Type) Matrix-Proc-Type Entry->Value-Type -> HashTableTop) - ;((vector?) ((or/c #f vector?) procedure? procedure?) . ->* . hash?) - (define reduce-proc reduce2) - (define interpolate-proc interpolate2) - (if (= 0 (vector-length col-indices)) - (make-hash) - (let ([row-indices (reduce-proc row-indices col-indices matrix-proc entry->value)]) - (define odd-column-minima (concave-minima row-indices (cast (vector-odd-elements (cast col-indices (Vectorof Any))) (Vectorof Index-Type)) matrix-proc entry->value)) - (interpolate-proc (cast odd-column-minima (HashTable Any Any)) row-indices col-indices matrix-proc entry->value)))) - - -(define no-value 'none) - -(define-syntax-rule (@ hashtable key) - (hash-ref hashtable key)) - -(define-syntax-rule (! hashtable key value) - (hash-set! hashtable key value)) - -(define-type Index-Type Nonnegative-Integer) -(define-type Entry-Type Any) -(define-type Value-Type Float) -(define-type No-Value-Type Symbol) -(define-type Finished-Value-Type Index-Type) -(define-type Matrix-Proc-Type (Index-Type Index-Type -> Entry-Type)) -(define-type Entry->Value-Type (Entry-Type -> Value-Type)) - -(struct $ocm ([min-entrys : (Vectorof Entry-Type)] [min-row-indices : (Vectorof (U Index-Type No-Value-Type))] [finished : Finished-Value-Type] [matrix-proc : Matrix-Proc-Type] [entry->value : Entry->Value-Type] [base : Index-Type] [tentative : Index-Type]) #:transparent #:mutable) - -(define-type OCM-Type $ocm) - -(define/typed (make-ocm matrix-proc entry->value [initial-entry 0.0]) - ((Matrix-Proc-Type Entry->Value-Type) (Entry-Type) . ->* . OCM-Type) - (log-ocm-debug "making new ocm") - ($ocm (vector initial-entry) (vector no-value) 0 matrix-proc entry->value 0 0)) - -;; Return min { Matrix(i,j) | i < j }. -(define/typed (min-entry ocm j) - (OCM-Type Index-Type -> Entry-Type) - (if (< (cast ($ocm-finished ocm) Real) j) - (begin (advance! ocm) (min-entry ocm j)) - (vector-ref ($ocm-min-entrys ocm) j))) - -;; same as min-entry, but converts to raw value -(define/typed (min-value ocm j) - (OCM-Type Index-Type -> Value-Type) - (($ocm-entry->value ocm) (min-entry ocm j))) - -;; Return argmin { Matrix(i,j) | i < j }. -(define/typed (min-index ocm j) - (OCM-Type Index-Type -> (U Index-Type No-Value-Type)) - (if (< (cast ($ocm-finished ocm) Real) j) - (begin (advance! ocm) (min-index ocm j)) - ((inst vector-ref (U Index-Type No-Value-Type)) ($ocm-min-row-indices ocm) j))) - -;; Finish another value,index pair. -(define/typed (advance! ocm) - (OCM-Type -> Void) - (define next (add1 ($ocm-finished ocm))) - (log-ocm-debug "advance! ocm to next = ~a" (add1 ($ocm-finished ocm))) - (cond - ;; First case: we have already advanced past the previous tentative - ;; value. We make a new tentative value by applying ConcaveMinima - ;; to the largest square submatrix that fits under the base. - [(> next ($ocm-tentative ocm)) - (log-ocm-debug "advance: first case because next (~a) > tentative (~a)" next ($ocm-tentative ocm)) - (define rows : (Vectorof Index-Type) (list->vector (range ($ocm-base ocm) next))) - (set-$ocm-tentative! ocm (+ ($ocm-finished ocm) (vector-length rows))) - (define cols : (Vectorof Index-Type) (list->vector (range next (add1 ($ocm-tentative ocm))))) - (define minima (concave-minima rows cols ($ocm-matrix-proc ocm) ($ocm-entry->value ocm))) - - (for ([col (in-vector cols)]) - (cond - [(>= col (vector-length ($ocm-min-entrys ocm))) - (set-$ocm-min-entrys! ocm (vector-append-entry ($ocm-min-entrys ocm) (@ (cast (@ minima col) (HashTable Symbol Entry-Type)) minima-payload-key))) - (set-$ocm-min-row-indices! ocm (vector-append-index ($ocm-min-row-indices ocm) (@ (cast (@ minima col) (HashTable Symbol Index-Type)) minima-idx-key)))] - [(< (($ocm-entry->value ocm) (@ (cast (@ minima col) HashTableTop) minima-payload-key)) (($ocm-entry->value ocm) (vector-ref ($ocm-min-entrys ocm) col))) - (set-$ocm-min-entrys! ocm ((inst vector-set Entry-Type) ($ocm-min-entrys ocm) col (cast (@ (cast (@ minima col) HashTableTop) minima-payload-key) Entry-Type))) - (set-$ocm-min-row-indices! ocm ((inst vector-set (U Index-Type No-Value-Type)) ($ocm-min-row-indices ocm) col (cast (@ (cast (@ minima col) HashTableTop) minima-idx-key) Index-Type)))])) - - (set-$ocm-finished! ocm next)] - - [else - ;; Second case: the new column minimum is on the diagonal. - ;; All subsequent ones will be at least as low, - ;; so we can clear out all our work from higher rows. - ;; As in the fourth case, the loss of tentative is - ;; amortized against the increase in base. - (define diag (($ocm-matrix-proc ocm) (sub1 next) next)) - (cond - [(< (($ocm-entry->value ocm) diag) (($ocm-entry->value ocm) (vector-ref ($ocm-min-entrys ocm) next))) - (log-ocm-debug "advance: second case because column minimum is on the diagonal") - (set-$ocm-min-entrys! ocm (vector-set ($ocm-min-entrys ocm) next diag)) - (set-$ocm-min-row-indices! ocm (vector-set ($ocm-min-row-indices ocm) next (sub1 next))) - (set-$ocm-base! ocm (sub1 next)) - (set-$ocm-tentative! ocm next) - (set-$ocm-finished! ocm next)] - - ;; Third case: row i-1 does not supply a column minimum in - ;; any column up to tentative. We simply advance finished - ;; while maintaining the invariant. - [(>= (($ocm-entry->value ocm) (($ocm-matrix-proc ocm) (sub1 next) ($ocm-tentative ocm))) - (($ocm-entry->value ocm) (vector-ref ($ocm-min-entrys ocm) ($ocm-tentative ocm)))) - (log-ocm-debug "advance: third case because row i-1 does not suppply a column minimum") - (set-$ocm-finished! ocm next)] - - ;; Fourth and final case: a new column minimum at self._tentative. - ;; This allows us to make progress by incorporating rows - ;; prior to finished into the base. The base invariant holds - ;; because these rows cannot supply any later column minima. - ;; The work done when we last advanced tentative (and undone by - ;; this step) can be amortized against the increase in base. - [else - (log-ocm-debug "advance: fourth case because new column minimum") - (set-$ocm-base! ocm (sub1 next)) - (set-$ocm-tentative! ocm next) - (set-$ocm-finished! ocm next)])])) - -(define/typed (print ocm) - (OCM-Type -> Void) - (displayln ($ocm-min-entrys ocm)) - (displayln ($ocm-min-row-indices ocm))) - -(define/typed (smawky? m) - ((Listof (Listof Real)) -> Boolean) - (: position-of-minimum ((Listof Real) -> Index-Type)) - (define (position-of-minimum xs) - ;; put each element together with its list index - (let ([xs : (Listof (Pairof Index-Type Real)) (map (inst cons Index-Type Real) (range (length xs)) xs)]) - ;; find the first one with the min value, and grab the list index - (car ((inst argmin (Pairof Index-Type Real)) cdr (filter (λ([x : (Pairof Index-Type Real)]) (not (negative? (cdr x)))) xs))))) - ;; tests if penalty matrix is monotone for non-negative values. - (define increasing-minima? (apply <= (cast (map position-of-minimum m) (List* Real Real (Listof Real))))) - - (define monotone? : Boolean - (for/and ([ridx (in-range 1 (length m))]) - (for/and : Boolean ([cidx (in-range (sub1 (length (car m))))]) - (cast (let* ([prev-row : (Listof Real) ((inst list-ref (Listof Real)) m (sub1 ridx))] - [row : (Listof Real) (list-ref m ridx)] - [a : Real (list-ref prev-row cidx)] - [b : Real (list-ref prev-row (add1 cidx))] - [c : Real (list-ref row cidx)] - [d : Real (list-ref row (add1 cidx))]) - (if (andmap (λ([x : Real]) (not (negative? x))) (list a b c d)) ;; smawk disregards negative values - (cond - [(< c d) (if (< a b) #t (error (format "Submatrix ~a not monotone in ~a" (list (list a b) (list c d)) m)))] - [(= c d) (if (<= a b) #t (error (format "Submatrix ~a not monotone in ~a" (list (list a b) (list c d)) m)))] - [else #t]) - #t)) Boolean)))) - - (and increasing-minima? monotone?)) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt deleted file mode 100644 index 8a9d0ecc..00000000 --- a/quad/quads-typed.rkt +++ /dev/null @@ -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) diff --git a/quad/quads.rkt b/quad/quads.rkt index 6eb06564..9cdb0d7b 100644 --- a/quad/quads.rkt +++ b/quad/quads.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax racket/string) racket/string racket/contract racket/serialize sugar/list racket/format racket/list sugar/debug sugar/coerce racket/bool racket/function sugar/string) +(require (for-syntax racket/base racket/syntax racket/string) racket/string racket/contract racket/serialize sugar/list racket/format racket/list sugar/debug sugar/coerce racket/bool racket/function sugar/unstable/string) (require "world.rkt") (provide (all-defined-out)) diff --git a/quad/quick-sample-typed.rkt b/quad/quick-sample-typed.rkt deleted file mode 100644 index 7d2adc4d..00000000 --- a/quad/quick-sample-typed.rkt +++ /dev/null @@ -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") \ No newline at end of file diff --git a/quad/quick-test.rkt b/quad/quick-test.rkt index 68aaa057..1aa0b5f5 100644 --- a/quad/quick-test.rkt +++ b/quad/quick-test.rkt @@ -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) \ No newline at end of file + (time (send (new pdf-renderer%) render-to-file to "quick-test-untyped.pdf"))) \ No newline at end of file diff --git a/quad/render-typed.rkt b/quad/render-typed.rkt deleted file mode 100644 index 2d53f254..00000000 --- a/quad/render-typed.rkt +++ /dev/null @@ -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)) - - - )) diff --git a/quad/samples-typed.rkt b/quad/samples-typed.rkt deleted file mode 100644 index 96af98c6..00000000 --- a/quad/samples-typed.rkt +++ /dev/null @@ -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") \ No newline at end of file diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt deleted file mode 100644 index b6bd172c..00000000 --- a/quad/tests-typed.rkt +++ /dev/null @@ -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) \ No newline at end of file diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt deleted file mode 100644 index 6fcddc71..00000000 --- a/quad/utils-typed.rkt +++ /dev/null @@ -1,283 +0,0 @@ -#lang typed/racket/base -(require/typed hyphenate [hyphenate (String #:min-length Nonnegative-Integer #:min-left-length Nonnegative-Integer #:min-right-length Nonnegative-Integer -> String)]) -(require (for-syntax racket/syntax racket/base) racket/string racket/list typed/sugar/debug typed/sugar/define racket/bool racket/function math/flonum) -(require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt" "core-types.rkt") - -(define/typed+provide (quad-map proc q) - ((QuadListItem -> QuadListItem) Quad -> Quad) - (quad (quad-name q) (quad-attrs q) (map proc (quad-list q)))) - - -;; predicate for use below -(define/typed (list-of-mergeable-attrs? xs) - (Any -> Boolean) - (and (list? xs) (andmap (λ(x) (or (quad? x) (quad-attrs? x) (HashableList? x))) xs))) - -;; faster than (listof pair? -(define/typed (pairs? x) - (Any -> Boolean) - (and (list? x) (andmap pair? x))) - -;; push together multiple attr sources into one list of pairs. -;; mostly a helper function for the two attr functions below. -;; does not resolve duplicates (see merge-attrs for that) -(define/typed+provide (join-attrs quads-or-attrs-or-lists) - ((Listof JoinableType) -> QuadAttrs) - (append-map (λ([x : JoinableType]) - (cond - [(quad? x) (quad-attrs x)] - [(quad-attrs? x) x] - [else (make-quadattrs x)])) quads-or-attrs-or-lists)) - - -;; merge uses join-attrs to concatenate attributes, -;; but then resolves duplicates, with later ones overriding earlier. -(define/typed+provide (merge-attrs . quads-or-attrs-or-lists) - (JoinableType * -> QuadAttrs) - (define all-attrs (join-attrs quads-or-attrs-or-lists)) - (hash->list (make-hash all-attrs))) - -;; flatten merges attributes, but applies special logic suitable to flattening -;; for instance, resolving x and y coordinates. -(define-type QuadAttrFloatPair (Pairof QuadAttrKey Float)) - -(define/typed+provide (flatten-attrs . joinable-items) - (JoinableType * -> QuadAttrs) - (define all-attrs (join-attrs joinable-items)) - (define-values (x-attrs y-attrs other-attrs-reversed) - (for/fold ([xas : (Listof QuadAttrFloatPair) null] - [yas : (Listof QuadAttrFloatPair) null] - [oas : (Listof QuadAttr) null]) - ([attr (in-list all-attrs)]) - (cond - [(and (equal? (car attr) world:x-position-key) (flonum? (cdr attr))) (values (cons attr xas) yas oas)] - [(and (equal? (car attr) world:y-position-key) (flonum? (cdr attr))) (values xas (cons attr yas) oas)] - [else (values xas yas (cons attr oas))]))) - (: make-cartesian-attr (QuadAttrKey (Listof QuadAttrFloatPair) -> (Listof QuadAttrFloatPair))) - (define (make-cartesian-attr key attrs) - (if (empty? attrs) - empty - (list (cons (ann key QuadAttrKey) (foldl fl+ 0.0 ((inst map Float QuadAttrFloatPair) cdr attrs)))))) - (define x-attr (make-cartesian-attr world:x-position-key x-attrs)) - (define y-attr (make-cartesian-attr world:y-position-key y-attrs)) - ;; use hash to resolve duplicate entries by giving priority to later ones - ;; then stuff x & y at the front (they will not have duplicates because they were already resolved) - (append x-attr y-attr (hash->list ((inst make-hash QuadAttrKey QuadAttrValue) (reverse other-attrs-reversed))))) - -;; ordinary flatten won't work because a quad is a bare list, -;; and flatten will go too far. -;; this version adds a check for quadness to the flattener. -(define/typed+provide (flatten-quadtree quad-tree) - ((Treeof Quad) -> (Listof Quad)) - (let loop ([sexp quad-tree][acc : (Listof Quad) null]) - (cond [(null? sexp) acc] - [(quad? sexp) (cons sexp acc)] - [else (loop (car sexp) (loop (cdr sexp) acc))]))) - -;; starting with a single nested quad, -;; pushes attributes down from parent quads to children, -;; resulting in a flat list of quads. -(define/typed+provide (flatten-quad q) - (Quad -> (Listof Quad)) - (flatten-quadtree - (let loop : (Treeof Quad) - ([x : QuadListItem q][parent : Quad (quad 'null '() '())]) - (cond - [(quad? x) - (let ([x-with-parent-attrs (quad (quad-name x) - (flatten-attrs parent x) ; child positioned last so it overrides parent attributes - (quad-list x))]) - - (if (empty? (quad-list x)) - x-with-parent-attrs ; no subelements, so stop here - ((inst map (Treeof Quad) QuadListItem) (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements - [else ;; it's a string - (quad (quad-name parent) (quad-attrs parent) (list x))])))) - -;; 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 -(define/typed+provide (split-quad q) - (Quad -> (Listof Quad)) - (: do-explode ((QuadListItem) (Quad) . ->* . (Treeof Quad))) - (define (do-explode x [parent (box)]) - (cond - [(quad? x) - (if (empty? (quad-list x)) - x ; no subelements, so stop here - ((inst map (Treeof Quad) QuadListItem) (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded - [else ;; it's a string - ((inst map (Treeof Quad) QuadListItem) (λ(xc) (quad world:split-quad-key (quad-attrs parent) (list xc))) (regexp-match* #px"." x))])) - (flatten-quadtree (map do-explode (flatten-quad q)))) - - -;; merge chars into words (and boxes), leave the rest -;; 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 -(define/typed+provide (join-quads qs-in) - ((Listof Quad) -> (Listof Quad)) - (let ([make-matcher (λ ([base-q : Quad]) - (λ([q : Quad]) - (and (member (quad-name q) world:mergeable-quad-types) - (not (whitespace/nbsp? q)) - ;; if key doesn't exist, it is compared against the default value. - ;; this way, a nonexistent value will test true against a default value. - (andmap (λ([key : QuadAttrKey] [default : QuadAttrValue]) (equal? (quad-attr-ref base-q key default) (quad-attr-ref q key default))) - (ann (list world:font-name-key - world:font-size-key - world:font-weight-key - world:font-style-key) (Listof QuadAttrKey)) - (ann (list (world:font-name-default) - (world:font-size-default) - (world:font-weight-default) - (world:font-style-default)) (Listof QuadAttrValue))))))]) - (let loop ([qs : (Listof Quad) qs-in][acc : (Listof Quad) null]) - (if (null? qs) - (reverse acc) - (let* ([base-q (first qs)] - [mergeable-and-matches-base? (make-matcher base-q)]) ; make a new predicate function for this quad - (cond - [(mergeable-and-matches-base? base-q) - ;; take as many quads that match, using the predicate function - (define-values (matching-qs other-qs) (splitf-at (cdr qs) mergeable-and-matches-base?)) - (define new-word-strings (append-map quad-list (cons base-q matching-qs))) - (define new-word - (if (andmap string? new-word-strings) - (word (quad-attrs base-q) (string-append* new-word-strings)) - (error 'join-quads "expected string"))) - (loop other-qs (cons new-word acc))] - ;; otherwise move on to the next in line - [else (loop (cdr qs) (cons base-q acc))])))))) - - -;; propagate x and y adjustments throughout the tree, -;; using parent x and y to adjust children, and so on. -(define/typed+provide (compute-absolute-positions qli) - (Quad -> Quad) - (define result - (let loop : QuadListItem ([qli : QuadListItem qli][parent-x : Float 0.0][parent-y : Float 0.0]) - (cond - [(quad? qli) - (define adjusted-x (round-float (+ (assert (quad-attr-ref qli world:x-position-key 0.0) flonum?) parent-x))) - (define adjusted-y (round-float (+ (assert (quad-attr-ref qli world:y-position-key 0.0) flonum?) parent-y))) - (quad (quad-name qli) (merge-attrs qli (list world:x-position-key adjusted-x world:y-position-key adjusted-y)) (map (λ([qlii : QuadListItem]) (loop qlii adjusted-x adjusted-y)) (quad-list qli)))] - [else ;; it's a string - qli]))) - (if (string? result) - (error 'compute-absolute-positions "got string as result: ~v" result) - result)) - - -;; these helper functions isolate the generic functionality. -;; problem with quad-attr-set and other Quad->Quad functions -;; is that they strip out type. -;; whereas these "surgical" alternatives can be used when preserving type is essential -(define/typed+provide (attr-change qas kvs) - (QuadAttrs HashableList -> QuadAttrs) - (merge-attrs qas kvs)) - -(define/typed+provide (attr-delete qas . ks) - (QuadAttrs QuadAttrKey * -> QuadAttrs) - (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) qas)) - - -;; functionally update a quad attr. Similar to hash-set -(define/typed+provide (quad-attr-set q k v) - (case-> - (GroupQuad QuadAttrKey QuadAttrValue -> GroupQuad) - (Quad QuadAttrKey QuadAttrValue -> Quad)) - (quad-attr-set* q (list k v))) - - -;; functionally update multiple quad attrs. Similar to hash-set* -(define/typed+provide (quad-attr-set* q kvs) - (case-> - (GroupQuad HashableList -> GroupQuad) - (Quad HashableList -> Quad)) - (quad (quad-name q) (attr-change (quad-attrs q) kvs) (quad-list q))) - - -;; functionally remove multiple quad attrs. Similar to hash-remove* -(define/typed+provide (quad-attr-remove* q . ks) - (case-> - (GroupQuad QuadAttrKey * -> GroupQuad) - (Quad QuadAttrKey * -> Quad)) - (if (not (empty? (quad-attrs q))) - ;; test all ks as a set so that iteration through attrs only happens once - (quad (quad-name q) (apply attr-delete (quad-attrs q) ks) (quad-list q)) - q)) - - -;; functionally remove a quad attr. Similar to hash-remove -(provide quad-attr-remove) -(define quad-attr-remove quad-attr-remove*) - - -;; the last char of a quad -(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 - (let ([result((inst car QuadListItem QuadListItem) (quad-list (last split-qs)))]) - (if (quad? result) - (error 'quad-last-char "last element is not a string: ~v" result) - result)))) - -;; the first char of a quad -(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 - (let ([result((inst car QuadListItem QuadListItem) (quad-list (first split-qs)))]) - (if (quad? result) - (error 'quad-first-char "first element is not a string: ~v" result) - 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 -> Float) - (assert (quad-attr-ref q world:height-key 0.0) flonum?)) - -;; use heights to compute vertical positions -(define/typed+provide (add-vert-positions starting-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))]) - (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 -(define/typed+provide (hyphenate-quad x) - (QuadListItem -> QuadListItem) - (cond - [(quad? x) (quad-map hyphenate-quad x)] - [(string? x) (hyphenate x - #:min-length 6 - #:min-left-length 3 - #:min-right-length 3)] - [else x])) - -;; just because it comes up a lot -(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)))) - -;; like cons, but joins a list to an atom -(provide snoc) -(define-syntax-rule (snoc xs x) - (append xs (list x))) diff --git a/quad/world-typed.rkt b/quad/world-typed.rkt deleted file mode 100644 index 30ecbb21..00000000 --- a/quad/world-typed.rkt +++ /dev/null @@ -1,98 +0,0 @@ -#lang typed/racket/base -(require (for-syntax typed/racket/base racket/syntax) "core-types.rkt") -(provide (prefix-out world: (all-defined-out))) - - -(define-syntax-rule (define-parameter-typed name val type) - (define name : (Parameterof type) (make-parameter val))) - -(define-syntax (define-key-and-parameter stx) - (syntax-case stx () - [(_ name keyname val type) - (with-syntax ([name-key (format-id #'name "~a-key" #'name)] - [name-default (format-id #'name "~a-default" #'name)]) - #'(begin - (define name-key : QuadAttrKey keyname) - (define-parameter-typed name-default val type)))])) - -(define-key-and-parameter measure 'measure 300.0 QuadAttrValue) - - -(define-key-and-parameter font-size 'size 13.0 Font-Size) -(define-key-and-parameter font-name 'font "Triplicate T4" Font-Name) -(define-key-and-parameter font-weight 'weight 'normal Font-Weight) -(define-key-and-parameter font-style 'style 'normal Font-Style) -(define-key-and-parameter font-color 'color "black" String) -(define-key-and-parameter font-background 'background "none" String) - -(define-key-and-parameter column-count 'column-count 2 Index) -(define-key-and-parameter column-gutter 'column-gutter 30.0 Float) - - -(define max-quality 100) -(define adaptive-quality 50) -(define draft-quality 20) -(define-key-and-parameter quality 'quality max-quality Index) - - -(define-key-and-parameter horiz-alignment 'x-align 'left QuadAttrKey) -(define-key-and-parameter leading 'leading (floor (* (font-size-default) 1.4)) Float) - - -(define-key-and-parameter paper-width 'paper-width (* 8.5 72) Float) -(define-key-and-parameter paper-height 'paper-height (* 11.0 72) Float) - -(define line-looseness-key 'looseness) -(define width-key 'width) -(define horiz-alignment-last-line-key 'x-align-last-line) -(define word-break-key 'word-break) -(define no-break-key 'nb) -(define before-break-key 'bb) -(define ascent-key 'ascent) -(define height-key 'height) -(define unbreakable-key 'no-break) - -(define split-quad-key 'word) - - -(define line-index-key 'line-idx) -(define total-lines-key 'lines) -(define page-index-key 'page-idx) -(define column-index-key 'column-idx) - -(define x-position-key 'x) -(define y-position-key 'y) - -(define page-key 'page) - -(define soft-hyphen #\u00AD) -(define hyphens-and-dashes (list "-" "–" "—" (format "~a" soft-hyphen))) -(define spaces '(" ")) -(define empty-string '"") - -(define mergeable-quad-types '(char run word)) - -(define default-word-break-list : (Parameterof JoinableType) (make-parameter '(nb "" bb "-"))) - -(define-parameter-typed optical-overhang 0.8 Float) - -(define line-looseness-tolerance 0.05) ; 0.04 seems to be the magic point that avoids a lot of hyphenation -(define hyphen-limit 1) ; does not work with first-fit wrapping -(define minimum-last-line-chars 5) -(define allow-hyphenated-last-word-in-paragraph #t) -(define allowed-overfull-ratio 1.015) -(define last-line-can-be-short #t) -(define use-optical-kerns? #t) -(define use-hyphenation? #t) - -(define new-line-penalty 5000) -(define hyphen-penalty 5000) - -(define hanging-chars (regexp-match* #rx"." ".-,‘’“”'\"()[]{}:;")) - -(define minimum-lines-per-column 4) -(define min-first-lines 2) -(define min-last-lines 2) -(define default-lines-per-column 36) - -(define-parameter-typed logging-level 'debug Log-Level) ;; usually 'debug for dev. change to 'info for less \ No newline at end of file diff --git a/quad/wrap-typed-test.rkt b/quad/wrap-typed-test.rkt deleted file mode 100644 index 0565ee7e..00000000 --- a/quad/wrap-typed-test.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang typed/racket -(require typed/rackunit) -(require "wrap-typed.rkt" "utils-typed.rkt" "quads-typed.rkt") - - -(define megs (split-quad (block '(size 10 font "Courier") "Meg is an ally."))) -(define measure 40.0) -(check-equal? (map quad->string (wrap-first megs measure)) '("Meg is" "an" "ally.")) -(check-equal? (map quad->string (wrap-best megs measure)) '("Meg" "is an" "ally.")) - - -(define eqs (split-quad (block '(x-align center font "Equity Text B" size 10) "Foo-d" (word '(size 13) "og ") "and " (box) " Zu" (word-break '(nb "c" bb "k-")) "kerman's. Instead of a circle, the result is a picture of the code that, if it were used as an expression, would produce a circle. In other words, code is not a function, but instead a new syntactic form for creating pictures; the bit between the opening parenthesis with code is not an expression, but instead manipulated by the code syntactic form. This helps explain what we meant in the previous section when we said that racket provides require and the function-calling syntax. Libraries are not restricted to exporting values, such as functions; they can also define new syntactic forms. In this sense, Racket isn’t exactly a language at all; it’s more of an idea for how to structure a language so that you can extend it or create entirely " (word '(font "Courier" size 5) "lang.")))) - (set! measure 200.0) - -;; these wrap results generated from untyped wrap.rkt -;; so a winning test is where typed and untyped agree -;; todo: make it easy to check results from both directions. -;; not as simple as importing untyped variants with a prefix. -;; the "quad" data structure itself is different. -;; so it would need macrology. - -(check-equal? (map quad->string (wrap-first eqs measure)) '("Foo-dog and Zuckerman's. Instead of a circle," - "the result is a picture of the code that, if it were" - "used as an expression, would produce a circle. In" - "other words, code is not a function, but instead a" - "new syntactic form for creating pictures; the bit" - "between the opening parenthesis with code is not" - "an expression, but instead manipulated by the" - "code syntactic form. This helps explain what we" - "meant in the previous section when we said that" - "racket provides require and the function-calling" - "syntax. Libraries are not restricted to exporting" - "values, such as functions; they can also define new" - "syntactic forms. In this sense, Racket isn’t exactly" - "a language at all; it’s more of an idea for how to" - "structure a language so that you can extend it or" - "create entirely lang.")) -(check-equal? (map quad->string (wrap-best eqs measure)) '("Foo-dog and Zuckerman's. Instead of a circle," - "the result is a picture of the code that, if it were" - "used as an expression, would produce a circle. In" - "other words, code is not a function, but instead" - "a new syntactic form for creating pictures; the" - "bit between the opening parenthesis with code is" - "not an expression, but instead manipulated by the" - "code syntactic form. This helps explain what we" - "meant in the previous section when we said that" - "racket provides require and the function-calling" - "syntax. Libraries are not restricted to exporting" - "values, such as functions; they can also define new" - "syntactic forms. In this sense, Racket isn’t exactly" - "a language at all; it’s more of an idea for how to" - "structure a language so that you can extend it or" - "create entirely lang.")) \ No newline at end of file diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt deleted file mode 100644 index 3a766ae4..00000000 --- a/quad/wrap-typed.rkt +++ /dev/null @@ -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))) - diff --git a/quad/wrap.rkt b/quad/wrap.rkt index 5f7ba24e..17209cc8 100644 --- a/quad/wrap.rkt +++ b/quad/wrap.rkt @@ -189,6 +189,11 @@ [else exploded-line-quads])) +(define-syntax (when/splice stx) + (syntax-case stx () + [(_ test body) + #'(if test (list body) '())])) + ;; 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.