From 9372df85767fe346e9cd52f96b6f2f5ac10862a3 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 3 Feb 2015 14:50:39 -0800 Subject: [PATCH] brick --- quad/quads-typed.rkt | 3 +-- quad/tests-typed.rkt | 8 ++++++-- quad/utils-typed.rkt | 38 ++++++++++++++++++++++++++++++++++++-- quad/utils.rkt | 15 +-------------- 4 files changed, 44 insertions(+), 20 deletions(-) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 79ed7123..b61eb1e4 100644 --- a/quad/quads-typed.rkt +++ b/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) diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt index 1a6c8d45..e203a0c7 100644 --- a/quad/tests-typed.rkt +++ b/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))) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 12cc0aa3..259fc28e 100644 --- a/quad/utils-typed.rkt +++ b/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)) diff --git a/quad/utils.rkt b/quad/utils.rkt index 509259dc..51cd6726 100644 --- a/quad/utils.rkt +++ b/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,