quad-attr-set and set*

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

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

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

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)