From 5c879ccb9296b16bc8180cc0fd40dd9384040d10 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 11 Jun 2017 19:59:18 -0700 Subject: [PATCH] continue cleanup --- pitfall/fontkit/directory.rkt | 12 ++--- pitfall/fontkit/fpgm.rkt | 6 +-- pitfall/fontkit/head.rkt | 8 ++-- pitfall/fontkit/hhea.rkt | 4 +- pitfall/fontkit/hmtx.rkt | 4 +- pitfall/fontkit/loca.rkt | 6 +-- pitfall/fontkit/maxp.rkt | 2 +- pitfall/fontkit/prep.rkt | 4 +- pitfall/fontkit/tabletest.rkt | 12 ++--- pitfall/restructure/array.rkt | 47 +++++++++--------- pitfall/restructure/bitfield.rkt | 29 +++++------ pitfall/restructure/helper.rkt | 2 + pitfall/restructure/main.rkt | 4 +- pitfall/restructure/string.rkt | 42 +++++++++------- pitfall/restructure/struct.rkt | 61 ++++++++++++++++++------ pitfall/restructure/versioned-struct.rkt | 24 ---------- 16 files changed, 140 insertions(+), 127 deletions(-) diff --git a/pitfall/fontkit/directory.rkt b/pitfall/fontkit/directory.rkt index d8901a18..dba5f1f2 100644 --- a/pitfall/fontkit/directory.rkt +++ b/pitfall/fontkit/directory.rkt @@ -7,13 +7,13 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js |# -(define TableEntry (make-object RStruct - (dictify 'tag (make-object RString 4) +(define TableEntry (make-object Struct + (dictify 'tag (+String 4) 'checkSum uint32be 'offset uint32be 'length uint32be))) -(define-subclass RStruct (RDirectory) +(define-subclass Struct (RDirectory) (define/override (process this-res stream) ;; in `restructure` `process` method, `res` is aliased as `this` (define new-tables-val (mhash)) @@ -45,15 +45,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js (define Directory (make-object RDirectory - (dictify 'tag (make-object RString 4) + (dictify 'tag (+String 4) 'numTables uint16be 'searchRange uint16be 'entrySelector uint16be 'rangeShift uint16be - 'tables (make-object RArray TableEntry 'numTables)))) + 'tables (+Array TableEntry 'numTables)))) (define (directory-decode ip [options (mhash)]) - (define is (make-object RDecodeStream (port->bytes ip))) + (define is (+DecodeStream (port->bytes ip))) (send Directory decode is)) diff --git a/pitfall/fontkit/fpgm.rkt b/pitfall/fontkit/fpgm.rkt index 017978fd..e0e55722 100644 --- a/pitfall/fontkit/fpgm.rkt +++ b/pitfall/fontkit/fpgm.rkt @@ -11,11 +11,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/fpgm.js ;; is for the definition of functions that are used in many different glyph programs. -(define-subclass RStruct (Rfpgm)) +(define-subclass Struct (fpgm%)) -(define fpgm (make-object Rfpgm +(define fpgm (make-object fpgm% (dictify - 'instructions (make-object RArray uint8)))) + 'instructions (make-object Array uint8)))) diff --git a/pitfall/fontkit/head.rkt b/pitfall/fontkit/head.rkt index 66e5bc54..a74ea4eb 100644 --- a/pitfall/fontkit/head.rkt +++ b/pitfall/fontkit/head.rkt @@ -7,7 +7,7 @@ approximates https://github.com/mbutterick/fontkit/blob/master/src/tables/head.js |# -(define-subclass RStruct (Rhead)) +(define-subclass Struct (Rhead)) (define head (make-object Rhead (dictify @@ -17,13 +17,13 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/head.js 'magicNumber uint32be ;; set to 0x5F0F3CF5 'flags uint16be 'unitsPerEm uint16be ;; range from 64 to 16384 - 'created (make-object RArray int32be 2) - 'modified (make-object RArray int32be 2) + 'created (+Array int32be 2) + 'modified (+Array int32be 2) 'xMin int16be ;; for all glyph bounding boxes 'yMin int16be ;; for all glyph bounding boxes 'xMax int16be ;; for all glyph bounding boxes 'yMax int16be ;; for all glyph bounding boxes - 'macStyle (make-object RBitfield uint16be '(bold italic underline outline shadow condensed extended)) + 'macStyle (+Bitfield uint16be '(bold italic underline outline shadow condensed extended)) 'lowestRecPPEM uint16be ;; smallest readable size in pixels 'fontDirectionHint int16be 'indexToLocFormat int16be ;; 0 for short offsets 1 for long diff --git a/pitfall/fontkit/hhea.rkt b/pitfall/fontkit/hhea.rkt index 3f3142e7..38186c45 100644 --- a/pitfall/fontkit/hhea.rkt +++ b/pitfall/fontkit/hhea.rkt @@ -2,7 +2,7 @@ (require restructure) (provide (all-defined-out)) -(define-subclass RStruct (Rhhea)) +(define-subclass Struct (Rhhea)) (define hhea (make-object Rhhea (dictify @@ -17,7 +17,7 @@ 'caretSlopeRise int16be ;; Used to calculate the slope of the cursor (rise/run); 1 for vertical 'caretSlopeRun int16be ;; 0 for vertical 'caretOffset int16be ;; Set to 0 for non-slanted fonts - 'reserved (make-object RArray int16be 4) + 'reserved (+Array int16be 4) 'metricDataFormat int16be ;; 0 for current format 'numberOfMetrics uint16be ;; Number of advance widths in 'hmtx' table ))) diff --git a/pitfall/fontkit/hmtx.rkt b/pitfall/fontkit/hmtx.rkt index f8f9b8fd..62de65d9 100644 --- a/pitfall/fontkit/hmtx.rkt +++ b/pitfall/fontkit/hmtx.rkt @@ -6,9 +6,9 @@ approximates https://github.com/mbutterick/fontkit/blob/master/src/tables/hmtx.js |# -(define-subclass RStruct (Rhmtx)) +(define-subclass Struct (Rhmtx)) -(define HmtxEntry (make-object RStruct +(define HmtxEntry (make-object Struct (dictify 'advance uint16be 'bearing uint16be))) diff --git a/pitfall/fontkit/loca.rkt b/pitfall/fontkit/loca.rkt index a6794c2f..969e48d5 100644 --- a/pitfall/fontkit/loca.rkt +++ b/pitfall/fontkit/loca.rkt @@ -11,7 +11,7 @@ approximates https://github.com/mbutterick/fontkit/blob/master/src/tables/loca.js |# -(define-subclass RVersionedStruct (Rloca) +(define-subclass VersionedStruct (Rloca) (define/override (process res stream) ;; in `restructure` `process` method, `res` is aliased as `this` ;; @@ -37,8 +37,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/loca.js (define loca (make-object Rloca (λ (parent) (hash-ref (send parent _getTable 'head) 'indexToLocFormat)) (dictify - 0 (dictify 'offsets (make-object RArray uint16be)) - 1 (dictify 'offsets (make-object RArray uint32be)) + 0 (dictify 'offsets (+Array uint16be)) + 1 (dictify 'offsets (+Array uint32be)) ))) diff --git a/pitfall/fontkit/maxp.rkt b/pitfall/fontkit/maxp.rkt index 611a1990..954d2b2b 100644 --- a/pitfall/fontkit/maxp.rkt +++ b/pitfall/fontkit/maxp.rkt @@ -2,7 +2,7 @@ (require restructure) (provide (all-defined-out)) -(define-subclass RStruct (Rmaxp)) +(define-subclass Struct (Rmaxp)) (define maxp (make-object Rmaxp (dictify 'version int32be diff --git a/pitfall/fontkit/prep.rkt b/pitfall/fontkit/prep.rkt index 6b157513..b23f1dff 100644 --- a/pitfall/fontkit/prep.rkt +++ b/pitfall/fontkit/prep.rkt @@ -6,11 +6,11 @@ approximates https://github.com/mbutterick/fontkit/blob/master/src/tables/prep.js |# -(define-subclass RStruct (Rprep)) +(define-subclass Struct (Rprep)) (define prep (make-object Rprep (dictify - 'controlValueProgram (make-object RArray uint8)))) + 'controlValueProgram (+Array uint8)))) diff --git a/pitfall/fontkit/tabletest.rkt b/pitfall/fontkit/tabletest.rkt index 81afb30b..a3d2e199 100644 --- a/pitfall/fontkit/tabletest.rkt +++ b/pitfall/fontkit/tabletest.rkt @@ -16,7 +16,7 @@ (define maxp-bytes #"\0\1\0\0\0\345\0f\0\a\0O\0\4\0\1\0\0\0\0\0\n\0\0\2\0\1s\0\2\0\1") (set-port-position! ip 0) (check-equal? (peek-bytes maxp-length maxp-offset ip) maxp-bytes) - (define maxp-data (send maxp decode (make-object RDecodeStream maxp-bytes))) + (define maxp-data (send maxp decode (+DecodeStream maxp-bytes))) (check-equal? (· maxp-data numGlyphs) 229) (check-equal? (· maxp-data version) 65536)) @@ -30,7 +30,7 @@ (define table-bytes #"\0\1\0\0\3\324\377\22\0\0\4\311\377_\377`\4\251\0\1\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\345") (set-port-position! ip 0) (check-equal? (peek-bytes length offset ip) table-bytes) - (define table-data (send hhea decode (make-object RDecodeStream table-bytes))) + (define table-data (send hhea decode (+DecodeStream table-bytes))) (check-equal? (· table-data ascent) 980) (check-equal? (· table-data descent) -238)) @@ -46,7 +46,7 @@ (define table-bytes #"\0\1\0\0\0\2\0\0.\252t<_\17<\365\0\t\3\350\0\0\0\0\316\3\301\261\0\0\0\0\316\3\304\364\377\36\377\24\4\226\3\324\0\2\0\t\0\2\0\0\0\0") (set-port-position! ip 0) (check-equal? (peek-bytes length offset ip) table-bytes) - (define table-data (send head decode (make-object RDecodeStream table-bytes))) + (define table-data (send head decode (+DecodeStream table-bytes))) (check-equal? (· table-data unitsPerEm) 1000) (check-equal? (· table-data yMin) -236) (check-equal? (· table-data yMax) 980) @@ -73,7 +73,7 @@ (set-port-position! ip 0) (define table-bytes #"\270\0\0+\0\272\0\1\0\1\0\2+\1\272\0\2\0\1\0\2+\1\277\0\2\0C\0007\0+\0\37\0\23\0\0\0\b+\0\277\0\1\0\200\0i\0R\0;\0#\0\0\0\b+\0\272\0\3\0\5\0\a+\270\0\0 E}i\30D") (check-equal? table-bytes (peek-bytes len offset ip)) - (define ds (make-object RDecodeStream (peek-bytes len offset ip))) + (define ds (+DecodeStream (peek-bytes len offset ip))) (check-equal? (hash-ref (send prep decode ds) 'controlValueProgram) '(184 0 0 @@ -160,7 +160,7 @@ (check-equal? offset 4140) (check-equal? len 371) (set-port-position! ip 0) - (define ds (make-object RDecodeStream (peek-bytes len offset ip))) + (define ds (+DecodeStream (peek-bytes len offset ip))) (check-equal? (hash-ref (send fpgm decode ds) 'instructions) '(184 0 0 @@ -540,7 +540,7 @@ (check-equal? offset 38692) (check-equal? len 460) (set-port-position! ip 0) - (define ds (make-object RDecodeStream (peek-bytes len offset ip))) + (define ds (+DecodeStream (peek-bytes len offset ip))) (define table-data (send loca decode ds #:version 0)) (check-equal? (length (· table-data offsets)) 230) (check-equal? (· table-data offsets) '(0 diff --git a/pitfall/restructure/array.rkt b/pitfall/restructure/array.rkt index 88dc4d0a..86816fe5 100644 --- a/pitfall/restructure/array.rkt +++ b/pitfall/restructure/array.rkt @@ -1,48 +1,47 @@ #lang restructure/racket -(require "number.rkt" "utils.rkt" "streamcoder.rkt") -(provide RArray) +(require "number.rkt" "utils.rkt" "stream.rkt") +(provide (all-defined-out)) #| approximates https://github.com/mbutterick/restructure/blob/master/src/Array.coffee |# -(define-subclass RStreamcoder (RArray type [length #f] [lengthType 'count]) +(define-subclass Streamcoder (Array type [_length #f] [lengthType 'count]) (define/augment (decode stream [parent #f]) - (let ([length (cond - [length - (resolveLength length stream parent)] - [else - (define num (send stream length)) - (define denom (send type size)) - (unless (andmap (λ (x) (and x (number? x))) (list num denom)) - (raise-argument-error 'RArray:decode "valid length and size" (list num denom))) - ;; implied length: length of stream divided by size of item - (floor (/ (send stream length) (send type size)))])]) + (let ([len (cond + ;; explicit length + [_length (resolveLength _length stream parent)] + [else ;; implicit length: length of stream divided by size of item + (define num (send stream length)) + (define denom (send type size)) + (unless (andmap (λ (x) (and x (number? x))) (list num denom)) + (raise-argument-error 'Array:decode "valid length and size" (list num denom))) + (floor (/ (send stream length) (send type size)))])]) (caseq lengthType - [(count) (for/list ([i (in-range length)]) - (send type decode stream this))]))) + [(count) (for/list ([i (in-range len)]) + (send type decode stream this))]))) (define/override (size array) - (for/sum ([item (in-list array)]) - (send type size))) + (unless (list? array) (raise-argument-error 'Array:size "list" array)) + (* (send type size) (length array))) (define/augment (encode stream array [parent #f]) + (unless (list? array) (raise-argument-error 'Array:encode "list" array)) (for ([item (in-list array)]) - (send type encode stream item)))) + (send type encode stream item)))) (test-module - (require "decodestream.rkt" "encodestream.rkt") - (define stream (make-object RDecodeStream #"ABCDEFG")) + (define stream (+DecodeStream #"ABCDEFG")) - (define A (make-object RArray uint16be 3)) + (define A (+Array uint16be 3)) (check-equal? (send A decode stream) '(16706 17220 17734)) - (define os (make-object REncodeStream)) + (define os (+EncodeStream)) (send A encode os '(16706 17220 17734)) (check-equal? (send os dump) #"ABCDEF") - (check-equal? (send (make-object RArray uint16be) size '(1 2 3)) 6) - (check-equal? (send (make-object RArray doublebe) size '(1 2 3 4 5)) 40)) \ No newline at end of file + (check-equal? (send (+Array uint16be) size '(1 2 3)) 6) + (check-equal? (send (+Array doublebe) size '(1 2 3 4 5)) 40)) \ No newline at end of file diff --git a/pitfall/restructure/bitfield.rkt b/pitfall/restructure/bitfield.rkt index 75b7085c..fd6ebd2f 100644 --- a/pitfall/restructure/bitfield.rkt +++ b/pitfall/restructure/bitfield.rkt @@ -1,33 +1,34 @@ #lang restructure/racket -(require "streamcoder.rkt") -(provide RBitfield) +(require "stream.rkt") +(provide (all-defined-out)) #| approximates https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee |# -(define-subclass RStreamcoder (RBitfield type [flags empty]) +(define-subclass Streamcoder (Bitfield type [flags empty]) - (define/augment (decode stream [parent #f]) - (for*/fold ([res (mhash)]) + (define/augment (decode stream . args) + (for*/fold ([flag-hash (mhash)]) ([val (in-value (send type decode stream))] [(flag i) (in-indexed flags)]) - (hash-set! res flag (bitwise-bit-set? val i)) - res)) + (hash-set! flag-hash flag (bitwise-bit-set? val i)) + flag-hash)) (define/override (size . args) (send type size)) (define/augment (encode stream flag-hash) - (send type encode stream (for/sum ([(flag i) (in-indexed flags)] - #:when (hash-ref flag-hash flag)) - (expt 2 i))))) + (define bitfield-int (for/sum ([(flag i) (in-indexed flags)] + #:when (hash-ref flag-hash flag)) + (expt 2 i))) + (send type encode stream bitfield-int))) (test-module - (require "number.rkt" "decodestream.rkt" "encodestream.rkt") - (define bfer (make-object RBitfield uint16be '(bold italic underline outline shadow condensed extended))) - (define bf (send bfer decode (make-object RDecodeStream #"\0\25"))) + (require "number.rkt" "stream.rkt") + (define bfer (+Bitfield uint16be '(bold italic underline outline shadow condensed extended))) + (define bf (send bfer decode (+DecodeStream #"\0\25"))) (check-true (hash-ref bf 'bold)) (check-true (hash-ref bf 'underline)) (check-true (hash-ref bf 'shadow)) @@ -36,6 +37,6 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (check-false (hash-ref bf 'condensed)) (check-false (hash-ref bf 'extended)) - (define os (make-object REncodeStream)) + (define os (+EncodeStream)) (send bfer encode os bf) (check-equal? (send os dump) #"\0\25")) \ No newline at end of file diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt index cbee36ef..aff744ac 100644 --- a/pitfall/restructure/helper.rkt +++ b/pitfall/restructure/helper.rkt @@ -11,6 +11,8 @@ (define/public (process . args) (void)) (define/public (preEncode . args) (void)))) +(define (RestructureBase? x) (is-a? x RestructureBase)) + (define-macro (test-module . EXPRS) #`(module+ test diff --git a/pitfall/restructure/main.rkt b/pitfall/restructure/main.rkt index 02c524c7..dc5b67e7 100644 --- a/pitfall/restructure/main.rkt +++ b/pitfall/restructure/main.rkt @@ -2,9 +2,7 @@ (r+p "number.rkt" "struct.rkt" - "versioned-struct.rkt" "string.rkt" "array.rkt" "bitfield.rkt" - "decodestream.rkt" - "encodestream.rkt") \ No newline at end of file + "stream.rkt") \ No newline at end of file diff --git a/pitfall/restructure/string.rkt b/pitfall/restructure/string.rkt index c5472321..83c440c0 100644 --- a/pitfall/restructure/string.rkt +++ b/pitfall/restructure/string.rkt @@ -1,40 +1,46 @@ #lang restructure/racket -(require "number.rkt" "utils.rkt" "streamcoder.rkt") -(provide RString) +(require "number.rkt" "utils.rkt" "stream.rkt") +(provide (all-defined-out)) #| approximates https://github.com/mbutterick/restructure/blob/master/src/String.coffee |# -(define-subclass RStreamcoder (RString [length #f] [encoding 'ascii]) - (field [_codec (caseq encoding - [(latin-1 ascii) (cons string->bytes/latin-1 bytes->string/latin-1)] - [(utf-8 utf8)(cons string->bytes/utf-8 bytes->string/utf-8)])]) +(struct $codec (encoder decoder) #:transparent) + +(define-subclass Streamcoder (String [strlen #f] [encoding 'ascii]) + (field [codec (caseq encoding + [(latin-1 ascii) ($codec string->bytes/latin-1 bytes->string/latin-1)] + [(utf-8 utf8) ($codec string->bytes/utf-8 bytes->string/utf-8)])]) (define/augment (decode stream [parent #f]) - (define count (if length - (resolveLength length stream parent) + (define count (if strlen + (resolveLength strlen stream parent) (send stream length))) (define bytes (send stream read count)) - ((cdr _codec) bytes)) + (($codec-decoder codec) bytes)) (define/augment (encode stream val [parent #f]) - (define bytes ((car _codec) (format "~a" val))) + (define bytes (($codec-encoder codec) (format "~a" val))) - (when (is-a? length Number) ;; length-prefixed string - (send length encode stream (bytes-length bytes))) + (when (Number? strlen) ;; length-prefixed string + (send strlen encode stream (bytes-length bytes))) (send stream write bytes)) - (define/override (size) (unfinished))) + (define/override (size str) + (define es (+EncodeStream)) + (encode es str) + (bytes-length (send es dump)))) (test-module - (require "decodestream.rkt" "encodestream.rkt") - (define stream (make-object RDecodeStream #"\2BCDEF")) - (define S (make-object RString uint8 'utf8)) + (require "stream.rkt") + (define stream (+DecodeStream #"\2BCDEF")) + (define S (+String uint8 'utf8)) (check-equal? (send S decode stream) "BC") - (define os (make-object REncodeStream)) + (define os (+EncodeStream)) (send S encode os "Mike") - (check-equal? (send os dump) #"\4Mike")) \ No newline at end of file + (check-equal? (send os dump) #"\4Mike") + (check-equal? (send (+String) size "foobar") 6)) \ No newline at end of file diff --git a/pitfall/restructure/struct.rkt b/pitfall/restructure/struct.rkt index d497cd2e..bba2e014 100644 --- a/pitfall/restructure/struct.rkt +++ b/pitfall/restructure/struct.rkt @@ -1,5 +1,5 @@ #lang restructure/racket -(require racket/dict) +(require racket/dict "stream.rkt") (provide (all-defined-out)) #| @@ -7,27 +7,32 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee |# -(define-subclass RBase (RStruct [assocs (dictify)]) - (field [key-index #f] - [fields (mhash)]) +(define-subclass RestructureBase (Struct [assocs (dictify)]) + (field [key-index (map car assocs)] ; store the original key order + [struct-types (mhash)]) (for ([(k v) (in-dict assocs)]) - (hash-set! fields k v)) - - (define/public-final (make-key-index! [fields assocs]) - (set! key-index (map car fields))) - (make-key-index!) + (hash-set! struct-types k v)) (define/override (decode stream [parent #f] [length 0]) (define res (_setup stream parent length)) - (_parseFields stream res fields) + (_parseFields stream res struct-types) #;(hash-set! (hash-ref res '_props) '_currentOffset (· stream pos)) (send this process res stream) res) - (define/override (encode stream val [parent #f]) - (send this preEncode val stream) - (for ([key (in-list key-index)]) - (send (hash-ref fields key) encode stream (hash-ref val key)))) + (define/override (encode stream input-hash [parent #f]) + (unless (hash? input-hash) + (raise-argument-error 'Struct:encode "hash" input-hash)) + (define sorted-input-keys (sort (hash-keys input-hash) #:key symbol->string stringstring string