po on quads-typed

quad/main-typed-sample.rkt

@@ -1,11 +1,15 @@
 #lang typed/racket/base
-(require "main-typed.rkt" "logger-typed.rkt" "world-typed.rkt" "samples-typed.rkt")
+(require "main-typed.rkt" "logger-typed.rkt" "world-typed.rkt" "samples-typed.rkt" "quads-typed.rkt")
 
-(require "render-typed.rkt" racket/class profile)
+(require/typed contract-profile
+                [contract-profile-thunk ((-> Any) . -> . Quad)])
+
+(require "render-typed.rkt" racket/class optimization-coach)
 (activate-logger quad-logger)
+
 (parameterize ([world:quality-default world:draft-quality]
                [world:paper-width-default 600.0]
                [world:paper-height-default 700.0])
   (define sample (ti5))
-  (define to (begin (time (typeset sample))))
+  (define to (time (typeset sample)))
   (time (send (new pdf-renderer%) render-to-file to "foo-typed.pdf")))

quad/quads-typed.rkt

@@ -32,16 +32,14 @@
      #'(begin
          (provide proc-name)
          (begin
-         (: proc-name type-expr)
-         (define proc-name body ...)))]))
+           (: proc-name type-expr)
+           (define proc-name body ...)))]))
 
 
 (define-syntax-rule (even-members xs)
   (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i))
     x))
 
-(: hashable-list? (Any . -> . Boolean))
-(define (hashable-list? x) (and (list? x) (even? (length x)) (andmap symbol? (even-members x))))
 
 (define-type QuadName Symbol)
 (define-predicate QuadName? QuadName)
@@ -52,6 +50,7 @@
 (define-predicate QuadAttrValue? QuadAttrValue)
 (define-type QuadAttrs (HashTable QuadAttrKey QuadAttrValue))
 (define-type HashableList  (Rec duo (U Null (List* QuadAttrKey Any duo))))
+(provide HashableList?)
 (define-predicate HashableList? HashableList)
 
 
@@ -63,8 +62,7 @@
 (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)))
+(struct quad ([name : QuadName] [attrs : QuadAttrs] [list : QuadList]) #:transparent)
 
 (define-type Quad quad)
 (define-predicate Quad? Quad)
@@ -107,29 +105,32 @@
 (: quad->string (Quad . -> . String))
 (define (quad->string x)
   (let loop : String ([x : (U Quad String) x])
-    (cond
-      [(quad? x) (string-append* ((inst map String QuadListItem) loop (quad-list x)))]
+    (cond 
       [(string? x) x]
-      [else ""])))
+      ;; else branch relies on fact that x is either Quad or String
+      [else (string-append* ((inst map String QuadListItem) loop (quad-list x)))])))
 
 (define/typed+provide (gather-common-attrs qs)
   ((Listof Quad) . -> . (Option HashableList))
   (: check-cap (Quad QuadAttrPair . -> . Boolean))
   (define (check-cap q cap) ; cap = candidate-attr-pair
     (equal? (quad-attr-ref q (car cap) attr-missing) (cdr cap)))
-  (let loop 
-    ([qs qs]
-     ;; start with the set of pairs in the first quad, then filter it down
-     [candidate-attr-pairs : (Listof QuadAttrPair) (if (quad-attrs (car qs))
-                                                    (for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))] 
-                                                               #:unless (member (car kv-pair) cannot-be-common-attrs))  
-                                                      kv-pair)
-                                                    null)])
-    (cond
-      [(null? candidate-attr-pairs) #f] ; ran out of possible pairs, so return #f
-      [(null? qs) (cast (flatten candidate-attr-pairs) HashableList)] ; ran out of quads, so return common-attr-pairs
-      ;; todo: reconsider type interface between output of this function and input to quadattrs
-      [else (loop (cdr qs) (filter (λ([cap : QuadAttrPair]) (check-cap (car qs) cap)) candidate-attr-pairs))])))
+  (and (not (null? qs))
+       (let loop 
+         ([qs qs]
+          ;; start with the set of pairs in the first quad, then filter it down
+          [candidate-attr-pairs : (Listof QuadAttrPair) (let ([first-attrs (quad-attrs (car qs))])
+                                                          (if first-attrs
+                                                              (for/fold ([kvps null]) ([k (in-list (hash-keys first-attrs))])  
+                                                                (if (member k cannot-be-common-attrs)
+                                                                    kvps
+                                                                    (cons (cons k (hash-ref first-attrs k)) kvps)))
+                                                              null))])
+         (cond
+           [(null? candidate-attr-pairs) #f] ; ran out of possible pairs, so return #f
+           [(null? qs) (cast (flatten candidate-attr-pairs) HashableList)] ; ran out of quads, so return common-attr-pairs
+           ;; todo: reconsider type interface between output of this function and input to quadattrs
+           [else (loop (cdr qs) (filter (λ([cap : QuadAttrPair]) (check-cap (car qs) cap)) candidate-attr-pairs))]))))
 
 (: quadattrs ((Listof Any) . -> . QuadAttrs))
 (define (quadattrs xs)
@@ -163,7 +164,7 @@
              (quad 'id (cond 
                          [(quad-attrs? attrs) (cast attrs QuadAttrs)]
                          [(list? attrs)
-                          (if (hashable-list? attrs)
+                          (if (HashableList? attrs)
                               (quadattrs attrs)
                               (error 'id "got non-hashable list ~a" attrs))]
                          [else (quadattrs '())]) (cast xs QuadList)))

quad/utils-typed.rkt

@@ -13,7 +13,7 @@
 ;; predicate for use below
 (: list-of-mergeable-attrs? (Any . -> . Boolean))
 (define (list-of-mergeable-attrs? xs)
-  (and (list? xs) (andmap (λ(x) (or (quad? x) (quad-attrs? x) (hashable-list? x))) xs)))
+  (and (list? xs) (andmap (λ(x) (or (quad? x) (quad-attrs? x) (HashableList? x))) xs)))
 
 ;; faster than (listof pair?)
 (: pairs? (Any . -> . Boolean))
@@ -27,7 +27,7 @@
                                                                                                (cond
                                                                                                  [(quad? x) (quad-attrs x)]
                                                                                                  [(quad-attrs? x) (cast x QuadAttrs)]
-                                                                                                 [(hashable-list? x) (quadattrs (cast x (Listof Any)))]
+                                                                                                 [(HashableList? x) (quadattrs (cast x (Listof Any)))]
                                                                                                  [else ;; something that will have no effect on result 
                                                                                                   (cast (hash) QuadAttrs)])) quads-or-attrs-or-lists)))