diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index b61eb1e4..b7825551 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -26,7 +26,9 @@ (define (quad-attrs? x) (and (hash? x) (andmap QuadAttrKey? (hash-keys x)))) -(define-type QuadList (Listof (U Quad String))) +(define-type QuadListItem (U Quad String)) +(define-type QuadList (Listof QuadListItem)) +(define-type (Treeof A) (Rec as (U A (Listof as)))) (struct quad ([name : QuadName] [attrs : QuadAttrs] [list : QuadList]) #:transparent #:property prop:sequence (λ(q) (quad-list q))) diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt index e8d83d64..c48c9798 100644 --- a/quad/tests-typed.rkt +++ b/quad/tests-typed.rkt @@ -13,10 +13,17 @@ (check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) #f) (check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) #f) -(define b1 (box '(x 10) "1st" (box '(foo bar) "2nd") "3rd")) -(define b1-flattened (list (box '(x 10) "1st") (box '(x 10 foo bar) "2nd") (box '(x 10) "3rd"))) +(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 #f (word) (line) (page))) (check-true (sequence? b3)) -;(check-true (quad= (flatten-quad b1) b1-flattened)) +(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)) + diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 2eca8642..e2398117 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -1,6 +1,6 @@ #lang typed/racket/base (require sugar/list) -(require/typed racket/list [flatten (All (A) ((Listof A) -> (Listof A)))]) +(require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))]) (require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool hyphenate racket/function math/flonum) (require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt") @@ -65,13 +65,13 @@ ;; 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) (: flatten-quad (Quad . -> . (Listof Quad))) (define (flatten-quad q) - (flatten - (let loop ([x q][parent #f]) + (cast (flatten + (let loop : (Treeof Quad) + ([x : QuadListItem q][parent : Quad (box)]) + (cond [(quad? x) (let ([x-with-parent-attrs (quad (quad-name x) @@ -79,8 +79,7 @@ (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))])))) + ((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))]))) (Listof Quad))) - -|# \ No newline at end of file diff --git a/quad/utils.rkt b/quad/utils.rkt index 51cd6726..016eb97a 100644 --- a/quad/utils.rkt +++ b/quad/utils.rkt @@ -60,7 +60,20 @@ (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.