split-quad

quad/tests-typed.rkt

@@ -25,5 +25,5 @@
 (define b2-flattened (list (spacer '(x 10.0)) (spacer '(x 25.0)) (spacer '(x 25.0)) (spacer '(x 10.0))))
 
 (check-true (quad= (flatten-quad b2) b2-flattened))
-;(check-true (quad= (split-quad b2) b2-flattened))
+(check-true (quad= (split-quad b2) b2-flattened))
 

quad/utils-typed.rkt

@@ -83,3 +83,21 @@
              [else ;; it's a string
               (quad (quad-name parent) (quad-attrs parent) (list x))]))) (Listof Quad)))
 
+
+;; flatten quad as above, 
+;; then dissolve it into individual character quads while copying attributes
+;; input is often large, so macro allows us to avoid allocation
+(provide split-quad)
+(: split-quad (Quad . -> . (Listof Quad)))
+(define (split-quad q)
+  (: do-explode ((QuadListItem) (Quad) . ->* . (Treeof Quad)))
+  (define (do-explode x [parent (box)])
+    (cond
+      [(quad? x)
+       (if (empty? (quad-list x))
+           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))]))
+  (cast (flatten (map do-explode (flatten-quad q))) (Listof Quad)))
+