brick

quad/quads-typed.rkt

@@ -1,7 +1,6 @@
 #lang typed/racket/base
 (require (for-syntax typed/racket/base racket/syntax racket/string))
-(require/typed racket/list [flatten (All (A) ((Listof A) -> (Listof A)))]
-               [empty? (All (A) ((Listof A) -> Boolean))])
+(require/typed racket/list [empty? (All (A) ((Listof A) -> Boolean))])
 (require/typed sugar/list [trimf (All (A) ((Listof A) (A . -> . Boolean) -> (Listof A)))]
                [filter-split (All (A) ((Listof A) (A . -> . Boolean) -> (Listof (Listof A))))])
 (require sugar/debug)

quad/tests-typed.rkt

@@ -2,5 +2,9 @@
 (require "utils-typed.rkt" "quads-typed.rkt" "world-typed.rkt" racket/list racket/format)
 (require rackunit)
 
-(check-equal? (join-attrs (list (box '(width 10)) (quad-attrs (box '(x 10))) (list 'width 20))) 
-              (list (cons 'width 10) (cons 'x 10) (cons 'width 20)))
+(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)) (hash 'x 10.0)) (apply hash '(foo bar x 10.0)))
+(check-equal? (flatten-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 5.0)))
+(check-equal? (merge-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 10.0)))

quad/utils-typed.rkt

@@ -1,6 +1,7 @@
 #lang typed/racket/base
 (require sugar/list)
-(require (for-syntax racket/syntax racket/base) racket/string racket/list sugar/debug racket/bool hyphenate racket/function math/flonum)
+(require/typed racket/list [flatten (All (A) ((Listof A) -> (Listof A)))])
+(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")
 
 
@@ -23,6 +24,39 @@
                                                      [(quad? x) (quad-attrs x)]
                                                      [(quad-attrs? x) (cast x QuadAttrs)]
                                                      [(hashable-list? x) (quadattrs (cast x (Listof Any)))]
-                                                     [else (cast hash QuadAttrs)])) quads-or-attrs-or-lists)))
+                                                     [else ;; something that will have no effect on result 
+                                                      (cast hash QuadAttrs)])) quads-or-attrs-or-lists)))
 
 
+;; flatten merges attributes, but applies special logic suitable to flattening
+;; for instance, resolving x and y coordinates.
+(provide flatten-attrs)
+(: flatten-attrs ((U Quad QuadAttrs) * . -> . QuadAttrs))
+(define (flatten-attrs . quads-or-attrs-or-falses)
+  (define all-attrs (join-attrs quads-or-attrs-or-falses))
+  (define-values (x-attrs y-attrs other-attrs-reversed)
+    (for/fold ([xas : (Listof QuadAttrPair) null]
+               [yas : (Listof QuadAttrPair) null]
+               [oas : (Listof QuadAttrPair) 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))])))
+  (: make-cartesian-attr (QuadAttrKey (Listof QuadAttrPair) . -> . (Listof QuadAttrPair)))
+  (define (make-cartesian-attr key attrs) 
+    (if (empty? attrs) 
+        empty 
+        (list (cons key (apply + (cast ((inst map QuadAttrValue QuadAttrPair) cdr attrs) (Listof Flonum)))))))
+  (define x-attr (make-cartesian-attr world:x-position-key x-attrs))
+  (define y-attr (make-cartesian-attr world:y-position-key y-attrs))
+  (for/hash : QuadAttrs ([kv-pair (in-list (append x-attr y-attr (reverse other-attrs-reversed)))])
+      (values (car kv-pair) (cdr kv-pair))))
+
+;; merge concatenates attributes, with later ones overriding earlier.
+;; most of the work is done by join-attrs.
+(provide merge-attrs)
+(: merge-attrs ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs))
+(define (merge-attrs . quads-or-attrs-or-lists)
+  (cast (for/hash ([kv-pair (in-list (join-attrs quads-or-attrs-or-lists))])
+      (values (car kv-pair) (cdr kv-pair))) QuadAttrs))

quad/utils.rkt

@@ -59,20 +59,7 @@
   (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,