mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

next: back to tables

Browse Source
main
Matthew Butterick 7 years ago
parent 5f559b9c7c
commit 1b5f1d9986
6 changed files with 67 additions and 61 deletions
Show Stats Download Patch File Download Diff File

4
pitfall/fontkit/directory.rkt
Unescape Escape View File

@ -53,12 +53,10 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
'tables (+Array TableEntry 'numTables)))) 'tables (+Array TableEntry 'numTables))))
(define (directory-decode ip [options (mhash)]) (define (directory-decode ip [options (mhash)])
(define is (+DecodeStream (port->bytes ip))) (send Directory decode (+DecodeStream (port->bytes ip))))
(send Directory decode is))
(test-module (test-module
(require racket/serialize)
(define ip (open-input-file charter-path)) (define ip (open-input-file charter-path))
(check-equal? (check-equal?
(directory-decode ip) (directory-decode ip)

3
pitfall/fontkit/loca.rkt
Unescape Escape View File

@ -38,8 +38,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/loca.js
(λ (parent) (hash-ref (send parent _getTable 'head) 'indexToLocFormat)) (λ (parent) (hash-ref (send parent _getTable 'head) 'indexToLocFormat))
(dictify (dictify
0 (dictify 'offsets (+Array uint16be)) 0 (dictify 'offsets (+Array uint16be))
1 (dictify 'offsets (+Array uint32be)) 1 (dictify 'offsets (+Array uint32be)))))
)))
(test-module (test-module

26
pitfall/restructure/number.rkt
Unescape Escape View File

@ -12,13 +12,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(equal? (substring str (sub1 (string-length str))) "8")) (equal? (substring str (sub1 (string-length str))) "8"))
(define (signed-type? type) (define (signed-type? type)
(not (equal? "U" (substring (symbol->string type) 0 1)))) (not (equal? "u" (substring (symbol->string type) 0 1))))
(test-module (test-module
(check-false (signed-type? 'UInt16)) (check-false (signed-type? 'uint16))
(check-true (signed-type? 'Int16))) (check-true (signed-type? 'int16)))
(define-subclass Streamcoder (Number [type 'UInt16] [endian (if (system-big-endian?) 'BE 'LE)]) (define-subclass Streamcoder (Number [type 'uint16] [endian (if (system-big-endian?) 'be 'le)])
(getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))]) (getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))])
@ -35,7 +35,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(define bstr (send stream read _size)) (define bstr (send stream read _size))
(if (= 1 _size) (if (= 1 _size)
(bytes-ref bstr 0) (bytes-ref bstr 0)
(integer-bytes->integer bstr (signed-type? type) (eq? endian 'BE)))) (integer-bytes->integer bstr (signed-type? type) (eq? endian 'be))))
(define/augment (encode stream val-in) (define/augment (encode stream val-in)
(define val (if (integer? val-in) (inexact->exact val-in) val-in)) (define val (if (integer? val-in) (inexact->exact val-in) val-in))
@ -44,7 +44,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(raise-argument-error 'Number:encode (format "integer that fits in ~a byte(s)" _size) val)) (raise-argument-error 'Number:encode (format "integer that fits in ~a byte(s)" _size) val))
(define bstr (if (= 1 _size) (define bstr (if (= 1 _size)
(bytes val) (bytes val)
(integer->integer-bytes val _size (signed-type? type) (eq? endian 'BE)))) (integer->integer-bytes val _size (signed-type? type) (eq? endian 'be))))
(send stream write bstr))) (send stream write bstr)))
@ -55,7 +55,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(check-exn exn:fail:contract? (λ () (send uint16 encode (+EncodeStream) (add1 #xffff)))) (check-exn exn:fail:contract? (λ () (send uint16 encode (+EncodeStream) (add1 #xffff))))
(check-not-exn (λ () (send uint16 encode (+EncodeStream) #xffff))) (check-not-exn (λ () (send uint16 encode (+EncodeStream) #xffff)))
(let ([o (+Number 'UInt16 'LE)] (let ([o (+Number 'uint16 'le)]
[ip (+DecodeStream (bytes 1 2 3 4))] [ip (+DecodeStream (bytes 1 2 3 4))]
[op (open-output-bytes)]) [op (open-output-bytes)])
(check-equal? (send o decode ip) 513) ;; 1000 0000 0100 0000 (check-equal? (send o decode ip) 513) ;; 1000 0000 0100 0000
@ -65,7 +65,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(send o encode op 1027) (send o encode op 1027)
(check-equal? (get-output-bytes op) (bytes 1 2 3 4))) (check-equal? (get-output-bytes op) (bytes 1 2 3 4)))
(let ([o (+Number 'UInt16 'BE)] (let ([o (+Number 'uint16 'be)]
[ip (+DecodeStream (bytes 1 2 3 4))] [ip (+DecodeStream (bytes 1 2 3 4))]
[op (open-output-bytes)]) [op (open-output-bytes)])
(check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000 (check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000
@ -77,10 +77,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(test-module (test-module
(check-equal? (send (+Number 'UInt8) size) 1) (check-equal? (send (+Number 'uint8) size) 1)
(check-equal? (send (+Number) size) 2) (check-equal? (send (+Number) size) 2)
(check-equal? (send (+Number 'UInt32) size) 4) (check-equal? (send (+Number 'uint32) size) 4)
(check-equal? (send (+Number 'Double) size) 8)) (check-equal? (send (+Number 'double) size) 8))
;; use keys of type-sizes hash to generate corresponding number definitions ;; use keys of type-sizes hash to generate corresponding number definitions
@ -88,13 +88,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(with-pattern ([((ID BASE ENDIAN) ...) (for/list ([k (in-hash-keys type-sizes)]) (with-pattern ([((ID BASE ENDIAN) ...) (for/list ([k (in-hash-keys type-sizes)])
(define kstr (format "~a" k)) (define kstr (format "~a" k))
(match-define (list* prefix suffix _) (match-define (list* prefix suffix _)
(regexp-split #rx"(?=[BL]E|$)" kstr)) (regexp-split #rx"(?=[bl]e|$)" kstr))
(map string->symbol (map string->symbol
(list (string-downcase kstr) (list (string-downcase kstr)
prefix prefix
(if (positive? (string-length suffix)) (if (positive? (string-length suffix))
suffix suffix
(if (system-big-endian?) "BE" "LE")))))] (if (system-big-endian?) "be" "le")))))]
[(ID ...) (suffix-id #'(ID ...) #:context caller-stx)]) [(ID ...) (suffix-id #'(ID ...) #:context caller-stx)])
#'(begin (define+provide ID (make-object Number 'BASE 'ENDIAN)) ...))) #'(begin (define+provide ID (make-object Number 'BASE 'ENDIAN)) ...)))

40
pitfall/restructure/sizes.rkt
Unescape Escape View File

@ -2,34 +2,34 @@
(provide type-sizes get-type-size) (provide type-sizes get-type-size)
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values) (define-values (int-keys byte-values) (for*/lists (int-keys byte-values)
([signed (in-list '("U" ""))] ([signed (in-list '("u" ""))]
[bit-size (in-list '(8 16 24 32))]) [bit-size (in-list '(8 16 24 32))])
(values (format "~aInt~a" signed bit-size) (/ bit-size 8)))) (values (format "~aint~a" signed bit-size) (/ bit-size 8))))
(define type-sizes (for/hash ([type-key (in-list (append '("Float" "Double") int-keys))] (define type-sizes (for/hash ([type-key (in-list (append '("float" "double") int-keys))]
[byte-value (in-list (append '(4 8) byte-values))] [byte-value (in-list (append '(4 8) byte-values))]
#:when #t #:when #t
[endian (in-list '("" "BE" "LE"))]) [endian (in-list '("" "be" "le"))])
(values (string->symbol (string-append type-key endian)) byte-value))) (values (string->symbol (string-append type-key endian)) byte-value)))
(define (get-type-size key) (define (get-type-size key)
(hash-ref type-sizes key (λ () (raise-argument-error 'DecodeStream:get-type-size "valid type" key)))) (hash-ref type-sizes key (λ () (raise-argument-error 'DecodeStream:get-type-size "valid type" key))))
(test-module (test-module
(check-equal? (get-type-size 'Int8) 1) (check-equal? (get-type-size 'int8) 1)
(check-equal? (get-type-size 'UInt8) 1) (check-equal? (get-type-size 'uint8) 1)
(check-equal? (get-type-size 'UInt8BE) 1) (check-equal? (get-type-size 'uint8be) 1)
(check-equal? (get-type-size 'Int16) 2) (check-equal? (get-type-size 'int16) 2)
(check-equal? (get-type-size 'UInt16) 2) (check-equal? (get-type-size 'uint16) 2)
(check-equal? (get-type-size 'UInt16BE) 2) (check-equal? (get-type-size 'uint16be) 2)
(check-equal? (get-type-size 'UInt16LE) 2) (check-equal? (get-type-size 'uint16le) 2)
(check-equal? (get-type-size 'UInt32) 4) (check-equal? (get-type-size 'uint32) 4)
(check-equal? (get-type-size 'UInt32LE) 4) (check-equal? (get-type-size 'uint32le) 4)
(check-equal? (get-type-size 'Int32BE) 4) (check-equal? (get-type-size 'int32be) 4)
(check-equal? (get-type-size 'Float) 4) (check-equal? (get-type-size 'float) 4)
(check-equal? (get-type-size 'FloatLE) 4) (check-equal? (get-type-size 'floatle) 4)
(check-equal? (get-type-size 'FloatBE) 4) (check-equal? (get-type-size 'floatbe) 4)
(check-equal? (get-type-size 'Double) 8) (check-equal? (get-type-size 'double) 8)
(check-equal? (get-type-size 'DoubleLE) 8) (check-equal? (get-type-size 'doublele) 8)
(check-equal? (get-type-size 'DoubleBE) 8) (check-equal? (get-type-size 'doublebe) 8)
(check-exn exn:fail:contract? (λ () (get-type-size 'not-a-type)))) (check-exn exn:fail:contract? (λ () (get-type-size 'not-a-type))))

53
pitfall/restructure/struct.rkt
Unescape Escape View File

@ -8,12 +8,26 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
|# |#
(define-subclass Streamcoder (Struct [assocs (dictify)]) (define-subclass Streamcoder (Struct [assocs (dictify)])
(unless (dict? assocs) (unless (assocs? assocs)
(raise-argument-error 'Struct "dictionary" assocs)) (raise-argument-error 'Struct "assocs" assocs))
(field [key-index (map car assocs)] ; store the original key order (field [key-index #f] ; store the original key order
[fields (mhash)]) [fields (mhash)])
(for ([(k v) (in-dict assocs)])
(hash-set! fields k v)) (define/private (update-key-index! assocs)
(unless (assocs? assocs)
(raise-argument-error 'Struct "assocs" assocs))
(set! key-index (map car assocs)))
(update-key-index! assocs)
(define/public-final (update-fields! assocs)
(unless (assocs? assocs)
(raise-argument-error 'Struct "assocs or hash" assocs))
(update-key-index! assocs)
(for ([(k v) (in-dict assocs)])
(hash-set! fields k v)))
(update-fields! assocs)
(define/augride (decode stream [parent #f] [length 0]) (define/augride (decode stream [parent #f] [length 0])
(define res (_setup stream parent length)) (define res (_setup stream parent length))
@ -109,8 +123,8 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
[(RestructureBase? version-resolver) (send version-resolver decode stream)] [(RestructureBase? version-resolver) (send version-resolver decode stream)]
[else (raise-argument-error 'VersionedStruct:decode "way of finding version" version-resolver)])) [else (raise-argument-error 'VersionedStruct:decode "way of finding version" version-resolver)]))
(hash-set! res 'version version) (hash-set! res 'version version)
(set! fields (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" version)))) (define assocs (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" version))))
(set! key-index (map car fields)) (send this update-fields! assocs)
(cond (cond
[(VersionedStruct? fields) (send fields decode stream parent)] [(VersionedStruct? fields) (send fields decode stream parent)]
[else [else
@ -123,26 +137,19 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42))) (check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42)))
;; make random versioned structs and make sure we can round trip ;; make random versioned structs and make sure we can round trip
(for ([i (in-range 1)]) (for ([i (in-range 20)])
(define field-types (for/list ([i (in-range 2)]) (define field-types (for/list ([i (in-range 200)])
(random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) (random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
(define num-versions 2) (define num-versions 20)
(define selector (random num-versions)) (define which-struct (random num-versions))
(define versions (for/list ([v (in-range num-versions)]) (define struct-versions (for/list ([v (in-range num-versions)])
(cons v (for/list ([num-type (in-list field-types)]) (cons v (for/list ([num-type (in-list field-types)])
(cons (gensym) num-type))))) (cons (gensym) num-type)))))
(define vs (+VersionedStruct selector versions)) (define vs (+VersionedStruct which-struct struct-versions))
(define size-num-types (for/sum ([num-type (in-list (map cdr (dict-ref versions selector)))]) (define struct-size (for/sum ([num-type (in-list (map cdr (dict-ref struct-versions which-struct)))])
(send num-type size))) (send num-type size)))
(define bs (apply bytes (for/list ([i (in-range size-num-types)]) (define bs (apply bytes (for/list ([i (in-range struct-size)])
(random 256)))) (random 256))))
(define es (+EncodeStream)) (define es (+EncodeStream))
(send vs encode es (send vs decode bs)) (send vs encode es (send vs decode bs))
#| (check-equal? (send es dump) bs)))
(check-equal? (send es dump) bs)
|#
42
))

2
pitfall/sugar/dict.rkt
Unescape Escape View File

@ -2,6 +2,8 @@
(require sugar/list) (require sugar/list)
(provide (all-defined-out)) (provide (all-defined-out))
(define (assoc? x) (and (pair? x) (not (list? x))))
(define (assocs? xs) (and (list? xs) (andmap assoc? xs)))
(define (listify kvs) (define (listify kvs)
(for/list ([slice (in-list (slice-at kvs 2))]) (for/list ([slice (in-list (slice-at kvs 2))])

Write Preview
Loading…
Cancel
Save