diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 209f4421..092e2319 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -37,8 +37,7 @@ 'CreationDate (seconds->date (if (test-mode) 0 (current-seconds)) #f))]) ;; initialize mixins - (send this initVector) - (inherit-field @ctm) + (inherit-field @ctm) ; from vector (send this initFonts) (inherit-field @font-families) (send this initText) diff --git a/pitfall/pitfall/path.rkt b/pitfall/pitfall/path.rkt index e325fc51..5a98c5c6 100644 --- a/pitfall/pitfall/path.rkt +++ b/pitfall/pitfall/path.rkt @@ -81,6 +81,6 @@ (list (- cx (- px cx) (- cy (- py cy)))))) (send doc quadratic-curve-to . cmd-args)] ;; todo other path ops - [(z) (send doc closePath . cmd-args) + [(z) (send doc close-path . cmd-args) (values sx sy px py sx sy)] [else (raise-argument-error 'apply-commands "valid command name" cmd-name)])))) \ No newline at end of file diff --git a/pitfall/pitfall/vector.rkt b/pitfall/pitfall/vector.rkt index cdd4546d..ab8d6360 100644 --- a/pitfall/pitfall/vector.rkt +++ b/pitfall/pitfall/vector.rkt @@ -18,199 +18,149 @@ (super-new) (field [@ctm default-ctm-value] [@ctm-stack null]) - (as-methods - initVector - save - restore - closePath - line-cap - line-join - line-width - dash - move-to - line-to - bezier-curve-to - quadratic-curve-to - rect - ellipse - circle - polygon - path - _windingRule - fill - stroke - fill-and-stroke - clip - shear - transform - translate - scale))) - - - -(define/contract (initVector this) - (->m void?) - (set-field! @ctm this default-ctm-value) - (set-field! @ctm-stack this null)) - - -(define/contract (save this) - (->m object?) - (push-field! @ctm-stack this (· this @ctm)) - (send this addContent "q")) - - -(define/contract (restore this) - (->m object?) - (set-field! @ctm this (if (pair? (· this @ctm-stack)) - (pop-field! @ctm-stack this) - default-ctm-value)) - (send this addContent "Q")) - - -(define/contract (closePath this) - (->m object?) - (send this addContent "h")) - -(define/contract (line-cap this [c #f]) - ((or/c 'butt 'round 'square #f) . ->m . object?) - (define cap-styles (hasheq 'butt 0 'round 1 'square 2)) - (send this addContent - (format "~a J" (if (symbol? c) - (hash-ref cap-styles c) - "")))) - - -(define/contract (line-join this [j #f]) - ((or/c 'miter 'round 'bevel #f) . ->m . object?) - (define cap-styles (hasheq 'miter 0 'round 1 'bevel 2)) - (send this addContent - (format "~a j" (if (symbol? j) - (hash-ref cap-styles j) - "")))) - - -(define/contract (line-width this w) - (number? . ->m . object?) - (send this addContent (format "~a w" (number w)))) - - -(define/contract (dash this length [options (mhash)]) - (((or/c number? (listof number?) #f)) (hash?) . ->*m . object?) - (cond - [length - (cond - [(list? length) - (send this addContent - (format "[~a] ~a d" - (string-join (map number length) " ") - (hash-ref options 'phase 0)))] - [else - (define space (hash-ref options 'space length)) - (define phase (hash-ref options 'phase 0)) - (send this addContent (format "[~a ~a] ~a d" (number length) (number space) (number phase)))])] - [else this])) - - -(define/contract (move-to this x y) - (number? number? . ->m . object?) - (send this addContent (format "~a ~a m" x y))) - - -(define/contract (line-to this x y) - (number? number? . ->m . object?) - (send this addContent (format "~a ~a l" x y))) - - -(define/contract (bezier-curve-to this cp1x cp1y cp2x cp2y x y) - (number? number? number? number? number? number? . ->m . object?) - (send this addContent (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " ")))) - - -(define/contract (quadratic-curve-to this cpx cpy x y) - (number? number? number? number . ->m . object?) - (send this addContent (format "~a v" (string-join (map number (list cpx cpy x y)) " ")))) + (define/public (save) + (set! @ctm-stack (cons @ctm @ctm-stack)) + (send this addContent "q")) + + (define/public (restore) + (set! @ctm (if (pair? @ctm-stack) + (begin0 + (car @ctm-stack) + (set! @ctm-stack (cdr @ctm-stack))) + default-ctm-value)) + (send this addContent "Q")) + + (define/public (close-path) + (send this addContent "h")) + + (define/public (line-cap [c #f]) + (define cap-styles (hasheq 'butt 0 'round 1 'square 2)) + (send this addContent + (format "~a J" (if (symbol? c) + (hash-ref cap-styles c) + "")))) + + (define/public (line-join [j #f]) + (define cap-styles (hasheq 'miter 0 'round 1 'bevel 2)) + (send this addContent + (format "~a j" (if (symbol? j) + (hash-ref cap-styles j) + "")))) + + (define/public (line-width w) + (send this addContent (format "~a w" (number w)))) + + (define/public (dash length [options (mhash)]) + (cond + [(list? length) + (send this addContent + (format "[~a] ~a d" + (string-join (map number length) " ") + (hash-ref options 'phase 0)))] + [length + (define space (hash-ref options 'space length)) + (define phase (hash-ref options 'phase 0)) + (send this addContent (format "[~a ~a] ~a d" (number length) (number space) (number phase)))] + [else this])) + + (define/public (move-to x y) + (send this addContent (format "~a ~a m" x y))) + + (define/public (line-to x y) + (send this addContent (format "~a ~a l" x y))) + + (define/public (bezier-curve-to cp1x cp1y cp2x cp2y x y) + (send this addContent (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " ")))) + + (define/public (quadratic-curve-to cpx cpy x y) + (send this addContent (format "~a v" (string-join (map number (list cpx cpy x y)) " ")))) - -(define/contract (rect this x y w h) - (number? number? number? number? . ->m . object?) - (send this addContent (format "~a re" (string-join (map number (list x y w h)) " ")))) - -(define/contract (ellipse this x y r1 [r2 r1]) - ((number? number? number?) (number?) . ->*m . object?) - ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084 - ;; This constant is used to approximate a symmetrical arc using a cubic Bezier curve. - (define kappa (* 4 (/ (- (sqrt 2) 1) 3.0))) - (-= x r1) - (-= y r2) - (define ox (* r1 kappa)) ; control point offset horizontal - (define oy (* r2 kappa)) ; control point offset vertical - (define xe (+ x (* r1 2))) ; x-end - (define ye (+ y (* r2 2))) ; y-end - (define xm (+ x r1)) ; x-middle - (define ym (+ y r2)) ; y-middle - (move-to this x ym) - (bezier-curve-to this x (- ym oy) (- xm ox) y xm y) - (bezier-curve-to this (+ xm ox) y xe (- ym oy) xe ym) - (bezier-curve-to this xe (+ ym oy) (+ xm ox) ye xm ye) - (bezier-curve-to this (- xm ox) ye x (+ ym oy) x ym) - (closePath this)) - - -(define/contract (circle this x y radius) - (number? number? number? . ->m . object?) - (ellipse this x y radius)) - - -(define/contract (polygon this . points) - (() () #:rest (listof (list/c number? number?)) . ->*m . object?) - (cond - [(pair? points) - (apply move-to this (car points)) - (for ([pt (in-list (cdr points))]) - (apply line-to this pt)) - (closePath this)] - [else this])) - - -(define/contract (path this path-data) - (string? . ->m . object?) - (parse-svg-path this path-data) - this) - - -(define/contract (_windingRule rule) - ((or/c string? #f) . -> . string?) - (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" "")) - - -(define/contract (fill this [color #f] #:rule [rule #f]) - (() ((or/c color-string? #f) #:rule (or/c string? #f)) . ->*m . object?) - (when color (send this fill-color color)) ;; fill-color method is from color mixin - (send this addContent (format "f~a" (_windingRule rule)))) - - -(define/contract (stroke this [color #f]) - (() ((or/c color-string? #f)) . ->*m . object?) - (when color (send this stroke-color color)) - (send this addContent "S")) - - -(define/contract (fill-and-stroke this [fill #f] [stroke fill] #:rule [rule #f]) - (() ((or/c color-string? #f) (or/c color-string? #f) #:rule (or/c string? #f)) . ->*m . object?) - (when fill (send* this [fill-color fill] [stroke-color stroke])) - (send this addContent (format "B~a" (_windingRule rule)))) - - -(define tm/c (list/c number? number? number? number? number? number?)) -(define/contract (make-transform-string ctm) - (tm/c . -> . string?) - (format "~a cm" (string-join (map number ctm) " "))) - - -(define/contract (combine-transforms m new-ctm) - (tm/c tm/c . -> . tm/c) + (define/public (rect x y w h) + (send this addContent (format "~a re" (string-join (map number (list x y w h)) " ")))) + + (define/public (ellipse x y r1 [r2 r1]) + ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084 + ;; This constant is used to approximate a symmetrical arc using a cubic Bezier curve. + (define kappa (* 4 (/ (- (sqrt 2) 1) 3.0))) + (-= x r1) + (-= y r2) + (define ox (* r1 kappa)) ; control point offset horizontal + (define oy (* r2 kappa)) ; control point offset vertical + (define xe (+ x (* r1 2))) ; x-end + (define ye (+ y (* r2 2))) ; y-end + (define xm (+ x r1)) ; x-middle + (define ym (+ y r2)) ; y-middle + (move-to x ym) + (bezier-curve-to x (- ym oy) (- xm ox) y xm y) + (bezier-curve-to (+ xm ox) y xe (- ym oy) xe ym) + (bezier-curve-to xe (+ ym oy) (+ xm ox) ye xm ye) + (bezier-curve-to (- xm ox) ye x (+ ym oy) x ym) + (close-path)) + + (define/public (circle x y radius) + (ellipse x y radius)) + + (define/public (polygon . points) + (match points + [(cons (list x y) other-points) + (move-to x y) + (for ([pt (in-list other-points)]) + (match pt + [(list x y) + (line-to x y)])) + (close-path)] + [else this])) + + (define/public (path path-data) + (parse-svg-path this path-data) + this) + + (define/public (_windingRule rule) + (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" "")) + + (define/public (fill [color #f] #:rule [rule #f]) + (when color (send this fill-color color)) ;; fill-color method is from color mixin + (send this addContent (format "f~a" (_windingRule rule)))) + + (define/public (stroke [color #f]) + (when color (send this stroke-color color)) + (send this addContent "S")) + + (define/public (fill-and-stroke [fill #f] [stroke fill] #:rule [rule #f]) + (when fill (send* this [fill-color fill] [stroke-color stroke])) + (send this addContent (format "B~a" (_windingRule rule)))) + + (define tm/c (list/c number? number? number? number? number? number?)) + (define/public (make-transform-string ctm) + (format "~a cm" (string-join (map number ctm) " "))) + + (define/public (clip [rule #f]) + (send this addContent (string-append "W" (_windingRule rule) " n"))) + + (define/public (transform scaleX shearY shearX scaleY mdx mdy) + (define new-ctm (list scaleX shearY shearX scaleY mdx mdy)) + (set! @ctm (combine-transforms (· this @ctm) new-ctm)) + (send this addContent (make-transform-string new-ctm))) + + (define/public (shear x y) + (transform 1 y x 1 0 0)) + + (define/public (translate x y) + (transform 1 0 0 1 x y)) + + (define/public scale + (match-lambda* + [(list (? object? this) (? number? x-factor)) (scale x-factor (mhash))] + [(list (? object? this) (? number? xFactor) (? hash? options)) (scale xFactor xFactor options)] + [(list (? object? this) (? number? xFactor) (? number? yFactor)) (scale this xFactor yFactor (mhash))] + [(list (? object? this) (? number? xFactor) (? number? yFactor) (? hash? options)) + (match-define (list x y) + (match-let ([(list xo yo) (hash-ref options 'origin '(0 0))]) + (list (* xo (- 1 xFactor)) (* yo (- 1 yFactor))))) + (transform xFactor 0 0 yFactor x y)])))) + +(define (combine-transforms m new-ctm) (match-define (list m0 m1 m2 m3 m4 m5) m) (match-define (list m11 m12 m21 m22 dx dy) new-ctm) (list (+ (* m0 m11) (* m2 m12)) @@ -220,47 +170,6 @@ (+ (* m0 dx) (* m2 dy) m4) (+ (* m1 dx) (* m3 dy) m5))) - -(define/contract (clip this [rule #f]) - (() ((or/c string? #f)) . ->*m . object?) - (send this addContent (string-append "W" (_windingRule rule) " n"))) - - -(define/contract (transform this scaleX shearY shearX scaleY mdx mdy) - (number? number? number? number? number? number? . ->m . object?) - (define new-ctm (list scaleX shearY shearX scaleY mdx mdy)) - (set-field! @ctm this (combine-transforms (· this @ctm) new-ctm)) - (send this addContent (make-transform-string new-ctm))) - - -(define/contract (shear this x y) - (number? number? . ->m . object?) - (transform this 1 y x 1 0 0)) - - -(define/contract (translate this x y) - (number? number? . ->m . object?) - (transform this 1 0 0 1 x y)) - - -(define/contract scale - (case->m - (number? . -> . object?) - (number? hash? . -> . object?) - (number? number? . -> . object?) - (number? number? hash? . -> . object?)) - (match-lambda* - [(list (? object? this) (? number? xFactor)) (scale xFactor (mhash))] - [(list (? object? this) (? number? xFactor) (? hash? options)) (scale xFactor xFactor options)] - [(list (? object? this) (? number? xFactor) (? number? yFactor)) (scale this xFactor yFactor (mhash))] - [(list (? object? this) (? number? xFactor) (? number? yFactor) (? hash? options)) - (match-define (list x y) - (match-let ([(list xo yo) (hash-ref options 'origin '(0 0))]) - (list (* xo (- 1 xFactor)) (* yo (- 1 yFactor))))) - (transform this xFactor 0 0 yFactor x y)])) - - - (module+ test (require rackunit) (define ctm default-ctm-value) @@ -271,10 +180,7 @@ (check-equal? ctm '(7 10 15 22 28 40)) (set! ctm (combine-transforms ctm ctm2)) (check-equal? ctm '(37 54 81 118 153 222)) - (check-equal? (combine-transforms '(1 0 0 -1 0 792.0) '(1 0 0 1 50 50)) '(1 0 0 -1 50 742.0)) - (check-equal? (combine-transforms '(1 0 0 -1 50 742.0) '(1 0 0 -1 0 792)) - '(1 0 0 1 50 -50.0)) - ) \ No newline at end of file + '(1 0 0 1 50 -50.0))) \ No newline at end of file