diff --git a/pitfall/binparser/main.rkt b/pitfall/binparser/main.rkt index e9e64815..ced55ef5 100644 --- a/pitfall/binparser/main.rkt +++ b/pitfall/binparser/main.rkt @@ -31,18 +31,24 @@ (raise (binary-problem (format "byte string length ~a" count) bs))) bs) -(define (bytes->integer len x) +(define (bytes->integer len x #:endian [big-endian? #f]) (when (< (bytes-length x) len) (raise-argument-error 'bytes->integer "too short" x)) (cond [(= len 1) (bytes-ref x 0)] - [else (integer-bytes->integer x #f #f)])) + [else (define signed #f) + (integer-bytes->integer x signed big-endian?)])) -(define (integer->bytes len x) +(define (integer->bytes len x #:endian [big-endian? #f]) (case len [(1) (bytes x)] - [(2 4 8) (integer->integer-bytes x len #f #f)] + [(2 4 8) (define signed #f) + (integer->integer-bytes x len signed big-endian?)] [else (raise-argument-error 'integer->bytes "byte length 1 2 4 8" len)])) +(define integer/be? #t) +(define (integer/be->bytes len x) (integer->bytes len x #:endian #t)) +(define (bytes->integer/be len x) (bytes->integer len x #:endian #t)) + (require racket/format) (define (hex? x) (and (list? x) (andmap string? x))) (define (int->hex int) (~r int #:base 16 #:min-width 2 #:pad-string "0")) @@ -134,6 +140,8 @@ (λ (x) (define-values (input-proc output-proc) (case-proc type + [integer/be? (values (curry bytes->integer/be count) + (curry integer/be->bytes count))] [integer? (values (curry bytes->integer count) (curry integer->bytes count))] [string/ascii? (values bytes->ascii ascii->bytes)] diff --git a/pitfall/pitfall/clone.rkt b/pitfall/pitfall/clone.rkt new file mode 100644 index 00000000..86152e6b --- /dev/null +++ b/pitfall/pitfall/clone.rkt @@ -0,0 +1,6 @@ +#lang racket +(provide cloneDeep) + +(define (cloneDeep val) + (parameterize ([print-graph #t]) + (read (open-input-string (~s val))))) \ No newline at end of file diff --git a/pitfall/pitfall/directory.rkt b/pitfall/pitfall/directory.rkt index d1a84583..b08317cb 100644 --- a/pitfall/pitfall/directory.rkt +++ b/pitfall/pitfall/directory.rkt @@ -1,5 +1,60 @@ #lang pitfall/racket (provide (all-defined-out)) -(define (directory-decode . xs) - 'boom) \ No newline at end of file +(require binparser) + +(define uint32be (:bytes 4 #:type integer/be?)) +(define uint16be (:bytes 2 #:type integer/be?)) +(define hexbytes (:bytes 4 #:type hex?)) +(define (string-rule count) (:bytes count #:type string/ascii?)) + +(define-macro (:seq ([ID BINDING] ...) . BODY) + #'(λ (p) (let* ([ID (BINDING p)] ...) (begin . BODY) (list (cons 'ID ID) ...)))) + +(define TableEntry (:seq + ([tag (string-rule 4)] + [checkSum uint32be] + [offset uint32be] + [length uint32be]))) + +(define Directory (:seq + ([tag hexbytes] + [numTables uint16be] + [searchRange uint16be] + [entrySelector uint16be] + [rangeShift uint16be] + [tables (:repeat numTables TableEntry)]) + (unless (equal? tag "00 01 00 00") + (error 'epic-fail)))) + +(define (directory-decode ip [options (mhash)]) + (Directory ip)) + + +(define ip (open-input-file "test/assets/Charter.ttf")) +(directory-decode ip (mhash '_startOffset 0)) +(module+ test + (require rackunit) + (define ip (open-input-file "test/assets/Charter.ttf")) + (check-equal? + (directory-decode ip (mhash '_startOffset 0)) + '((tag . "00 01 00 00") + (numTables . 14) + (searchRange . 128) + (entrySelector . 3) + (rangeShift . 96) + (tables + ((tag . "OS/2") (checkSum . 2351070438) (offset . 360) (length . 96)) + ((tag . "VDMX") (checkSum . 1887795202) (offset . 1372) (length . 1504)) + ((tag . "cmap") (checkSum . 1723761408) (offset . 2876) (length . 1262)) + ((tag . "cvt ") (checkSum . 10290865) (offset . 4592) (length . 26)) + ((tag . "fpgm") (checkSum . 106535991) (offset . 4140) (length . 371)) + ((tag . "glyf") (checkSum . 1143629849) (offset . 4620) (length . 34072)) + ((tag . "head") (checkSum . 4281190895) (offset . 236) (length . 54)) + ((tag . "hhea") (checkSum . 132056097) (offset . 292) (length . 36)) + ((tag . "hmtx") (checkSum . 3982043058) (offset . 456) (length . 916)) + ((tag . "loca") (checkSum . 2795817194) (offset . 38692) (length . 460)) + ((tag . "maxp") (checkSum . 50135594) (offset . 328) (length . 32)) + ((tag . "name") (checkSum . 2629707307) (offset . 39152) (length . 2367)) + ((tag . "post") (checkSum . 1670855689) (offset . 41520) (length . 514)) + ((tag . "prep") (checkSum . 490862356) (offset . 4512) (length . 78)))))) \ No newline at end of file diff --git a/pitfall/pitfall/fontkit.rkt b/pitfall/pitfall/fontkit.rkt index eca555f7..631ddf8b 100644 --- a/pitfall/pitfall/fontkit.rkt +++ b/pitfall/pitfall/fontkit.rkt @@ -13,6 +13,8 @@ (super-new) (when stream (unless (input-port? stream) (raise-argument-error 'TTFFont "input port" stream))) + (port-count-lines! stream) + ;; skip variationCoords (field [_directoryPos (let-values ([(l c p) (port-next-location stream)]) p)] [_tables (mhash)] @@ -22,6 +24,16 @@ (field [directory #f]) (send this _decodeDirectory) + #;(define/public (_getTable tag) + (unless (member (· directory tag) _tables) + (raise-argument-error '_getTable "table that exists" (· table tag))) + (hash-set! _tables (· table tag) (_decodeTable table))) + + (define/public (_decodeTable table) + (define-values (l c p) (port-next-location stream)) + (displayln 'whee) + (set-port-next-location! stream l c p)) + (define/public (_decodeDirectory) (set! directory (directory-decode stream (mhash '_startOffset 0))) directory) @@ -264,6 +276,8 @@ (check-false (· f has-gpos-table?)) (check-true (send f has-table? #"cmap")) (check-equal? (· f lineGap) 0) + f + #;(send f _getTable 'maxp) #;(· f createSubset) diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt index 6c602876..dae1798b 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!) racket/string racket/format racket/contract) +(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract) (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) @@ -185,4 +185,29 @@ (define (layout? x) (and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions))) -(define index? (and/c (not/c negative?) integer?)) \ No newline at end of file +(define index? (and/c (not/c negative?) integer?)) + + +(define-macro (define-stub-stop ID) + (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")]) + #'(define (ID . args) + (error 'ERROR-ID)))) + +(provide (rename-out [define-stub-stop define-stub])) + +(define-macro (define-stub-go ID) + (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")]) + #'(define (ID . args) + (displayln 'ERROR-ID)))) + +(define-macro (define-unfinished (ID . ARGS) . BODY) + (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":unfinished")]) + #'(define (ID . ARGS) + (begin . BODY) + (error 'ID-UNFINISHED)))) + + +(define-macro (unfinished) + (with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)]) + #'(error 'ID-UNFINISHED))) + \ No newline at end of file diff --git a/pitfall/pitfall/racket.rkt b/pitfall/pitfall/racket.rkt index 6004d8ff..9155f462 100644 --- a/pitfall/pitfall/racket.rkt +++ b/pitfall/pitfall/racket.rkt @@ -1,4 +1,6 @@ #lang racket/base +(require (for-syntax racket/base br/syntax)) +(provide (for-syntax (all-from-out racket/base br/syntax))) (provide (all-from-out racket/base) r+p) (define-syntax-rule (r+p id ...) (begin (require id ...) (provide (all-from-out id ...)))) @@ -15,7 +17,8 @@ racket/contract racket/list racket/port - racket/function) + racket/function + br/define) (module reader syntax/module-reader #:language 'pitfall/racket diff --git a/pitfall/pitfall/subset.rkt b/pitfall/pitfall/subset.rkt index da129930..6b566f7d 100644 --- a/pitfall/pitfall/subset.rkt +++ b/pitfall/pitfall/subset.rkt @@ -1,4 +1,5 @@ #lang pitfall/racket +(require "clone.rkt" "ttfglyphencoder.rkt") (provide Subset CFFSubset TTFSubset) ;; approximates @@ -6,7 +7,7 @@ (define-subclass object% (Subset font) (super-new) - (field [glyphs empty] ; list of glyphs in the subset + (field [glyphs empty] ; list of glyph ids in the subset [mapping (mhash)] ; mapping of glyph ids to indexes in `glyphs` ) @@ -36,11 +37,39 @@ (define-subclass Subset (TTFSubset) (super-new) + (field [glyphEncoder (make-object TTFGlyphEncoder)]) + (field [glyf #f] + [offset #f] + [loca #f] + [hmtx #f]) (as-methods + _addGlyph encode) + + ) +(define-stub-go _addGlyph) + +;; tables required by PDF spec: +;; head, hhea, loca, maxp, cvt, prep, glyf, hmtx, fpgm +;; additional tables required for standalone fonts: +;; name, cmap, OS/2, post + (define/contract (encode this) (->m input-port?) - (· this font stream)) \ No newline at end of file + (set-field! glyf this empty) + (set-field! offset this 0) + (set-field! loca this (mhash 'offsets empty)) + (set-field! hmtx this (mhash 'metrics empty 'bearings empty)) + + ;; include all the glyphs used in the document + (for ([gid (in-list (· this glyphs))]) + (send this _addGlyph gid)) + + (define maxp (cloneDeep (· this font maxp))) + + (unfinished) + ) + diff --git a/pitfall/pitfall/ttfglyphencoder.rkt b/pitfall/pitfall/ttfglyphencoder.rkt new file mode 100644 index 00000000..72dd7525 --- /dev/null +++ b/pitfall/pitfall/ttfglyphencoder.rkt @@ -0,0 +1,13 @@ +#lang pitfall/racket +(provide TTFGlyphEncoder) + +(define-subclass object% (TTFGlyphEncoder) + (super-new) + + (as-methods + encodeSimple + _encodePoint)) + +(define-stub encodeSimple) + +(define-stub _encodePoint) \ No newline at end of file