From ab97bb55c38d364cf7dec954460c074b1c20ca95 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 17 Feb 2018 16:46:22 -0800 Subject: [PATCH] cleanse --- quad/quad/draw.rkt | 21 +++++++ quad/quad/position.rkt | 135 +++++++++++++++++++---------------------- quad/quad/quad.rkt | 11 ++-- 3 files changed, 89 insertions(+), 78 deletions(-) create mode 100644 quad/quad/draw.rkt diff --git a/quad/quad/draw.rkt b/quad/quad/draw.rkt new file mode 100644 index 00000000..ea84d966 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index 56061dd2..e861d9f8 100644 --- a/quad/quad/position.rkt +++ b/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)))))))) \ No newline at end of file + (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)))))))) \ No newline at end of file diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index b0d2de6f..0b6a1e4d 100644 --- a/quad/quad/quad.rkt +++ b/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 ""))))))]) @@ -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)]))