diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index 07a02ca4..42afe61e 100644 --- a/pitfall/pitfall/color.rkt +++ b/pitfall/pitfall/color.rkt @@ -1,117 +1,130 @@ #lang pitfall/racket (provide color-mixin) -(define (color-mixin %) +(define (color-mixin [% mixin-tester%]) (class % (super-new) - (field [(@_opacityRegistry _opacityRegistry) #f] - [(@_opacityCount _opacityCount) #f] - [(@_gradCount _gradCount) #f]) + (field [_opacityRegistry #f] + [_opacityCount #f] + [_gradCount #f] + [_fillColor #f]) + + (as-methods + initColor + _normalizeColor + _setColor + _setColorSpace + fillColor + fillOpacity + _doOpacity))) + - (define/public (initColor) - (set! @_opacityRegistry (mhash)) - (set! @_opacityCount 0) - (set! @_gradCount 0)) +(define/contract (initColor this) + (->m void?) + (set-field! _opacityRegistry this (mhash)) + (set-field! _opacityCount this 0) + (set-field! _gradCount this 0)) - ;; parses color string into list of values - (public [@_normalizeColor _normalizeColor]) - (define (@_normalizeColor color) - (cond - #;[(is-a? color PDFGradient) color] ; todo - ;; 3-digit hex becomes 6-digit hex - [(and (string? color) - (regexp-match #px"^#(?i:[0-9A-F]){3}$" color)) - (@_normalizeColor - (list->string (cdr (apply append - (for/list ([c (in-string color)]) - (list c c))))))] - ;; 6-digit hexish string becomes list of hex numbers and maybe #f vals - [(and (string? color) (= 7 (string-length color)) (string-prefix? color "#")) - (@_normalizeColor - (for/list ([str (in-list (regexp-match* #rx".." (string-trim color "#")))]) - (string->number str 16)))] - ;; named color - [(and (string? color) (hash-ref namedColors color #f)) => @_normalizeColor] - ;; array of numbers - [(and (list? color) (andmap number? color)) - (for/list ([i (in-list color)]) - (define x (/ i (case (length color) - [(3) 255.0] ; RGB - [(4) 100.0] ; CMYK - [else 1]))) - (if (integer? x) (inexact->exact x) x))] - [else #f])) - (public [@_setColor _setColor]) - (define (@_setColor color stroke) - (set! color (@_normalizeColor color)) - (define op (if stroke "SCN" "scn")) - (cond - [(not color)] - #;[(is-a? color PDFGradient) - (@_setColorSpace "Pattern" stroke) - (send color apply op) - #t] ; todo - [else - (define space (if (= (length color) 4) - "DeviceCMYK" - "DeviceRGB")) - (@_setColorSpace space stroke) - (set! color (string-join (map number color) " ")) - (send this addContent (format "~a ~a" color op)) - #t])) +(define/contract (_normalizeColor this color) + ((or/c string? (listof number?)) . ->m . (or/c (listof number?) #f)) + ;; parses color string into list of values + (cond + #;[(is-a? color PDFGradient) color] ; todo + ;; 3-digit hex becomes 6-digit hex + [(and (string? color) + (regexp-match #px"^#(?i:[0-9A-F]){3}$" color)) + (_normalizeColor this + (list->string (cdr (apply append + (for/list ([c (in-string color)]) + (list c c))))))] ; change #abc to ##aabbcc then drop the first char + ;; 6-digit hexish string becomes list of hex numbers and maybe #f vals + [(and (string? color) (= 7 (string-length color)) (string-prefix? color "#")) + (_normalizeColor this + (for/list ([str (in-list (regexp-match* #rx".." (string-trim color "#")))]) + (string->number str 16)))] ; match two at a time and convert to hex + ;; named color + [(and (string? color) (hash-ref namedColors color #f)) => (curry _normalizeColor this)] + ;; array of numbers + [(and (list? color) (andmap number? color)) + (for/list ([i (in-list color)]) + (define x (/ i (case (length color) + [(3) 255.0] ; RGB + [(4) 100.0] ; CMYK + [else 1.0]))) + (if (integer? x) (inexact->exact x) x))] + [else #f])) - - (public [@_setColorSpace _setColorSpace]) - (define (@_setColorSpace space stroke) - (define op (if stroke "CS" "cs")) - (send this addContent (format "/~a ~a" space op))) + +(define/contract (_setColor this color stroke) + (color-string? (or/c #f number?) . ->m . boolean?) + (let ([color (_normalizeColor this color)] + [op (if stroke "SCN" "scn")]) + (cond + [(not color)] + #;[(is-a? color PDFGradient) + (_setColorSpace this "Pattern" stroke) + (send color apply op) + #t] ; todo + [else + (define color-space (cond + [(= (length color) 4) "DeviceCMYK"] + [(= (length color) 3) "DeviceRGB"] + [else (raise-argument-error '_setColor "color of length 3 or 4" color)])) + (_setColorSpace this color-space stroke) + (send this addContent (format "~a ~a" (string-join (map number color) " ") op)) + #t]))) - (field ([@_fillColor _fillColor] #f)) - (public [@fillColor fillColor]) - (define (@fillColor color [opacity 1]) - (when (@_setColor color #f) - (@fillOpacity opacity)) +(define (_setColorSpace this space stroke) + ((or/c "DeviceCMYK" "DeviceRGB") (or/c number? #f) . ->m . object?) + (define op (if stroke "CS" "cs")) + (send this addContent (format "/~a ~a" space op))) + + +(define/contract (fillColor this color [opacity 1]) + ((color-string?) ((or/c number? #f)) . ->*m . object?) + (unless (_normalizeColor this color) + (raise-argument-error 'fillColor "valid color string" color)) + (when (_setColor this color #f) (fillOpacity this opacity)) - ;; save this for text wrapper, which needs to reset - ;; the fill color on new pages - (set! @_fillColor (list color opacity)) - this) + ;; save this for text wrapper, which needs to reset + ;; the fill color on new pages + (set-field! _fillColor this (list color opacity)) + this) - (public [@fillOpacity fillOpacity]) - (define (@fillOpacity opacity) - (@_doOpacity opacity #f) - this) +(define/contract (fillOpacity this opacity) + ((or/c number? #f) . ->m . object?) + (_doOpacity this opacity #f) + this) - (public [@_doOpacity doOpacity]) - (define (@_doOpacity fillOpacity strokeOpacity) - (when (or fillOpacity strokeOpacity) - (set! fillOpacity (and fillOpacity (bounded 0 fillOpacity 1))) - (set! strokeOpacity (and strokeOpacity (bounded 0 strokeOpacity 1))) +(define/contract (_doOpacity this fillOpacity strokeOpacity) + ((or/c number? #f) (or/c number? #f) . ->m . object?) + (when (or fillOpacity strokeOpacity) + (set! fillOpacity (and fillOpacity (bounded 0 fillOpacity 1))) + (set! strokeOpacity (and strokeOpacity (bounded 0 strokeOpacity 1))) - (define key (format "~a_~a" - (if fillOpacity (number fillOpacity) "") - (if strokeOpacity (number strokeOpacity) ""))) + (define key (format "~a_~a" + (if fillOpacity (number fillOpacity) "") + (if strokeOpacity (number strokeOpacity) ""))) - (match-define (list dictionary name) - (hash-ref! @_opacityRegistry key - (λ () - (define dictionary (mhash 'Type "ExtGState")) - (when fillOpacity - (hash-set! dictionary 'ca fillOpacity)) - (when strokeOpacity - (hash-set! dictionary 'CA strokeOpacity)) - (define dict-ref (send this ref dictionary)) - (· dict-ref end) - (list dict-ref (format "Gs~a" (++ @_opacityCount)))))) + (match-define (list dictionary name) + (hash-ref! (get-field _opacityRegistry this) key + (λ () + (define dictionary (mhash 'Type "ExtGState")) + (when fillOpacity + (hash-set! dictionary 'ca fillOpacity)) + (when strokeOpacity + (hash-set! dictionary 'CA strokeOpacity)) + (define dict-ref (send this ref dictionary)) + (· dict-ref end) + (list dict-ref (format "Gs~a" (increment-field! _opacityCount this)))))) - (hash-set! (· this page ext_gstates) name dictionary) - (send this addContent (format "/~a gs" name)))) + (hash-set! (· this page ext_gstates) name dictionary) + (send this addContent (format "/~a gs" name)))) - )) (define namedColors (hash "aliceblue" '(240 248 255) @@ -263,13 +276,13 @@ "yellowgreen" '(154 205 50))) -(define c (new (color-mixin object%))) (module+ test (require rackunit) - (check-equal? (send c _normalizeColor "#6699Cc") '(0.4 0.6 0.8)) - (check-false (send c _normalizeColor "#88aaCCC")) - (check-equal? (send c _normalizeColor "#69C") '(0.4 0.6 0.8)) - (check-equal? (send c _normalizeColor "#69c") '(0.4 0.6 0.8)) - (check-false (send c _normalizeColor "#8aCC")) - (check-equal? (send c _normalizeColor "aqua") '(0 1 1))) \ No newline at end of file + (define c (new (color-mixin))) + (check-equal? (_normalizeColor c "#6699Cc") '(0.4 0.6 0.8)) + (check-false (_normalizeColor c "#88aaCCC")) + (check-equal? (_normalizeColor c "#69C") '(0.4 0.6 0.8)) + (check-equal? (_normalizeColor c "#69c") '(0.4 0.6 0.8)) + (check-false (_normalizeColor c "#8aCC")) + (check-equal? (_normalizeColor c "aqua") '(0 1 1))) \ No newline at end of file diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt index 47a418d4..75c628e3 100644 --- a/pitfall/pitfall/helper.rkt +++ b/pitfall/pitfall/helper.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax) 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!) racket/string) (provide (all-defined-out) push! pop!) (define-syntax (· stx) @@ -61,9 +61,20 @@ (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 (push-end-field! field o expr) + (set-field! field o (append (get-field field o) (list expr)))) + (define-syntax-rule (pop-field! field o) (let ([xs (get-field field o)]) (set-field! field o (cdr xs)) (car xs))) +(define-syntax (increment-field! stx) + (syntax-case stx () + [(_ field o) #'(increment-field! field o 1)] + [(_ field o expr) + #'(begin (set-field! field o (+ (get-field field o) expr)) (get-field field o))])) + + (module+ test (define xs '(1 2 3)) @@ -135,4 +146,7 @@ (define (private-id . args) (apply id this args))))])) (define-syntax-rule (as-methods id ...) - (begin (as-method id) ...)) \ No newline at end of file + (begin (as-method id) ...)) + +(define (color-string? x) + (and (string? x) (or (= (string-length x) 4) (= (string-length x) 7)) (string-prefix? x "#"))) \ No newline at end of file diff --git a/pitfall/pitfall/racket.rkt b/pitfall/pitfall/racket.rkt index bd8f7879..5cdaac09 100644 --- a/pitfall/pitfall/racket.rkt +++ b/pitfall/pitfall/racket.rkt @@ -13,10 +13,11 @@ racket/format racket/contract racket/list - racket/port) + racket/port + racket/function) (module reader syntax/module-reader #:language "racket.rkt" - #:read @-read - #:read-syntax @-read-syntax + #: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 8ced91c5..a55d1815 100644 --- a/pitfall/pitfall/reference.rkt +++ b/pitfall/pitfall/reference.rkt @@ -5,64 +5,72 @@ (define PDFReference (class object% (super-new) - (init-field [(@document document)] [(@id id)] [(@data data) (mhash)]) - (field [(@gen gen) 0]) - (field [(@deflate deflate) #f]) - (field [(@compress compress) #f #;debug - #;(and (· @document compress) - (not (hash-ref @data 'Filter #f)))]) - (field [(@uncompressedLength uncompressedLength) 0]) - (field [(@chunks chunks) empty]) + (init-field document id [data (mhash)]) + (field [gen 0] + [deflate #f] + ;; #f is debug value below + [compress (and #f + (· document compress) + (not (hash-ref data 'Filter #f)))] + [uncompressedLength 0] + [chunks empty] + [offset #f]) - (public [@initDeflate initDeflate]) - (define (@initDeflate) - (hash-ref! @data 'Filter "FlateDecode") + (as-methods + initDeflate + write + _write + end + finalize + toString))) - (set! @deflate deflate) - (report 'initDeflate-unimplemented)) +(define/contract (initDeflate this) + (->m void?) + (hash-ref! (· this data) 'Filter "FlateDecode")) - (define/public (write data) - (_write data #f void)) - - (define/public (_write chunk-in encoding callback) - (define chunk (if (isBuffer? chunk-in) - chunk-in - (newBuffer (string-append chunk-in "\n")))) - (+= @uncompressedLength (buffer-length chunk)) - (hash-ref! @data 'Length 0) - (cond - [@compress (when (not @deflate) (@initDeflate)) - (send @deflate write chunk)] - [else (push-end! @chunks chunk) - (hash-update! @data 'Length (λ (len) (+ len (buffer-length chunk))))]) - (callback)) +(define/contract (write this data) + (any/c . ->m . void?) + (send this _write data #f void)) - (define/public (end [chunk #f]) - ; (super) ; todo - (if @deflate - (void) ; todo (deflate-end) - (@finalize))) +(define/contract (_write this chunk-in encoding callback) + (any/c (or/c string? #f) procedure? . ->m . any/c) + (define chunk (if (isBuffer? chunk-in) + chunk-in + (newBuffer (string-append chunk-in "\n")))) + (increment-field! uncompressedLength this (buffer-length chunk)) + (hash-ref! (· this data) 'Length 0) + (cond + #;[(· this compress) (when (not (· this deflate)) (initDeflate)) + (send deflater write chunk)] ; todo: implement compression + [else (push-end-field! chunks this chunk) + (hash-update! (· this data) 'Length (λ (len) (+ len (buffer-length chunk))))]) + (callback)) - (field [(@offset offset) #f]) - (public [@finalize finalize]) - (define (@finalize) - (set! @offset (· @document _offset)) - - (send @document _write (format "~a ~a obj" @id @gen)) - (send @document _write (send (new PDFObject) convert @data)) +(define/contract (end this [chunk #f]) + (() ((or/c any/c #f)) . ->*m . void?) + ; (super) ; todo + (if (· this deflate) + (void) ; todo (deflate-end) + (send this finalize))) - (when (positive? (length @chunks)) - (send @document _write "stream") - (for ([chunk (in-list @chunks)]) - (send @document _write chunk)) +(define/contract (finalize this) + (->m void?) + (set-field! offset this (· this document _offset)) + + (send (· this document) _write (format "~a ~a obj" (· this id) (· this gen))) + (send (· this document) _write (send (new PDFObject) convert (· this data))) - (set! @chunks null) ; free up memory - (send @document _write "\nendstream")) + (when (positive? (length (· this chunks))) + (send (· this document) _write "stream") + (for ([chunk (in-list (· this chunks))]) + (send (· this document) _write chunk)) - (send @document _write "endobj") - (send @document _refEnd this)) + (set-field! chunks this null) ; free up memory + (send (· this document) _write "\nendstream")) - (define/public (toString) - (format "~a ~a R" @id @gen)) + (send (· this document) _write "endobj") + (send (· this document) _refEnd this)) - )) +(define/contract (toString this) + (->m string?) + (format "~a ~a R" (· this id) (· this gen))) diff --git a/pitfall/pitfall/test/test1.rkt b/pitfall/pitfall/test/test1.rkt index fa1e2e9c..0bf78f83 100644 --- a/pitfall/pitfall/test/test1.rkt +++ b/pitfall/pitfall/test/test1.rkt @@ -9,19 +9,18 @@ ;; Create a new PDFDocument (test-mode #t) (check-true - (let () - (define doc (new PDFDocument)) + (let ([doc (new PDFDocument)]) (send doc pipe (open-output-file this #:exists 'replace)) - ;; Draw a triangle and a circle - (send*/fold doc [save] - [moveTo 100 150] - [lineTo 100 250] - [lineTo 200 250] - [fill "#FF3300"]) - - (send*/fold doc [circle 280 200 50] [fill "#6600FF"]) - + (send* doc + [save] + [moveTo 100 150] + [lineTo 100 250] + [lineTo 200 250] + [fill "#FF3300"]) + (send* doc + [circle 280 200 50] + [fill "#6600FF"]) (send doc end))) (check-equal? (file->bytes this) (file->bytes control)) \ No newline at end of file diff --git a/pitfall/pitfall/vector.rkt b/pitfall/pitfall/vector.rkt index 1bf3ea95..1dfb3023 100644 --- a/pitfall/pitfall/vector.rkt +++ b/pitfall/pitfall/vector.rkt @@ -89,7 +89,7 @@ (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" "")) (define/contract (fill this color [rule #f]) - ((string?) ((or/c string? #f)) . ->*m . object?) + ((color-string?) ((or/c string? #f)) . ->*m . object?) (when (regexp-match #rx"^(even-?odd)|(non-?zero)$" color) (set! rule color) (set! color #f))