start printing

quad/qtest/quad-repl.rkt

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

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")
+(render-pdf '(q ((page-width "250") (page-height "250")
+                 (page-margin-left "30")
+                 (page-margin-top "20")
+                 (line-align "center")) "Hello world") "foo.pdf")

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)
 

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

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

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)

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}