From c0ed7b08a17f65c671cf8bb10cbd423557c258e4 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 28 Jan 2015 23:39:57 -0800 Subject: [PATCH] still utils --- quad/quads-typed.rkt | 1 - quad/utils-typed.rkt | 257 ++----------------------------------------- 2 files changed, 9 insertions(+), 249 deletions(-) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index b6d3675c..06c6ab8f 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -7,7 +7,6 @@ (require sugar/debug) (provide (all-defined-out)) -;; struct implementation (: hashable-list? (Any . -> . Boolean)) (define (hashable-list? x) (and (list? x) (even? (length x)))) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 94212d53..59e8e802 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -1,267 +1,28 @@ #lang typed/racket/base -(require sugar/list sugar/define) -(require (for-syntax racket/syntax racket/base) racket/string racket/contract racket/list sugar/debug racket/bool hyphenate racket/function math/flonum) +(require sugar/list) +(require (for-syntax racket/syntax racket/base) racket/string racket/list sugar/debug racket/bool hyphenate racket/function math/flonum) (require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt") ;; predicate for use below +(: list-of-mergeable-attrs? (Any . -> . Boolean)) (define (list-of-mergeable-attrs? xs) (and (list? xs) (andmap (λ(x) (or (quad? x) (quad-attrs? x) (hashable-list? x))) xs))) ;; faster than (listof pair?) +(: pairs? (Any . -> . Boolean)) (define (pairs? x) (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. -(define+provide/contract (join-attrs quads-or-attrs-or-lists) - (list-of-mergeable-attrs? . -> . pairs?) +(: join-attrs ((Listof (U Quad QuadAttrs)) . -> . QuadAttrs)) +(define (join-attrs quads-or-attrs-or-lists) +; (list-of-mergeable-attrs? . -> . pairs?) (append-map hash->list (filter-not false? (map (λ(x) (cond [(quad? x) (quad-attrs x)] [(quad-attrs? x) x] - [(hashable-list? x) (apply hash x)] + [(hashable-list? x) (quadattrs x)] [else #f])) quads-or-attrs-or-lists)))) - -;; merge concatenates attributes, with later ones overriding earlier. -;; most of the work is done by join-attrs. -(define+provide/contract (merge-attrs . quads-or-attrs-or-lists) - (() #:rest list-of-mergeable-attrs? . ->* . quad-attrs?) - (define all-attrs (join-attrs quads-or-attrs-or-lists)) - (apply hash (flatten all-attrs))) - -;; functionally update a quad attr. Similar to hash-set -(define+provide/contract (quad-attr-set q k v) - (quad? symbol? any/c . -> . quad?) - (quad (quad-name q) (merge-attrs (quad-attrs q) (list k v)) (quad-list q))) - - -;; functionally update multiple quad attrs. Similar to hash-set* -(define+provide/contract (quad-attr-set* q . kvs) - ((quad?) #:rest hashable-list? . ->* . quad?) - (for/fold ([current-q q])([kv-list (in-list (slice-at kvs 2))]) - (apply quad-attr-set current-q kv-list))) - -;; functionally remove a quad attr. Similar to hash-remove -(define+provide/contract (quad-attr-remove q k) - (quad? symbol? . -> . quad?) - (if (quad-attrs q) - (quad (quad-name q) (hash-remove (quad-attrs q) k) (quad-list q)) - q)) - -;; functionally remove multiple quad attrs. Similar to hash-remove -(define+provide/contract (quad-attr-remove* q . ks) - ((quad?) #:rest (λ(ks) (and (list? ks) (andmap symbol? ks))) . ->* . quad?) - (for/fold ([current-q q])([k (in-list ks)]) - (quad-attr-remove current-q k))) - -(define+provide/contract (quad-map proc q) - (procedure? quad? . -> . quad?) - (quad (quad-name q) (quad-attrs q) (map proc (quad-list q)))) - -;; flatten merges attributes, but applies special logic suitable to flattening -;; for instance, resolving x and y coordinates. -(define+provide/contract (flatten-attrs . quads-or-attrs-or-falses) - (() #:rest (listof (or/c quad? quad-attrs?)) . ->* . quad-attrs?) - (define all-attrs (join-attrs quads-or-attrs-or-falses)) - (define-values (x-attrs y-attrs other-attrs-reversed) - (for/fold ([xas null][yas null][oas null])([attr (in-list all-attrs)]) - (cond - [(equal? (car attr) world:x-position-key) (values (cons attr xas) yas oas)] - [(equal? (car attr) world:y-position-key) (values xas (cons attr yas) oas)] - [else (values xas yas (cons attr oas))]))) - (define (make-cartesian-attr key attrs) (if (empty? attrs) empty (cons key (apply + (map cdr attrs))))) - (define-values (x-attr y-attr) (apply values (map make-cartesian-attr (list world:x-position-key world:y-position-key) (list x-attrs y-attrs)))) - (apply hash (flatten (list* x-attr y-attr (reverse other-attrs-reversed))))) - - -;; pushes attributes down from parent quads to children, -;; resulting in a flat list of quads. -;; input is often large, so macro allows us to avoid allocation -(provide flatten-quad) -(define-syntax-rule (flatten-quad q) - ; (quad? . -> . quads?) - (flatten - (let loop ([x q][parent #f]) - (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 - (map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements - [(string? x) (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+provide (split-quad q) - ;(quad? . -> . quads?) - (letrec ([do-explode (λ(x [parent #f]) - (cond - [(quad? x) - (if (empty? (quad-list x)) - x ; no subelements, so stop here - (map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded - [else (map (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (regexp-match* #px"." x))]))]) - (flatten (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 -(provide join-quads) -(define-syntax-rule (join-quads qs-in) - ;((quads?)(quads?) . ->* . quads?) - - (let ([make-matcher (λ (base-q) - (λ(q) - (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 default) (equal? (quad-attr-ref base-q key default) (quad-attr-ref q key default))) - (list world:font-name-key - world:font-size-key - world:font-weight-key - world:font-style-key) - (list (world:font-name-default) - (world:font-size-default) - (world:font-weight-default) - (world:font-style-default))))))]) - (let loop ([qs qs-in][acc 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 (word (quad-attrs base-q) (string-append* (append-map quad-list (cons base-q matching-qs))))) - (loop other-qs (cons new-word acc))] - ;; otherwise move on to the next in line - [else (loop (cdr qs) (cons base-q acc))])))))) - - - -;; the last char of a quad -(define+provide/contract (quad-last-char q) - (quad? . -> . (or/c #f 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 - (car (quad-list (last split-qs))))) - -;; the first char of a quad -(define+provide/contract (quad-first-char q) - (quad? . -> . (or/c #f 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 - (car (quad-list (first split-qs))))) - - -;; propagate x and y adjustments throughout the tree, -;; using parent x and y to adjust children, and so on. -(define+provide/contract (compute-absolute-positions i [parent-x 0][parent-y 0]) - ((quad?) (integer? integer?) . ->* . quad?) - (cond - [(quad? i) - (define adjusted-x (round-float (+ (quad-attr-ref i world:x-position-key 0) parent-x))) - (define adjusted-y (round-float (+ (quad-attr-ref i world:y-position-key 0) parent-y))) - (quad (quad-name i) (merge-attrs i (list world:x-position-key adjusted-x world:y-position-key adjusted-y)) (map (λ(ii) (compute-absolute-positions ii adjusted-x adjusted-y)) (quad-list i)))] - [else i])) - -;; simple assert. should get moved to sugar/debug -(provide assert) -(define-syntax-rule (assert pred expr) - (let ([result expr]) - (if (pred result) - result - (error 'assert-failure (format "\n~a\nevaluates to:\n~a\nwhich is not:\n~a" 'expr result 'pred))))) - -;; peeks at arguments and times execution -(provide snoop) -(define-syntax (snoop stx) - (syntax-case stx () - [(_ proc arg ... . rest) - (with-syntax () - #'(begin - (displayln (format "Evaluating ~s" '(proc arg ... . rest))) - (let ([start (current-milliseconds)] - [result (proc arg ... . rest)] - [end (current-milliseconds)]) - (displayln (format "Evaluation of ~s took ~a ms\nResult ~a" '(proc arg ... . rest) (- end start) result)) - result)))])) - -;; find total pages in doc by searching on page count key. -(define+provide/contract (pages-in-doc doc) - (doc? . -> . integer?) - (add1 (apply max (map (curryr quad-attr-ref world:page-key 0) (quad-list doc))))) - - -;; todo: how to guarantee line has leading key? -(define+provide/contract (compute-line-height line) - (line? . -> . line?) - (quad-attr-set line world:height-key (quad-attr-ref/parameter line world:leading-key))) - -(define (fixed-height? q) (quad-has-attr? q world:height-key)) -(define+provide/contract (quad-height q) - (quad? . -> . number?) - (quad-attr-ref q world:height-key 0)) - -;; use heights to compute vertical positions -(define+provide/contract (add-vert-positions starting-quad) - (quad? . -> . quad?) - (define-values (new-quads final-height) - (for/fold ([new-quads empty][height-so-far 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+provide/contract (hyphenate-quad x) - (quad? . -> . quad?) - (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 -(provide split-last) -(define-syntax-rule (split-last xs) - (let-values ([(first-list last-list) (split-at-right 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))) - - -;; folded flonum operators -;; (for use with multiple args, standard flonum ops have arity = 2) - -(define-syntax (define-folded-op stx) - (syntax-case stx () - [(_ op starting-val) - (with-syntax ([fold-op (format-id stx "fold-~a" #'op)] - [ops (format-id stx "~as" #'op)]) - #'(begin - (provide fold-op ops) - (define-syntax-rule (ops x (... ...)) - (fold-op (list x (... ...)))) - (define-syntax-rule (fold-op xs) - (foldl op starting-val xs))))])) - -(define-folded-op fl+ 0.0) -(define-folded-op fl- 0.0) -(define-folded-op fl* 1.0) -(define-folded-op fl/ 1.0) \ No newline at end of file