diff --git a/quad/quad/dev.rkt b/quad/quad/dev.rkt index b28ee734..8950e709 100644 --- a/quad/quad/dev.rkt +++ b/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))) diff --git a/quad/quad/quads.rkt b/quad/quad/quads.rkt index a4dc1cfc..a550e749 100644 --- a/quad/quad/quads.rkt +++ b/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"))) \ No newline at end of file diff --git a/quad/quad/split.rkt b/quad/quad/split.rkt index 82d56a08..e0e3e158 100644 --- a/quad/quad/split.rkt +++ b/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")) \ No newline at end of file +(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")) \ No newline at end of file