simplify notation

pitfall/pitfall/alltest.rkt

@@ -0,0 +1,5 @@
+#lang racket
+(module+ test
+  (require pitfall/test/test0
+           pitfall/test/test1
+           pitfall/page-test))

pitfall/pitfall/buffer.rkt

@@ -1,4 +1,4 @@
-#lang br
+#lang pitfall/racket
 
 ;; nodejs Buffer object = Racket byte string
 

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 %

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

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)))
+    (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) ...))

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

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)

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

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

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

pitfall/pitfall/test-helper.rkt

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

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)