From c44aafe1e5b4ae81eb0ee6a310c8e9af53e380a5 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 18 May 2017 11:44:59 -0700 Subject: [PATCH] start deflation --- pitfall/pitfall/document.rkt | 122 ++++++++++++++++----------------- pitfall/pitfall/helper.rkt | 7 +- pitfall/pitfall/image.rkt | 1 + pitfall/pitfall/jpeg.rkt | 1 + pitfall/pitfall/object.rkt | 1 + pitfall/pitfall/png.rkt | 8 +++ pitfall/pitfall/test/test0.rkt | 4 +- pitfall/pitfall/test/test1.rkt | 2 +- pitfall/pitfall/test/test4.rkt | 2 +- pitfall/pitfall/zlib.rkt | 30 ++++++++ 10 files changed, 111 insertions(+), 67 deletions(-) create mode 100644 pitfall/pitfall/jpeg.rkt create mode 100644 pitfall/pitfall/png.rkt create mode 100644 pitfall/pitfall/zlib.rkt diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 50ff1b8d..da3cb1d7 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -5,68 +5,66 @@ (define mixed% (image-mixin (text-mixin (fonts-mixin (color-mixin (vector-mixin object%)))))) -(define PDFDocument - (class mixed% ; actually is an instance of readable.Stream, which is an input port - (init-field [options (mhash)]) - (super-new) - - (field [byte-strings empty] ; list of byte chunks to push onto; simulates interface of stream.readable - [version 1.3] ; PDF version - [compress (hash-ref options 'compress #t)] ; Whether streams should be compressed - [_pageBuffer null] - [_pageBufferStart 0] - [_offsets null] ; The PDF object store - [_waiting 0] - [_ended #f] - [_offset 0] - [_root (ref this - (mhash 'Type "Catalog" - 'Pages (ref this - (mhash 'Type "Pages" - 'Count 0 - 'Kids empty))))] ; top object - [page #f] ; The current page - [x 0] - [y 0] - [info (mhash - 'Producer "PitfallKit" - 'Creator "PitfallKit" - 'CreationDate (seconds->date (if (test-mode) - 0 - (current-seconds)) #f))] ; Initialize the metadata - [op #f] ; for `pipe` - [_info #f]) ; for `end` - - ;; Initialize mixins - (· this initColor) - (· this initVector) - (· this initFonts) - (· this initText) - ;(· this initImages) - - (as-methods - addPage - flushPages - ref - push - _write - addContent - _refEnd - pipe - end - _finalize) - - (for ([(key val) (in-hash (hash-ref options 'info (hash)))]) ; if no 'info key, nothing will be copied from (hash) - (hash-set! info key val)) - - ;; Write the header - (_write this (format "%PDF-~a" version)) ; PDF version - (let ([c (integer->char #xFF)]) - (_write this (string-append "%" (string c c c c)))) ; 4 binary chars, as recommended by the spec - - ;; Add the first page - (unless (not (hash-ref options 'autoFirstPage #t)) - (addPage this)))) +(define-subclass mixed% (PDFDocument [options (mhash)]) + (super-new) + + (field [byte-strings empty] ; list of byte chunks to push onto; simulates interface of stream.readable + [version 1.3] ; PDF version + [compress (hash-ref options 'compress #t)] ; Whether streams should be compressed + [_pageBuffer null] + [_pageBufferStart 0] + [_offsets null] ; The PDF object store + [_waiting 0] + [_ended #f] + [_offset 0] + [_root (ref this + (mhash 'Type "Catalog" + 'Pages (ref this + (mhash 'Type "Pages" + 'Count 0 + 'Kids empty))))] ; top object + [page #f] ; The current page + [x 0] + [y 0] + [info (mhash + 'Producer "PitfallKit" + 'Creator "PitfallKit" + 'CreationDate (seconds->date (if (test-mode) + 0 + (current-seconds)) #f))] ; Initialize the metadata + [op #f] ; for `pipe` + [_info #f]) ; for `end` + + ;; Initialize mixins + (· this initColor) + (· this initVector) + (· this initFonts) + (· this initText) + ;(· this initImages) + + (as-methods + addPage + flushPages + ref + push + _write + addContent + _refEnd + pipe + end + _finalize) + + (for ([(key val) (in-hash (hash-ref options 'info (hash)))]) ; if no 'info key, nothing will be copied from (hash) + (hash-set! info key val)) + + ;; Write the header + (_write this (format "%PDF-~a" version)) ; PDF version + (let ([c (integer->char #xFF)]) + (_write this (string-append "%" (string c c c c)))) ; 4 binary chars, as recommended by the spec + + ;; Add the first page + (unless (not (hash-ref options 'autoFirstPage #t)) + (addPage this))) (define/contract (addPage this [options-arg (· this options)]) diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt index 5f05e170..d8eac67f 100644 --- a/pitfall/pitfall/helper.rkt +++ b/pitfall/pitfall/helper.rkt @@ -163,4 +163,9 @@ (and (string? x) (if (string-prefix? x "#") (or (= (string-length x) 4) (= (string-length x) 7)) - #t))) \ No newline at end of file + #t))) + +(define-syntax-rule (define-subclass CLASS-ID (SUBCLASS-ID INIT-FIELD ...) . EXPRS) + (define SUBCLASS-ID + (class CLASS-ID + (init-field INIT-FIELD ...) . EXPRS))) \ No newline at end of file diff --git a/pitfall/pitfall/image.rkt b/pitfall/pitfall/image.rkt index ae3fe392..384b1201 100644 --- a/pitfall/pitfall/image.rkt +++ b/pitfall/pitfall/image.rkt @@ -1,4 +1,5 @@ #lang pitfall/racket +(require "jpeg.rkt" "png.rkt") (provide PDFImage) (define PDFImage diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt new file mode 100644 index 00000000..110c0f21 --- /dev/null +++ b/pitfall/pitfall/jpeg.rkt @@ -0,0 +1 @@ +#lang pitfall/racket diff --git a/pitfall/pitfall/object.rkt b/pitfall/pitfall/object.rkt index 7a4d1822..0e9d30ae 100644 --- a/pitfall/pitfall/object.rkt +++ b/pitfall/pitfall/object.rkt @@ -35,6 +35,7 @@ ;; Convert little endian UTF-16 to big endian ;; endianness of `bytes-open-converter` is relative to platform, so little endian on all x86 +;; can detect with `system-big-endian?` (define/contract (utf8->utf16 bytes) (bytes? . -> . bytes?) (define-values (bs bslen bsresult) diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt new file mode 100644 index 00000000..ebac16fc --- /dev/null +++ b/pitfall/pitfall/png.rkt @@ -0,0 +1,8 @@ +#lang pitfall/racket +(require racket/draw/unsafe/png) + +(define PNGImage + (class object% + (init-field data label) + (field [image 'newPngobject] + [width '()]))) diff --git a/pitfall/pitfall/test/test0.rkt b/pitfall/pitfall/test/test0.rkt index 19368075..100f481e 100644 --- a/pitfall/pitfall/test/test0.rkt +++ b/pitfall/pitfall/test/test0.rkt @@ -3,8 +3,8 @@ (check-true (let () - (define doc (new PDFDocument)) + (define doc (make-object PDFDocument (hash 'compress #f))) (send doc pipe (open-output-file this #:exists 'replace)) (send doc end))) -(check-copy-equal? this) \ No newline at end of file +;(check-copy-equal? this) \ No newline at end of file diff --git a/pitfall/pitfall/test/test1.rkt b/pitfall/pitfall/test/test1.rkt index e96435d9..ee56a92d 100644 --- a/pitfall/pitfall/test/test1.rkt +++ b/pitfall/pitfall/test/test1.rkt @@ -2,7 +2,7 @@ (define-runtime-path this "test1rkt.pdf") (check-true - (let ([doc (new PDFDocument)]) + (let ([doc (make-object PDFDocument (hash 'compress #f))]) (send doc pipe (open-output-file this #:exists 'replace)) ;; Draw a triangle and a circle diff --git a/pitfall/pitfall/test/test4.rkt b/pitfall/pitfall/test/test4.rkt index 256d2dc2..ecf2d2e9 100644 --- a/pitfall/pitfall/test/test4.rkt +++ b/pitfall/pitfall/test/test4.rkt @@ -2,7 +2,7 @@ (define-runtime-path this "test4rkt.pdf") (check-true - (let ([doc (new PDFDocument)]) + (let ([doc (make-object PDFDocument (hash 'compress #f))]) (send doc pipe (open-output-file this #:exists 'replace)) (send* doc diff --git a/pitfall/pitfall/zlib.rkt b/pitfall/pitfall/zlib.rkt new file mode 100644 index 00000000..bdd74840 --- /dev/null +++ b/pitfall/pitfall/zlib.rkt @@ -0,0 +1,30 @@ +#lang pitfall/racket +(provide deflate inflate) + +;; see https://groups.google.com/d/topic/racket-users/3CvjHLAmwSQ/discussion +;; for discrepancies between gzip gunzip and zlib + +(require (prefix-in gzip: file/gzip) + (prefix-in gunzip: file/gunzip) png-image) + +(define (deflate bstr) + ;; https://www.ietf.org/rfc/rfc1950.txt + (define rfc-1950-header (bytes #x78 #x9c)) + (define op (open-output-bytes)) + (gzip:deflate (open-input-bytes bstr) op) + (bytes-append rfc-1950-header + (get-output-bytes op) + (integer->integer-bytes (bytes-adler32 bstr) 4 #f 'want-big-endian))) + +(define (inflate bstr) + (define op (open-output-bytes)) + (gunzip:inflate (open-input-bytes (subbytes bstr 2)) op) + (get-output-bytes op)) + +(module+ test + (require rackunit) + (for ([i (in-range 100)]) + (define random-bytes + (apply bytes (for/list ([bidx (in-range 100)]) + (random 256)))) + (check-equal? random-bytes (inflate (deflate random-bytes))))) \ No newline at end of file