kish

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)))

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))
+

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)))
 
-
-|#

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.