From b63147ddfd98b3d8e8c0617bab5a34d7fa4de620 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 14 May 2017 15:32:16 -0700 Subject: [PATCH] simplify notation --- pitfall/pitfall/alltest.rkt | 5 + pitfall/pitfall/buffer.rkt | 2 +- pitfall/pitfall/color.rkt | 5 +- pitfall/pitfall/document.rkt | 4 +- pitfall/pitfall/helper.rkt | 23 ++- pitfall/pitfall/object.rkt | 5 +- pitfall/pitfall/page.rkt | 5 +- pitfall/pitfall/racket.rkt | 22 ++ pitfall/pitfall/reference.rkt | 4 +- pitfall/pitfall/struct.rkt | 2 +- pitfall/pitfall/{test => }/test-all.rkt | 0 pitfall/pitfall/test-helper.rkt | 7 - pitfall/pitfall/vector.rkt | 259 ++++++++++++------------ 13 files changed, 182 insertions(+), 161 deletions(-) create mode 100644 pitfall/pitfall/alltest.rkt create mode 100644 pitfall/pitfall/racket.rkt rename pitfall/pitfall/{test => }/test-all.rkt (100%) delete mode 100644 pitfall/pitfall/test-helper.rkt diff --git a/pitfall/pitfall/alltest.rkt b/pitfall/pitfall/alltest.rkt new file mode 100644 index 00000000..a744e552 --- /dev/null +++ b/pitfall/pitfall/alltest.rkt @@ -0,0 +1,5 @@ +#lang racket +(module+ test + (require pitfall/test/test0 + pitfall/test/test1 + pitfall/page-test)) \ No newline at end of file diff --git a/pitfall/pitfall/buffer.rkt b/pitfall/pitfall/buffer.rkt index 51af2e68..a2a56f71 100644 --- a/pitfall/pitfall/buffer.rkt +++ b/pitfall/pitfall/buffer.rkt @@ -1,4 +1,4 @@ -#lang br +#lang pitfall/racket ;; nodejs Buffer object = Racket byte string diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index 5d227b5f..07a02ca4 100644 --- a/pitfall/pitfall/color.rkt +++ b/pitfall/pitfall/color.rkt @@ -1,8 +1,5 @@ -#lang racket/base -(require racket/class racket/string racket/match) +#lang pitfall/racket (provide color-mixin) -(require sugar/debug) -(require "helper.rkt") (define (color-mixin %) (class % diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 3c8e42ac..2f35d5f9 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -1,6 +1,4 @@ -#lang sugar/debug racket/base -(require racket/class racket/draw racket/list racket/format racket/port) -(require sugar/debug) +#lang pitfall/racket (provide PDFDocument) (require "reference.rkt" "struct.rkt" "object.rkt" "page.rkt" "helper.rkt" "params.rkt") diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt index e3cd76fd..47a418d4 100644 --- a/pitfall/pitfall/helper.rkt +++ b/pitfall/pitfall/helper.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-syntax racket/base) racket/class sugar/list racket/list (only-in br/list push! pop!)) +(require (for-syntax racket/base racket/syntax) racket/class sugar/list racket/list (only-in br/list push! pop!)) (provide (all-defined-out) push! pop!) (define-syntax (· stx) @@ -42,7 +42,7 @@ (define (listify kvs) (for/list ([slice (in-list (slice-at kvs 2))]) - (cons (first slice) (second slice)))) + (cons (first slice) (second slice)))) (define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs)))) (define-hashifier mhash make-hash) (define-hashifier mhasheq make-hasheq) @@ -60,6 +60,11 @@ ;; js-style `push`, which appends to end of list (define-syntax-rule (push-end! id thing) (set! id (append id (list thing)))) +(define-syntax-rule (push-field! field o expr) (set-field! field o (cons expr (get-field field o)))) +(define-syntax-rule (pop-field! field o) (let ([xs (get-field field o)]) + (set-field! field o (cdr xs)) + (car xs))) + (module+ test (define xs '(1 2 3)) (push-end! xs 4) @@ -117,9 +122,17 @@ (define-syntax-rule (test-when cond expr) (if cond (raise-test-exn expr) expr)) - - (define mixin-tester% (class object% (super-new) - (define/public (addContent val) val))) \ No newline at end of file + (define/public (addContent val) val))) + +(define-syntax (as-method stx) + (syntax-case stx () + [(_ id) (with-syntax ([private-id (generate-temporary #'id)]) + #'(begin + (public [private-id id]) + (define (private-id . args) (apply id this args))))])) + +(define-syntax-rule (as-methods id ...) + (begin (as-method id) ...)) \ No newline at end of file diff --git a/pitfall/pitfall/object.rkt b/pitfall/pitfall/object.rkt index e8b1c1ab..4b34475b 100644 --- a/pitfall/pitfall/object.rkt +++ b/pitfall/pitfall/object.rkt @@ -1,6 +1,5 @@ -#lang at-exp br -(require racket/class racket/string racket/list srfi/19) -(require "struct.rkt" "helper.rkt") +#lang pitfall/racket +(require srfi/19) (provide PDFObject) (define PDFObject diff --git a/pitfall/pitfall/page.rkt b/pitfall/pitfall/page.rkt index ba8ebf17..70692093 100644 --- a/pitfall/pitfall/page.rkt +++ b/pitfall/pitfall/page.rkt @@ -1,9 +1,6 @@ -#lang racket/base -(require sugar/debug) -(require racket/class "helper.rkt") +#lang pitfall/racket (provide PDFPage) - (define PDFPage (class object% (super-new) diff --git a/pitfall/pitfall/racket.rkt b/pitfall/pitfall/racket.rkt new file mode 100644 index 00000000..bd8f7879 --- /dev/null +++ b/pitfall/pitfall/racket.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(provide (all-from-out racket/base)) + +(define-syntax-rule (r+p id ...) (begin (require id ...) (provide (all-from-out id ...)))) + +(r+p "helper.rkt" + "params.rkt" + "struct.rkt" + sugar/debug + racket/class + racket/match + racket/string + racket/format + racket/contract + racket/list + racket/port) + +(module reader syntax/module-reader + #:language "racket.rkt" + #:read @-read + #:read-syntax @-read-syntax + (require (prefix-in @- scribble/reader))) \ No newline at end of file diff --git a/pitfall/pitfall/reference.rkt b/pitfall/pitfall/reference.rkt index 9d023ead..8ced91c5 100644 --- a/pitfall/pitfall/reference.rkt +++ b/pitfall/pitfall/reference.rkt @@ -1,5 +1,5 @@ -#lang br -(require "helper.rkt" "object.rkt" file/gzip) +#lang pitfall/racket +(require "object.rkt") (provide PDFReference) (define PDFReference diff --git a/pitfall/pitfall/struct.rkt b/pitfall/pitfall/struct.rkt index e60cabff..780bba8b 100644 --- a/pitfall/pitfall/struct.rkt +++ b/pitfall/pitfall/struct.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (provide (struct-out String)) ;; use structs to sub for missing node types diff --git a/pitfall/pitfall/test/test-all.rkt b/pitfall/pitfall/test-all.rkt similarity index 100% rename from pitfall/pitfall/test/test-all.rkt rename to pitfall/pitfall/test-all.rkt diff --git a/pitfall/pitfall/test-helper.rkt b/pitfall/pitfall/test-helper.rkt deleted file mode 100644 index 8e62bcdd..00000000 --- a/pitfall/pitfall/test-helper.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base -(require rackunit pitfall/helper) -(provide (all-defined-out)) - -(define-syntax-rule (check-exn-equal? expr val) - (check-equal? (with-handlers ([exn:pitfall:test? (λ (e) (exn:pitfall:test-data e))]) - expr) val)) \ No newline at end of file diff --git a/pitfall/pitfall/vector.rkt b/pitfall/pitfall/vector.rkt index a708fe89..1bf3ea95 100644 --- a/pitfall/pitfall/vector.rkt +++ b/pitfall/pitfall/vector.rkt @@ -1,40 +1,110 @@ -#lang racket/base -(require racket/class racket/match racket/string racket/format racket/contract) -(require "helper.rkt" "params.rkt") -(provide (contract-out - [vector-mixin (class? . -> . - (class/c [initVector (->m void?)] - [save (->m object?)] - [restore (->m object?)] - [closePath (->m object?)] - [moveTo (number? number? . ->m . object?)] - [lineTo (number? number? . ->m . object?)] - [bezierCurveTo ( number? number? number? number? number? number? . ->m . object?)] - [ellipse ((number? number? number?) (number?) . ->*m . object?)] - [circle (number? number? number? . ->m . object?)] - [_windingRule (string? . ->m . string?)] - [fill ((string?) ((or/c string? #f)) . ->*m . object?)] - [transform (number? number? number? number? number? number? . ->m . object?)] - [translate (number? number? . ->m . object?)] - [scale (case->m - (number? . -> . object?) - (number? hash? . -> . object?) - (number? number? . -> . object?) - (number? number? hash? . -> . object?))]))])) - - -;; This constant is used to approximate a symmetrical arc using a cubic -;; Bezier curve. -(define kappa (* 4 (/ (- (sqrt 2) 1) 3.0))) +#lang pitfall/racket +(provide vector-mixin) + +(define (vector-mixin [% mixin-tester%]) + (class % + (super-new) + (field [_ctm default-ctm-value] + [_ctmStack null]) + (as-methods + initVector + save + restore + closePath + lineTo + moveTo + bezierCurveTo + ellipse + circle + _windingRule + fill + transform + translate + scale) + (define/public (path pth) this) ;; SVGPath.apply this, path ; todo + )) + (define default-ctm-value '(1 0 0 1 0 0)) -(define (make-transform-string ctm) +(define/contract (initVector this) + (->m void?) + (set-field! _ctm this default-ctm-value) + (set-field! _ctmStack this null)) + +(define/contract (save this) + (->m object?) + (push-field! _ctmStack this (· this _ctm)) + (send this addContent "q")) + +(define/contract (restore this) + (->m object?) + (set-field! _ctm this (if (pair? (· this _ctmStack)) + (pop-field! _ctmStack this) + default-ctm-value)) + (send this addContent "Q")) + +(define/contract (closePath this) + (->m object?) + (send this addContent "h")) + +(define/contract (moveTo this x y) + (number? number? . ->m . object?) + (send this addContent (format "~a ~a m" x y))) + +(define/contract (lineTo this x y) + (number? number? . ->m . object?) + (send this addContent (format "~a ~a l" x y))) + +(define/contract (bezierCurveTo 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 (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 + (moveTo this x ym) + (bezierCurveTo this x (- ym oy) (- xm ox) y xm y) + (bezierCurveTo this (+ xm ox) y xe (- ym oy) xe ym) + (bezierCurveTo this xe (+ ym oy) (+ xm ox) ye xm ye) + (bezierCurveTo 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 (_windingRule this rule) + ((or/c string? #f) . ->m . string?) + (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" "")) + +(define/contract (fill this color [rule #f]) + ((string?) ((or/c string? #f)) . ->*m . object?) + (when (regexp-match #rx"^(even-?odd)|(non-?zero)$" color) + (set! rule color) + (set! color #f)) + (when color (send this fillColor color)) ;; fillColor method is from color mixin + (send this addContent (format "f~a" (_windingRule this 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 (combine-transforms n-transform m-transform) - (match-define (list n11 n12 n21 n22 ndx ndy) n-transform) +(define/contract (combine-transforms m-transform n-transform) + (tm/c tm/c . -> . tm/c) (match-define (list m11 m12 m21 m22 mdx mdy) m-transform) + (match-define (list n11 n12 n21 n22 ndx ndy) n-transform) (list (+ (* n11 m11) (* n21 m12)) (+ (* n12 m11) (* n22 m12)) (+ (* n11 m21) (* n21 m22)) @@ -42,106 +112,33 @@ (+ (* n11 mdx) (* n21 mdy) ndx) (+ (* n12 mdx) (* n22 mdy) ndy))) -(define (vector-mixin [% mixin-tester%]) - (class % - (super-new) - (field [(@_ctm _ctm) default-ctm-value] - [(@_ctmStack _ctmStack) null]) - - (define/public (initVector) - (set! @_ctm default-ctm-value) - (set! @_ctmStack null)) - - (define/public (save) - (push! @_ctmStack @_ctm) - (send this addContent "q")) - - (define/public (restore) - (set! @_ctm (if (pair? @_ctmStack) (pop! @_ctmStack) default-ctm-value)) - (send this addContent "Q")) - - (public [@closePath closePath]) - (define (@closePath) - (send this addContent "h")) - - (public [@moveTo moveTo]) - (define (@moveTo x y) - (send this addContent (format "~a ~a m" x y))) - - (public [@lineTo lineTo]) - (define (@lineTo x y) - (send this addContent (format "~a ~a l" x y))) - - - (public [@bezierCurveTo bezierCurveTo]) - (define (@bezierCurveTo cp1x cp1y cp2x cp2y x y) - (send this addContent (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " ")))) - - - (public [@ellipse ellipse]) - (define (@ellipse x y r1 [r2 r1]) - ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084 - (-= 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 - (@moveTo x ym) - (@bezierCurveTo x (- ym oy) (- xm ox) y xm y) - (@bezierCurveTo (+ xm ox) y xe (- ym oy) xe ym) - (@bezierCurveTo xe (+ ym oy) (+ xm ox) ye xm ye) - (@bezierCurveTo (- xm ox) ye x (+ ym oy) x ym) - (@closePath)) - - - (public [@circle circle]) - (define (@circle x y radius) - (@ellipse x y radius)) - - - (public [@path path]) - (define (@path path) - ;; SVGPath.apply this, path ; todo - this) - - (public [@_windingRule _windingRule]) - (define (@_windingRule rule) - (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" "")) - - (define/public (fill color [rule #f]) - (when (regexp-match #rx"^(even-?odd)|(non-?zero)$" color) - (set! rule color) - (set! color #f)) - (when color (send this fillColor color)) ;; fillColor method is from color mixin - (send this addContent (format "f~a" (@_windingRule rule)))) - - (public [@transform transform]) - (define (@transform . new-ctm) - ;; keep track of the current transformation matrix - (set! @_ctm (combine-transforms @_ctm new-ctm)) - (send this addContent (make-transform-string new-ctm))) - - - (public [@translate translate]) - (define (@translate x y) - (@transform 1 0 0 1 x y)) - - (public [@scale scale]) - (define @scale - (match-lambda* - [(list (? number? xFactor)) (@scale xFactor (mhash))] - [(list (? number? xFactor) (? hash? options)) (@scale xFactor xFactor options)] - [(list (? number? xFactor) (? number? yFactor)) (@scale xFactor yFactor (mhash))] - [(list (? 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/contract (transform this m11 m12 m21 m22 mdx mdy) + (number? number? number? number? number? number? . ->m . object?) + (define new-ctm (list m11 m12 m21 m22 mdx mdy)) + (set-field! _ctm this (combine-transforms (· this _ctm) new-ctm)) + (send this addContent (make-transform-string new-ctm))) + +(define/contract (translate this x y) + (number? number? . ->m . object?) + (transform this (list 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)