diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt index d8413ee7..bd3d1f67 100644 --- a/quad/tests-typed.rkt +++ b/quad/tests-typed.rkt @@ -27,3 +27,22 @@ (check-true (quad= (flatten-quad b2) b2-flattened)) (check-true (quad= (split-quad b2) b2-flattened)) +(check-true (quad= (flatten-quad (box '(foo 10) (spacer) (box) (spacer))) (list (spacer '(foo 10)) (box '(foo 10)) (spacer '(foo 10))))) + +(check-equal? (compute-absolute-positions (page '(x 100.0 y 100.0) (line '(x 10.0 y 10.0) (word '(x 1.0 y 1.0) "hello") + (word '(x 2.0 y 2.0) "world")))) + (page '(y 100.0 x 100.0) (line '(y 110.0 x 110.0) (word '(y 111.0 x 111.0) "hello")(word '(y 112.0 x 112.0) "world")))) + +(define b2-exploded (list (word '(x 10.0) "1") (word '(x 10.0) "s") (word '(x 10.0) "t") (word '(x 10.0 foo bar) "2") (word '(x 10.0 foo bar) "n") (word '(x 10.0 foo bar) "d") (word '(x 10.0) "3") (word '(x 10.0) "r") (word '(x 10.0) "d"))) + +(check-true (quad= (split-quad b1) b2-exploded)) + +(check-false (quad-has-attr? (box) 'foo)) +(check-true (quad-has-attr? (box '(foo bar)) 'foo)) + +(check-equal? (quad-attr-set (box '(foo bar)) 'foo 'zam) (box '(foo zam))) +(check-equal? (quad-attr-set (box '()) 'foo 'zam) (box '(foo zam))) +(check-equal? (quad-attr-set* (box '()) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo))) +(check-equal? (quad-attr-set* (box '(foo bar)) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo))) + + diff --git a/quad/tests.rkt b/quad/tests.rkt index 7e4781f1..e94cf5d3 100644 --- a/quad/tests.rkt +++ b/quad/tests.rkt @@ -41,8 +41,6 @@ (check-true (quad= (split-quad b1) b2-exploded)) -(let ([world:minimum-last-line-chars 0]) - (check-equal? (map (compose1 quad-list last quad-list) (make-pieces (split-quad (block #f "Foo-dog and " (box) " mas\u00adsachu.")))) '(("o") ("g") ("d") () ("s") (".")))) (check-false (quad-has-attr? (box) 'foo)) (check-true (quad-has-attr? (box '(foo bar)) 'foo)) @@ -101,3 +99,5 @@ (check-equal? tokens (vector #\M #\e #\g #\space #\i #\s #\space (box) #\space #\a #\l #\l #\y #\.)) (check-equal? attrs '(#(#hash((measure . 54)) 0 14) #(#hash((foo . 42)) 7 8))) +(let ([world:minimum-last-line-chars 0]) + (check-equal? (map (compose1 quad-list last quad-list) (make-pieces (split-quad (block #f "Foo-dog and " (box) " mas\u00adsachu.")))) '(("o") ("g") ("d") () ("s") (".")))) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 33431295..ae11626d 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -1,5 +1,5 @@ #lang typed/racket/base -(require sugar/list) +(require/typed sugar/list [slice-at ((Listof (U QuadAttrKey QuadAttrValue)) Positive-Integer . -> . (Listof (List QuadAttrKey QuadAttrValue)))]) (require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))]) (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") @@ -98,6 +98,39 @@ x ; no subelements, so stop here ((inst map (Treeof Quad) QuadListItem) (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded [else ;; it's a string - ((inst map (Treeof Quad) QuadListItem) (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (regexp-match* #px"." x))])) + ((inst map (Treeof Quad) QuadListItem) (λ(xc) (quad world:split-quad-key (quad-attrs parent) (list xc))) (regexp-match* #px"." x))])) (cast (flatten (map do-explode (flatten-quad q))) (Listof Quad))) + +;; propagate x and y adjustments throughout the tree, +;; using parent x and y to adjust children, and so on. +(provide compute-absolute-positions) +(: compute-absolute-positions (Quad . -> . Quad)) +(define (compute-absolute-positions qli) + (define result + (let loop : QuadListItem ([qli : QuadListItem qli][parent-x : Flonum 0.0][parent-y : Flonum 0.0]) + (cond + [(quad? qli) + (define adjusted-x (round-float (+ (cast (quad-attr-ref qli world:x-position-key 0.0) Flonum) parent-x))) + (define adjusted-y (round-float (+ (cast (quad-attr-ref qli world:y-position-key 0.0) Flonum) parent-y))) + (quad (quad-name qli) (merge-attrs qli (list world:x-position-key adjusted-x world:y-position-key adjusted-y)) ((inst map QuadListItem QuadListItem) (λ(qlii) (loop qlii adjusted-x adjusted-y)) (quad-list qli)))] + [else ;; it's a string + qli]))) + (if (string? result) + (error 'compute-absolute-positions "got string as result: ~v" result) + result)) + + +;; functionally update a quad attr. Similar to hash-set +(provide quad-attr-set) +(: quad-attr-set (Quad QuadAttrKey QuadAttrValue . -> . Quad)) +(define (quad-attr-set q k v) + (quad (quad-name q) (merge-attrs (quad-attrs q) (list k v)) (quad-list q))) + + +;; functionally update multiple quad attrs. Similar to hash-set* +(provide quad-attr-set*) +(: quad-attr-set* (Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad)) +(define (quad-attr-set* q . kvs) + (for/fold ([current-q q])([kv-list (in-list (slice-at kvs 2))]) + (apply quad-attr-set current-q kv-list))) \ No newline at end of file diff --git a/quad/world-typed.rkt b/quad/world-typed.rkt index 0428ef84..bde8c810 100644 --- a/quad/world-typed.rkt +++ b/quad/world-typed.rkt @@ -51,6 +51,8 @@ (define height-key 'height) (define unbreakable-key 'no-break) +(define split-quad-key 'word) + (define line-index-key 'line-idx) (define total-lines-key 'lines)