clarify

quad/quad/dev.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
-(require (for-syntax racket/base))
+(require (for-syntax racket/base) racket/list sugar/debug)
 (provide (except-out (all-from-out racket/base) #%module-begin)
+         (all-from-out racket/list sugar/debug)
          (rename-out [~module-begin #%module-begin])
          (for-syntax (all-from-out racket/base)))
 

quad/quad/quads.rkt

@@ -2,28 +2,40 @@
 (provide (all-defined-out))
 (require (for-syntax racket/string))
 
-(define (quad-name q) (vector-ref q 0))
+
 (define (quad-attrs q) (vector-ref q 1))
-(define (quad-list q) (vector-ref q 2))
+(define (quad-list q) (vector-ref q 0))
 
 
 (define (quad? x)
   (and (vector? x)
-       (symbol? (quad-name x))
-       (or (not (quad-attrs x)) (hash? (quad-attrs x)))
+       (vector? (quad-attrs x))
        (list? (quad-list x))))
 
 (define (quad-attrs? x) (list? x))
 
-(define (quad name attrs xs)
-  (vector name attrs xs))
 
+(define default-attrs (vector 12 "Courier" 0 0))
+(define (quad attrs . xs)
+  (vector-immutable xs attrs))
+
+(define (make-quad-attrs #:size [size #f]
+              #:font [font #f]
+              #:x [x #f]
+              #:y [y #f])
+  (vector size font x y))
+
+(define attrs '(size font x y))
+
+(define (attr-size a) (vector-ref a 0))
+(define (attr-font a) (vector-ref a 1))
+(define (attr-x a) (vector-ref a 2))
+(define (attr-y a) (vector-ref a 3))
 
 (module+ test
   (require rackunit)
-  (define q (quad 'foo #f '("bar")))
+  (define q (quad "bar"))
   (check-true (quad? q))
   (check-false (quad? 42))
-  (check-equal? (quad-name q) 'foo)
-  (check-equal? (quad-attrs q) #f)
+  (check-equal? (quad-attrs q) default-attrs)
   (check-equal? (quad-list q) '("bar")))

quad/quad/split.rkt

@@ -1,86 +1,17 @@
-#lang racket
+#lang quad/dev
 (require "quads.rkt")
 
-;; push together multiple attr sources into one list of pairs.
-;; mostly a helper function for the two attr functions below.
-#;(define (join-attrs quads-or-attrs-or-lists)
-    (append-map hash->list (filter-not false? (map (λ(x)
-                                                     (cond
-                                                       [(quad? x) (quad-attrs x)]
-                                                       [(quad-attrs? x) x]
-                                                       #;[(hashable-list? x) (apply hash x)]
-                                                       [else #f])) quads-or-attrs-or-lists))))
-
-
-;; flatten merges attributes, but applies special logic suitable to flattening
-;; for instance, resolving x and y coordinates.
-#;(define (flatten-attrs . quads-or-attrs-or-falses)
-    (define all-attrs (join-attrs quads-or-attrs-or-falses))
-    (define-values (x-attrs y-attrs other-attrs-reversed)
-      (for/fold ([xas null][yas null][oas null])([attr (in-list all-attrs)])
-        (cond
-          [(equal? (car attr) 'x) (values (cons attr xas) yas oas)]
-          [(equal? (car attr) 'y) (values xas (cons attr yas) oas)]
-          [else (values xas yas (cons attr oas))])))
-    (define (make-cartesian-attr key attrs) (if (empty? attrs) empty (cons key (apply + (map cdr attrs)))))
-    (define-values (x-attr y-attr) (apply values (map make-cartesian-attr (list 'x 'y) (list x-attrs y-attrs))))
-    (apply hash (flatten (list* x-attr y-attr (reverse other-attrs-reversed)))))
-
-;; pushes attributes down from parent quads to children, 
-;; resulting in a flat list of quads.
-#;(define (flatten-quad q)
-    (flatten
-     (let loop ([x q][parent #f])
-       (cond       
-         [(quad? x)
-          (let ([x-with-parent-attrs (quad (quad-name x) 
-                                           (flatten-attrs parent x) ; child positioned last so it overrides parent attributes 
-                                           (quad-list x))])
-            (if (empty? (quad-list x))
-                x-with-parent-attrs ; no subelements, so stop here
-                (map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements
-         [(string? x) (quad (quad-name parent) (quad-attrs parent) (list x))]))))
-
-
-
-(require sugar/debug)
-;; flatten quad as above, 
-;; then dissolve it into individual character quads while copying attributes
-
-#;(define (split-quad q)
-    (letrec ([do-explode (λ(x [parent #f])
-                           (cond
-                             [(quad? x)
-                              (if (empty? (quad-list x))
-                                  x ; no subelements, so stop here
-                                  (map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
-                             ;; todo: figure out why newlines foul up the input stream. Does it suffice to ignore them? 
-                             [else (map (λ(xc) (quad 'atom (quad-attrs parent) (list xc))) (regexp-match* #px"[^\r\n]" x))]))])
-      (flatten (map do-explode (flatten-quad q)))))
-
-(require (for-syntax syntax/strip-context sugar/debug))
-(define-for-syntax ctx #'here)
-(define-syntax (stx-quad stx)
-  (syntax-case stx ()
-    [(_ QUAD-NAME ((ATTR-NAME ATTR-VAL) ...) XS)
-     (with-syntax ([(NEW-ATTR-NAME ...) (map (λ(an) (datum->syntax stx (syntax->datum an))) (syntax->list #'(ATTR-NAME ...)))]
-                   [(ALL-ATTR-NAME ...) (map (λ(n) (datum->syntax stx n)) '(size font))])
-       #'(let ([NEW-ATTR-NAME ATTR-VAL] ...)
-           (append-map (λ(x) (if (string? x)
-                                 (for/list ([c (in-string x)])
-                                           (vector ALL-ATTR-NAME ... c))
-                                 x)) XS)))]))
-
-
-(require racket/generator)
-#;(define y (generator () (stx-quad ((size 10)) (list "bar" (stx-quad () '("zam"))))))
-
-#|
-(define x (quad 'foo (hash 'size 10) (list "bar" (quad 'foo (hash 'size 8) '("zam")) "qux")))
-(split-quad x)
-|#
-
-;(define x2 (stx-quad ((size 10)(font "Eq")) (list "bar" (stx-quad ((size 8)) '("zam")) "qux")))
-;x2
-
-(stx-quad 'foo ((size 10)(font "Eq")) (list "bar" (stx-quad 'foo ((size 8)) '("zam")) "qux"))
+(define (split-quad x)
+  (flatten
+   (let loop ([x x][attrs default-attrs])
+     (cond
+       [(char? x) (quad attrs x)]
+       [(string? x) (map (λ(xi) (loop xi attrs)) (string->list x))]
+       [else
+        (define x-attrs (quad-attrs x))
+        (for ([i (in-range (vector-length attrs))])
+             (unless (vector-ref x-attrs i)
+               (vector-set! x-attrs i (vector-ref attrs i))))
+        (map (λ(xi) (loop xi x-attrs)) (quad-list x))]))))
+
+(split-quad (quad (make-quad-attrs #:size 10 #:font "Eq") "ba\nr" (quad (make-quad-attrs #:size 8) "zam") "q\tux"))