diff --git a/quad/qtest/quad-repl.rkt b/quad/qtest/quad-repl.rkt deleted file mode 100644 index b4f12e47..00000000 --- a/quad/qtest/quad-repl.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang br -(require quad racket/draw racket/gui) -(verbose-quad-printing? #t) - -(define q1 (make-quad #:size '(20 20))) -(define q2 (make-quad - #:from 'bo - #:to 'bi - #:size '(15 15))) - - (define target (make-bitmap 800 150)) ; A 30x30 bitmap -(define (go qs) - (define dc (new bitmap-dc% [bitmap target])) - (send dc scale 3 3) - (send dc translate 3 3) - - (for ([q qs]) - (define args (append (quad-origin q) (quad-size q))) - (send dc draw-rectangle . args)) ; 30 pixels wide and 10 pixels high - - (make-object image-snip% target)) - -(go (position (list q1 q2))) diff --git a/quad/qtest/tagdemo.rkt b/quad/qtest/tagdemo.rkt index 1f1f603d..fbfa8ba7 100644 --- a/quad/qtest/tagdemo.rkt +++ b/quad/qtest/tagdemo.rkt @@ -2,9 +2,10 @@ (require quadwriter/core quadwriter/param quad/quad) (draw-debug? #true) +(zoom-factor 2) (verbose-quad-printing? #f) -(render-pdf '(q ((page-width "300") (page-height "300") - (page-margin-left "60") - (page-margin-top "40") - (line-align "right")) "Hello world") "foo.pdf") \ No newline at end of file +(render-pdf '(q ((page-width "250") (page-height "250") + (page-margin-left "30") + (page-margin-top "20") + (line-align "center")) "Hello world") "foo.pdf") \ No newline at end of file diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 8fee891a..4ecac5eb 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -75,19 +75,18 @@ ;; notice that the technique depends on ;; 1) we only need to update attrs and elems ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail - (define x-maker (let-values ([(x-structure-type _) (struct-info x)]) - (struct-type-make-constructor x-structure-type))) + (define x-constructor (derive-quad-constructor x)) (define x-tail (drop (struct->list x) 2)) (match (merge-adjacent-strings (quad-elems x) 'isolate-white) [(? pair? merged-elems) (append* (for/list ([elem (in-list merged-elems)]) (match elem - [(? string? str) (list (apply x-maker next-attrs (list str) x-tail))] + [(? string? str) (list (apply x-constructor next-attrs (list str) x-tail))] [_ (loop elem next-attrs next-key)])))] ;; if merged elements are empty (for instance, series of empty strings) ;; then zero out the elements in the quad. - [_ (list (apply x-maker next-attrs null x-tail))])]))) + [_ (list (apply x-constructor next-attrs null x-tail))])]))) #;(trimf atomized-qs (λ (q) (equal? (quad-elems q) '(" ")))) atomized-qs) diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index 1e4ec3ae..ee7157c3 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -119,8 +119,45 @@ [(list-no-order 0 val) val] [(list ∆x ∆y) (sqrt (+ (expt ∆x 2) (expt ∆y 2)))])) +(define (flatten-quad q) + (cons (struct-copy quad q [elems null]) + (apply append (map flatten-quad (quad-elems q))))) + +(define (bounding-box . qs-in) + ;; size of box that holds q and all subqs, based on reported origin and size + ;; does not know anything about drawing (which may go outside the box) + (define qs (flatten-quad (position (make-quad #:elems qs-in)))) + (define (outer-pt q) (pt+ (quad-origin q) (quad-size q))) + (define max-outer-pt (apply map max (cons '(0 0) (map outer-pt qs)))) + (define min-origin (apply map min (cons '(0 0) (map quad-origin qs)))) + (pt- max-outer-pt min-origin)) + + (module+ test (require rackunit) + + (test-case + "bounding boxes" + (define q10 (make-quad #:size '(10 10))) + (define q20 (make-quad #:size '(20 20))) + (check-equal? (bounding-box q10) '(10 10)) + (check-equal? (bounding-box q10 q10) '(20 10)) + (check-equal? (bounding-box q20) '(20 20)) + (check-equal? (bounding-box q10 q20) '(30 20)) + (check-equal? (bounding-box q10 q20 q20) '(50 20)) + + (define q1 (make-quad #:size '(20 20))) + (define p (make-quad #:size '(35 35) + #:elems (list q1))) + (let ([p (position p)]) + (println (quad-origin p)) + (println (quad-origin (car (quad-elems p))))) + (let ([p p]) + (println (quad-origin p)) + (println (quad-origin (car (quad-elems p))))) + (check-equal? (bounding-box (position p)) (bounding-box p))) + + (test-case "origins" (define size (pt 10 10)) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 72d4c625..46335a96 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -108,6 +108,13 @@ ;; and everything piles up at the origin ;; if size is otherwise, the items don't pile up (but rather lay out in a row) +(define (make-quad-constructor type) + (make-keyword-procedure (λ (kws kw-args . rest) + (keyword-apply make-quad #:type type kws kw-args rest)))) + +(define (derive-quad-constructor q) + (define-values (x-structure-type _) (struct-info q)) + (struct-type-make-constructor x-structure-type)) ;; todo: convert immutable hashes to mutable on input? (define (make-quad diff --git a/quad/quad/repl.rkt b/quad/quad/repl.rkt new file mode 100644 index 00000000..e83b3d95 --- /dev/null +++ b/quad/quad/repl.rkt @@ -0,0 +1,35 @@ +#lang br +(require quad racket/draw pict pict/convert) +(provide (all-defined-out)) +(verbose-quad-printing? #t) + +(define (quad->pict q) + (match-define (list bbox-x bbox-y) (bounding-box q)) + (define scaling-factor 3) + (define stroke-width 0.5) + (unsafe-dc + (λ (dc dx dy) + (send dc scale scaling-factor scaling-factor) + (send dc translate stroke-width stroke-width) + (send dc set-pen + (new pen% [width stroke-width] [color "slategray"])) + (let loop ([q q]) + (define args (append (quad-origin q) (quad-size q))) + (send dc draw-rectangle . args) + (map loop (quad-elems q)))) + (* scaling-factor (+ bbox-x (* stroke-width 2))) + (* scaling-factor (+ bbox-y (* stroke-width 2))))) + +(struct quad-pict quad () + #:property prop:pict-convertible quad->pict) + +(define make-quad (make-quad-constructor quad-pict)) + +(define q1 (make-quad #:size '(20 20))) +(define q2 (make-quad #:size '(15 15))) +(define p (make-quad #:size '(35 35) + #:elems (list q1))) + +;; todo: make these equal +(bounding-box (position p)) +(bounding-box p) diff --git a/quad/quad/scribblings/quad.scrbl b/quad/quad/scribblings/quad.scrbl index 7c319801..f76265ae 100644 --- a/quad/quad/scribblings/quad.scrbl +++ b/quad/quad/scribblings/quad.scrbl @@ -1,9 +1,19 @@ #lang scribble/manual @(require racket/runtime-path scribble/eval (for-label txexpr (except-in pollen #%module-begin) xml racket/base racket/draw) -pollen/scribblings/mb-tools) +pollen/scribblings/mb-tools quad/repl) @(define my-eval (make-base-eval)) +@(my-eval `(require quad quad/repl pict)) + +@examples[#:eval my-eval +(define q1 (make-quad #:size '(20 20))) +(define q2 (make-quad + #:from 'bo + #:to 'bi + #:size '(15 15))) +(d (position (list q1 q2))) +] @title[#:style 'toc]{Quad: document processor}