diff --git a/quad/main-typed-sample.rkt b/quad/main-typed-sample.rkt index 6859909c..6cd2c075 100644 --- a/quad/main-typed-sample.rkt +++ b/quad/main-typed-sample.rkt @@ -11,5 +11,6 @@ [world:paper-width-default 600.0] [world:paper-height-default 700.0]) (define sample (ti5)) - (define to (time (profile-thunk #:delay 0.001 (λ () (typeset sample))))) +; (define to (time (profile-thunk #:delay 0.001 (λ () (typeset sample))))) + (define to (time (typeset sample))) (time (send (new pdf-renderer%) render-to-file to "foo-typed.pdf"))) \ No newline at end of file diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index bcc611b6..ba7173c0 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -37,24 +37,27 @@ (: proc-name type-expr) (define proc-name body ...)))])) +(define-syntax (define-type+predicate stx) + (syntax-case stx () + [(_ id basetype) + (with-syntax ([id? (format-id stx "~a?" #'id)]) + #'(begin + (define-type id basetype) + (define-predicate id? id)))])) (define-syntax-rule (even-members xs) (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i)) x)) -(define-type QuadName Symbol) -(define-predicate QuadName? QuadName) +(define-type+predicate QuadName Symbol) -(define-type QuadAttrKey Symbol) -(define-predicate QuadAttrKey? QuadAttrKey) -(define-type QuadAttrValue Any) -(define-predicate QuadAttrValue? QuadAttrValue) +(define-type+predicate QuadAttrKey Symbol) +(define-type+predicate QuadAttrValue Any) (define-type QuadAttrs (HashTable QuadAttrKey QuadAttrValue)) ;;(define-predicate QuadAttrs? QuadAttrs) ;; won't work because it generates a chaperone contract -(define-type HashableList (Rec duo (U Null (List* QuadAttrKey Any duo)))) +(define-type+predicate HashableList (Rec duo (U Null (List* QuadAttrKey Any duo)))) (provide HashableList?) -(define-predicate HashableList? HashableList) (: quad-attrs? (Any . -> . Boolean)) (define (quad-attrs? x) @@ -67,10 +70,34 @@ (define-type (Treeof A) (Rec as (U A (Listof as)))) (struct quad ([name : QuadName] [attrs : QuadAttrs] [list : QuadList]) #:transparent) - (define-type Quad quad) (define-predicate Quad? Quad) + +#| +;; vector implementation + +(define-type Quad (List QuadName QuadAttrs QuadList)) +(define quad? Quad?) + +(define/typed (quad name attrs list) + (QuadName QuadAttrs QuadList . -> . Quad) + `(,name ,attrs ,list)) + +(define/typed (quad-name q) + (Quad . -> . QuadName) + (car q)) + +(define/typed (quad-attrs q) + (Quad . -> . QuadAttrs) + (cadr q)) + +(define/typed (quad-list q) + (Quad . -> . QuadList) + (caddr q)) +|# + + (define quad-attr-ref (case-lambda [([q : Quad] [key : QuadAttrKey]) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 64066742..44f385a7 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -34,23 +34,25 @@ ;; flatten merges attributes, but applies special logic suitable to flattening ;; for instance, resolving x and y coordinates. +(define-type QuadAttrFloatPair (Pairof QuadAttrKey Float)) + (define/typed+provide (flatten-attrs . quads-or-attrs-or-falses) ((U Quad QuadAttrs) * . -> . QuadAttrs) (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] + (for/fold ([xas : (Listof QuadAttrFloatPair) null] + [yas : (Listof QuadAttrFloatPair) 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)] + [(and (equal? (car attr) world:x-position-key) (flonum? (cdr attr))) (values (cons attr xas) yas oas)] + [(and (equal? (car attr) world:y-position-key) (flonum? (cdr attr))) (values xas (cons attr yas) oas)] [else (values xas yas (cons attr oas))]))) - (: make-cartesian-attr (QuadAttrKey (Listof QuadAttrPair) . -> . (Listof QuadAttrPair))) + (: make-cartesian-attr (QuadAttrKey (Listof QuadAttrFloatPair) . -> . (Listof QuadAttrFloatPair))) (define (make-cartesian-attr key attrs) (if (empty? attrs) empty - (list (cons key (apply + (cast ((inst map QuadAttrValue QuadAttrPair) cdr attrs) (Listof Float))))))) + (list (cons (ann key QuadAttrKey) (foldl fl+ 0.0 ((inst map Float QuadAttrFloatPair) cdr attrs)))))) (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)))])