wrk

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

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

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