cleanse

quad/quad/draw.rkt

@@ -0,0 +1,21 @@
+#lang debug br
+(require pict racket/draw)
+
+
+(dc (λ (dc dx dy)
+        (define old-brush (send dc get-brush))
+        (define old-pen (send dc get-pen))
+        (send dc set-brush
+          (new brush% [style 'fdiagonal-hatch]
+                      [color "darkslategray"]))
+        (send dc set-pen
+          (new pen% [width 3] [color "slategray"]))
+        (define path (new dc-path%))
+        (send path move-to 0 0)
+        (send path line-to 50 0)
+        (send path line-to 25 50)
+        (send path close)
+        (send dc draw-path path dx dy)
+        (send dc set-brush old-brush)
+        (send dc set-pen old-pen))
+    100 100)

quad/quad/position.rkt

@@ -2,114 +2,101 @@
 (require racket/contract "quad.rkt" "generic.rkt")
 (provide (all-defined-out))
 
-(define pt-x real-part)
-(define pt-y imag-part)
-(define (pt x y) (+ x (* y +i)))
-(define point? number?)
+(define pt-x first)
+(define pt-y second)
+(define (pt x y) (list x y))
+(define (pt+ . pts) (apply map + pts))
+(define (pt- . pts) (apply map - pts))
+(define point? (list/c number? number?))
+
 
 (define (valid-anchor? anchor)
-  (define valid-anchors '(nw n ne e se s sw w))
+  (define valid-anchors '(nw n ne w c e sw s se))
   (and (memq anchor valid-anchors) #t))
 
+
 (define (coerce-int x) (if (integer? x) (inexact->exact x) x))
 
-(define/contract (relative-anchor-pt q anchor)
+
+(define/contract (anchor->point q anchor)
   (quad? symbol? . -> . point?)
   (unless (valid-anchor? anchor)
-    (raise-argument-error 'anchor-adjustment "valid anchor" anchor))
-  (define-values (xfac yfac)
+    (raise-argument-error 'relative-anchor-pt "valid anchor" anchor))
+  (match-define (list x-fac y-fac)
     (case anchor
-      [(nw) (values 0 0)]
-      [(n) (values 0.5 0)]
-      [(ne) (values 1 0)]
-      [(e) (values 1 0.5)]
-      [(se) (values 1 1)]
-      [(s) (values 0.5 1)]
-      [(sw) (values 0 1)]
-      [(w) (values 0 0.5)]))
-  (pt (coerce-int (* (pt-x (size q)) xfac))
-      (coerce-int (* (pt-y (size q)) yfac))))
+      [(nw) '(0 0  )] [(n) '(0.5 0  )] [(ne) '(1 0  )]
+      [( w) '(0 0.5)] [(c) '(0.5 0.5)] [( e) '(1 0.5)]
+      [(sw) '(0 1  )] [(s) '(0.5 1  )] [(se) '(1 1  )]))
+  (pt (coerce-int (* (pt-x (size q)) x-fac)) (coerce-int (* (pt-y (size q)) y-fac))))
 
 
 (define/contract (inner-point q)
   (quad? . -> . point?)
-  (+ (origin q) (relative-anchor-pt q (inner q)) (offset q)))
+  (pt+ (origin q) (anchor->point q (inner q)) (offset q)))
 
 
 (define/contract (end-point q)
   (quad? . -> . point?)
-  ;; no offset because end-point is "pre-padding"
-  (+ (origin q) (relative-anchor-pt q (end q))))
-    
+  (pt+ (origin q) (anchor->point q (end q)))) ; no offset because end-point is calculated without padding
 
-(define/contract (align! q where)
-  (quad? point? . -> . quad?)
-  (set-origin! q (- where (relative-anchor-pt q (start q))))
-  q)
 
-(define/contract (position q [where 0])
+(define/contract (position q [previous-end-pt (pt 0 0)])
   ((quad?) (point?) . ->* . quad?)
-  (align! q where)
-  (fold-positions (elems q) (inner-point q))
+  (set-origin! q (pt- previous-end-pt (anchor->point q (start q))))
+  (for/fold ([pt (inner-point q)])
+            ([q (in-list (elems q))])
+    (end-point (position q pt)))
   q)
 
-(define/contract (fold-positions qs [start-pt 0])
-  (((listof quad?)) (point?) . ->* . point?)
-  (foldl (λ (q pt) (end-point (position q pt))) start-pt qs))
-
-
 
 (module+ test
   (require rackunit)
   (test-case
    "origins"
-   (define size 10+10i)
-   (define orig 5+5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'nw 'size size)) orig)) 5+5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'n 'size size)) orig)) +5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'ne 'size size)) orig)) -5+5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'e 'size size)) orig)) -5)
-   (check-equal? (origin (position (quad (hasheq 'start 'se 'size size)) orig)) -5-5i)
-   (check-equal? (origin (position (quad (hasheq 'start 's 'size size)) orig)) -5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'sw 'size size)) orig)) 5-5i)
-   (check-equal? (origin (position (quad (hasheq 'start 'w 'size size)) orig)) 5))
+   (define size (pt 10 10))
+   (define orig (pt 5 5))
+   (check-equal? (origin (position (quad (hasheq 'start 'nw 'size size)) orig)) (pt 5 5))
+   (check-equal? (origin (position (quad (hasheq 'start 'n 'size size)) orig)) (pt 0 5))
+   (check-equal? (origin (position (quad (hasheq 'start 'ne 'size size)) orig)) (pt -5 5))
+   (check-equal? (origin (position (quad (hasheq 'start 'e 'size size)) orig)) (pt -5 0))
+   (check-equal? (origin (position (quad (hasheq 'start 'se 'size size)) orig)) (pt -5 -5))
+   (check-equal? (origin (position (quad (hasheq 'start 's 'size size)) orig)) (pt 0 -5))
+   (check-equal? (origin (position (quad (hasheq 'start 'sw 'size size)) orig)) (pt 5 -5))
+   (check-equal? (origin (position (quad (hasheq 'start 'w 'size size)) orig)) (pt 5 0)))
 
   (test-case
    "inner points"
-   (define size 10+10i)
-   (define orig 0)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw)) orig)) 0)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n)) orig)) 5)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne)) orig)) 10)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e)) orig)) 10+5i)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se)) orig)) 10+10i)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's)) orig)) 5+10i)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw)) orig)) +10i)
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w)) orig)) +5i))
+   (define size '(10 10))
+   (define orig '(0 0))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw)) orig)) (pt 0 0))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n)) orig)) (pt 5 0))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne)) orig)) (pt 10 0))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e)) orig)) (pt 10 5))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se)) orig)) (pt 10 10))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's)) orig)) (pt 5 10))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw)) orig)) (pt 0 10))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w)) orig)) (pt 0 5)))
 
   (test-case
    "inner points with offsets"
-   (define size 10+10i)
-   (define orig 0)
+   (define size (pt 10 10))
+   (define orig (pt 0 0))
    (define off (pt (random 100) (random 100)))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw 'offset off)) orig)) (+ 0 off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n 'offset off)) orig)) (+ 5 off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne 'offset off)) orig)) (+ 10 off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e 'offset off)) orig)) (+ 10+5i off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se 'offset off)) orig)) (+ 10+10i off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's 'offset off)) orig)) (+ 5+10i off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw 'offset off)) orig)) (+ +10i off))
-   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w 'offset off)) orig)) (+ +5i off)))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw 'offset off)) orig)) (pt+ '(0 0) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n 'offset off)) orig)) (pt+ '(5 0) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne 'offset off)) orig)) (pt+ '(10 0) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e 'offset off)) orig)) (pt+ '(10 5) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se 'offset off)) orig)) (pt+ '(10 10) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's 'offset off)) orig)) (pt+ '(5 10) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw 'offset off)) orig)) (pt+ '(0 10) off))
+   (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w 'offset off)) orig)) (pt+ '(0 5) off)))
 
   (test-case
    "folding positions"
-   (check-equal? (position (quad (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad))
-                                 (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad))
-                                 (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad))))
-
-                 (position (quad (quad (hasheq 'size +i 'end 'se 'origin 0) (quad (hasheq 'origin 0))
-                                       (quad (hasheq 'origin 1)) (quad (hasheq 'origin 2)))
-                                 (quad (hasheq 'size +i 'end 'se 'origin +i) (quad (hasheq 'origin +i))
-                                       (quad (hasheq 'origin 1+i)) (quad (hasheq 'origin 2+i)))
-                                 (quad (hasheq 'size +i 'end 'se 'origin +2i) (quad (hasheq 'origin +2i))
-                                       (quad (hasheq 'origin 1+2i)) (quad (hasheq 'origin 2+2i))))))))
+   (check-equal? (position (quad (quad '(end se) (quad) (quad) (quad))
+                                 (quad '(end se) (quad) (quad) (quad))
+                                 (quad '(end se) (quad) (quad) (quad))))
+                 (quad '(origin (0 0))
+                       (quad '(origin (0 0) end se) (quad '(origin (0 0))) (quad '(origin (1 0))) (quad '(origin (2 0))))
+                       (quad '(origin (1 1) end se) (quad '(origin (1 1))) (quad '(origin (2 1))) (quad '(origin (3 1))))
+                       (quad '(origin (2 2) end se) (quad '(origin (2 2))) (quad '(origin (3 2))) (quad '(origin (4 2))))))))

quad/quad/quad.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require racket/match racket/function "generic.rkt")
+(require racket/match racket/function racket/dict "generic.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
@@ -10,9 +10,9 @@
    (define (start q) (hash-ref (attrs q) 'start 'nw))
    (define (end q) (hash-ref (attrs q) 'end 'ne))
    (define (inner q) (hash-ref (attrs q) 'inner (λ () (start q))))
-   (define (size q [condition #f]) (hash-ref (attrs q) 'size 1))
-   (define (offset q [condition #f]) (hash-ref (attrs q) 'offset 0))
-   (define (origin q) (hash-ref (attrs q) 'origin 0))
+   (define (size q [condition #f]) (hash-ref (attrs q) 'size '(1 1)))
+   (define (offset q [condition #f]) (hash-ref (attrs q) 'offset '(0 0)))
+   (define (origin q) (hash-ref (attrs q) 'origin '(0 0)))
    (define (set-origin! q val) (set-$quad-attrs! q (hash-set (attrs q) 'origin val)))
    (define (draw q [surface #f] [origin #f]) ((hash-ref (attrs q) 'draw (λ () (λ () (println "<no draw routine>"))))))])
 
@@ -22,6 +22,9 @@
 (define (quad #:type [type $quad] . xs)
   (match xs
     [(list #f xs ...) (apply quad #:type type (hasheq) xs)]
+    [(list (list (? symbol? sym) rest ...) (? quad-elem? elems) ...) (type (apply hasheq (cons sym rest)) elems)]
+    [(list (? dict? attrs) (? quad-elem? elems) ...) (type (for/hasheq ([(k v) (in-dict attrs)])
+                                                                       (values k v)) elems)]
     [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (type attrs elems)]
     [(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)]
     [else (error 'bad-quad-input)]))