diff --git a/quad/main-typed-sample.rkt b/quad/main-typed-sample.rkt index 5cbed3f0..4dd918ee 100644 --- a/quad/main-typed-sample.rkt +++ b/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"))) \ No newline at end of file diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 3da05a16..c212ba3c 100644 --- a/quad/quads-typed.rkt +++ b/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))) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 7b8a294c..8a4cc594 100644 --- a/quad/utils-typed.rkt +++ b/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)))