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

working on bit parsing

Browse Source
main
Matthew Butterick 8 years ago
parent 1e41d9e1cd
commit 6ac7f82488
11 changed files with 212 additions and 151 deletions
Show Stats Download Patch File Download Diff File

0
pitfall/pitfall/binparser/binary-parse.scm → pitfall/binparser/binary-parse.scm
Unescape Escape View File

0
pitfall/pitfall/binparser/binary-parsing-slides.pdf → pitfall/binparser/binary-parsing-slides.pdf
Unescape Escape View File

1
pitfall/binparser/compiled/drracket/main_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.9.0.1" ("d4acf59c6acf0dad17fcba3329960f093e6d5d28" . "8267c356c2dc2c54a92317aeb6f02701e17cb6e6") (collects #"br" #"define.rkt") (collects #"br" #"syntax.rkt") (collects #"racket" #"base.rkt") (collects #"racket" #"function.rkt") (collects #"racket" #"list.rkt") (collects #"racket" #"match.rkt") (collects #"racket" #"port.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt") (collects #"sugar" #"debug.rkt") (collects #"sugar" #"list.rkt") (indirect collects #"racket" #"match" #"gen-match.rkt") (indirect collects #"racket" #"match" #"parse.rkt"))

BIN
pitfall/binparser/compiled/drracket/main_rkt.zo
View File

Binary file not shown.

39
pitfall/binparser/gif-parse.rkt
Unescape Escape View File

@ -0,0 +1,39 @@
#lang br
(require pitfall/binprint binparser)
;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp
(define-rule gif (:seq signature version logical-screen-descriptor #:type hash?))
(define-rule signature (:atomic 3 #:type string/ascii?))
(define-rule version (:atomic 3 #:type string/ascii?))
(define-rule logical-screen-descriptor (:seq width height lsd-flags bgcolor-idx aspect #:type hash?))
(define-rule width (:atomic 2 #:type integer?))
(define-rule height (:atomic 2 #:type integer?))
(define-rule lsd-flags (:seq reserved disposal user-input transparent #:type hash?))
(define-rule reserved (:atomic .3))
(define-rule disposal (:atomic .3))
(define-rule user-input (:atomic .1))
(define-rule transparent (:atomic .1))
(define-rule bgcolor-idx (:atomic 1 #:type integer?))
(define-rule aspect (:atomic 1 #:type integer?))
(gif (open-input-file "test.gif"))
#;(check-equal? (gif (gif (open-input-file "test.gif"))) (read-bytes 13 (open-input-file "test.gif")))
(require rackunit)
#;(check-equal? (parse-with-template "test.gif" gif)
(cons 'gif
(make-hasheq (list (cons 'logical-screen-descriptor '(162 162 (#f #t #f #f #f #t #f #t) 0 0))
'(signature . "GIF")
'(version . "87a")))))

0
pitfall/pitfall/binparser/giflexer.rkt → pitfall/binparser/giflexer.rkt
Unescape Escape View File

0
pitfall/pitfall/binparser/gifparser.rkt → pitfall/binparser/gifparser.rkt
Unescape Escape View File

172
pitfall/binparser/main.rkt
Unescape Escape View File

@ -0,0 +1,172 @@
#lang sugar/debug racket/base
(require sugar/debug)
(require (for-syntax racket/base br/syntax))
(require racket/match racket/function racket/port br/define sugar/list racket/list)
(provide define-rule :atomic :seq :repeat string/utf-8? string/latin-1? string/ascii? bitfield?)
(define string/utf-8? #t)
(define string/latin-1? 'string/latin-1?)
(define string/ascii? 'string/ascii?)
(define bitfield? 'bitfield?)
(struct binary-problem (msg val) #:transparent)
(define bitfield #f)
(define (read-bits-exact count p)
(define bitcount (inexact->exact (* 10 count)))
(unless (pair? bitfield)
(set! bitfield (bytes->bitfield (read-bytes 1 p))))
(define-values (bits rest) (split-at bitfield bitcount))
(set! bitfield rest)
bits)
(define (read-bytes-exact count p)
(cond
[(integer? count)
(define bs (read-bytes count p))
(unless (and (bytes? bs) (= (bytes-length bs) count))
(raise (binary-problem (format "byte string length ~a" count) bs)))
bs]
[else (read-bits-exact count p)]))
(define (bytes->integer len x)
(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)]))
(define (integer->bytes len x)
(case len
[(1) (bytes x)]
[(2 4 8) (integer->integer-bytes x len #f #f)]
[else (raise-argument-error 'integer->bytes "byte length 1 2 4 8" len)]))
(define (bytes->ascii bs)
(list->string (for/list ([b (in-bytes bs)])
(if (< b 128)
(integer->char b)
(raise (binary-problem "ascii byte < 128" b))))))
(define (ascii->bytes str)
(apply bytes (for/list ([c (in-string str)])
(char->integer c))))
(define (bytes->bitfield bs)
(for*/list ([b (in-bytes bs)]
[idx (in-range 8)])
(bitwise-bit-set? b idx)))
(define (bitfield->bytes bf)
(unless (zero? (modulo (length bf) 8))
(raise-argument-error 'bitfield->bytes "bitfield length a multiple of 8" (length bf)))
(apply bytes
(let loop ([bf bf][acc null])
(if (null? bf)
(reverse acc)
(let-values ([(bits rest) (split-at bf 8)])
(loop rest (cons (for/sum ([b (in-list bits)]
[pow (in-range 8)]
#:when b)
(expt 2 pow)) acc)))))))
(module+ test
(check-equal? (bitfield->bytes (bytes->bitfield #"AB")) #"AB"))
(define (:atomic count #:type [type #f])
(procedure-rename
(λ (x)
(define-values (input-proc output-proc)
(cond
[(equal? type integer?) (values (curry bytes->integer count)
(curry integer->bytes count))]
[(equal? type string/ascii?) (values bytes->ascii ascii->bytes)]
[(equal? type bitfield?) (values bytes->bitfield bitfield->bytes)]
[else (values identity identity)]))
(if (input-port? x)
(input-proc (read-bytes-exact count x))
(let ([result (output-proc x)])
(unless (and (bytes? result) (= (bytes-length result) count))
(raise (binary-problem (format "byte string length ~a" count) result)))
result))) (gensym 'atomic-)))
(define (list->hash-with-keys keys vals)
(make-hash (map cons keys vals)))
(define (hash->list-with-keys keys h)
(for/list ([k (in-list keys)])
(hash-ref h k)))
(define (procedure-name proc)
(string->symbol (cadr (regexp-match #rx"^#<procedure:(.*?)>$" (with-output-to-string (λ () (display proc)))))))
(define (hash-has-keys? h keys)
(define (sortation xs) (sort xs #:key symbol->string string<?))
(equal? (sortation (hash-keys h)) (sortation keys)))
(define (resolve-duplicates xs)
(if (members-unique? xs)
xs
(for/list ([x (in-list xs)]
[idx (in-naturals 1)])
(string->symbol (format "~a-~a" x idx)))))
(define (:seq #:type [type #f] . rule-procs)
(procedure-rename
(λ (x) (define-values (input-proc output-proc output-check)
(cond
[(equal? type hash?)
(define rule-proc-names (resolve-duplicates (map procedure-name rule-procs)))
(values (curry list->hash-with-keys rule-proc-names)
(curry hash->list-with-keys rule-proc-names)
(λ (x)
(unless (and (hash? x) (hash-has-keys? x rule-proc-names))
(raise (binary-problem (format "hash with ~a keys, namely ~a" (length rule-procs) rule-proc-names) x)))))]
[else (values identity identity
(λ (x)
(unless (and (list? x) (= (length rule-procs) (length x)))
(raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))]))
(match x
[(? input-port? p) (input-proc (map (λ (rule-proc) (rule-proc p)) rule-procs))]
[else
(output-check x)
(apply bytes-append (map (λ (rp xi) (rp xi)) rule-procs (output-proc x)))])) (gensym 'seq)))
(define (:repeat count . rule-procs)
(λ (p) (append-map (λ (i) (map (λ (r-p) (r-p p) rule-procs))) (range count))))
(define-macro (define-rule ID RULE-PROC)
#'(define (ID [x (current-input-port)])
(with-handlers ([binary-problem? (λ (exn)
(raise-result-error
'ID
(binary-problem-msg exn)
(binary-problem-val exn)))])
(RULE-PROC x))))
(module+ test
(require rackunit)
(define-rule foo (:seq bar zam #:type hash?))
(define-rule bar (:atomic 1 #:type integer?))
(define-rule zam (:atomic 2 #:type integer?))
(check-equal? #"AB" (zam (zam (open-input-bytes #"AB"))) (zam 16961))
(check-equal? #"123" (foo (foo (open-input-bytes #"123"))) (foo '#hash((bar . 49) (zam . 13106))))
(define-rule foolist (:seq bar zam bar zam))
(check-equal? #"123456" (foolist (foolist (open-input-bytes #"123456"))) (foolist '(49 13106 52 13877)))
(define-rule hashrule (:seq bar zam bar zam bar #:type hash?))
(check-equal? #"1234567" (hashrule (hashrule (open-input-bytes #"1234567")))
(hashrule '#hash((zam-4 . 13877) (bar-3 . 52) (zam-2 . 13106) (bar-1 . 49) (bar-5 . 55))))
(define-rule flag (:atomic .4))
(check-equal? (flag (open-input-bytes #"A")) '(#t #f #f #f))
)

0
pitfall/pitfall/binparser/prototype-binparser.rkt → pitfall/binparser/prototype-binparser.rkt
Unescape Escape View File

0
pitfall/pitfall/binparser/test.gif → pitfall/binparser/test.gif
Unescape Escape View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.5 KiB

After

Width:  |  Height:  |  Size: 1.5 KiB

151
pitfall/pitfall/binparser/gif-parse.rkt
Unescape Escape View File

@ -1,151 +0,0 @@
#lang br
(require "../binprint.rkt" racket/file)
;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp
(define unparse-val (make-parameter #f))
(struct binary-problem (msg val) #:transparent)
(define (read-bytes-exact count p)
(define bs (read-bytes count p))
(unless (and (bytes? bs) (= (bytes-length bs) count))
(raise (binary-problem (format "byte string length ~a" count) bs)))
bs)
(define (seq->hash xs) (make-hasheq xs))
(define (seq->list xs) (map cdr xs))
(define-macro (:bidi X) #'X)
(define (val->hash x)
(if (unparse-val)
(report (car (map cdr (hash->list x))))
(make-hasheq (list x))))
(define (bytes->integer len x)
(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)]))
(define (integer->bytes len x)
(cond
[(= len 1) (bytes x)]
[else (integer->integer-bytes x len #f #f)]))
(define (bytes->bitfield bs)
(for*/list ([b (in-bytes bs)]
[idx (in-range 8)])
(bitwise-bit-set? b idx)))
(define (bytes->string bs)
(bytes->string/latin-1 bs))
#|
(define-rule gif (:seq signature version logical-screen-descriptor (:bidi seq->hash)))
(define-rule signature (:atomic 3 (:bidi bytes->string)))
(define-rule version (:atomic 3 (:bidi bytes->string)))
(define-rule logical-screen-descriptor (:seq width height packed bgcolor-idx aspect (:bidi seq->list)))
(define-rule width (:atomic 2 (:bidi bytes->int)))
(define-rule height (:atomic 2 (:bidi bytes->int)))
(define-rule packed (:atomic 1 (:bidi bytes->bitfield)))
(define-rule bgcolor-idx (:atomic 1 (:bidi bytes->int)))
(define-rule aspect (:atomic 1 (:bidi bytes->int)))
|#
(define (:atomic count #:type [type #f])
(λ (x)
(define-values (input-proc output-proc)
(match type
[integer?
(values (curry bytes->integer count)
(curry integer->bytes count))]
[else (values identity identity)]))
(if (input-port? x)
(input-proc (read-bytes-exact count x))
(let ([result (output-proc x)])
(unless (and (bytes? result) (= (bytes-length result) count))
(raise (binary-problem (format "byte string length ~a" count) result)))
result))))
(define (list->hash-with-keys keys vals)
(make-hash (map cons keys vals)))
(define (hash->list-with-keys keys h)
(for/list ([k (in-list keys)])
(hash-ref h k)))
(define (procedure-name proc)
(string->symbol (cadr (regexp-match #rx"^#<procedure:(.*?)>$" (with-output-to-string (λ () (display proc)))))))
(define (hash-has-keys? h keys)
(define (sortation xs) (sort xs #:key symbol->string string<?))
(equal? (sortation (hash-keys h)) (sortation keys)))
(define (:seq #:type [type #f] . rule-procs)
(λ (x) (define-values (input-proc output-proc output-check)
(cond
[(equal? type hash?)
(define rule-proc-names (map procedure-name rule-procs))
(values (curry list->hash-with-keys rule-proc-names)
(curry hash->list-with-keys rule-proc-names)
(λ (x)
(unless (and (hash? x) (hash-has-keys? x rule-proc-names))
(raise (binary-problem (format "hash with ~a keys, namely ~a" (length rule-procs) rule-proc-names) x)))))]
[else (values identity identity
(λ (x)
(unless (and (list? x) (= (length rule-procs) (length x)))
(raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))]))
(match x
[(? input-port? p) (input-proc (map (λ (rule-proc) (rule-proc p)) rule-procs))]
[else
(output-check x)
(apply bytes-append (map (λ (rp xi) (rp xi)) rule-procs (output-proc x)))])))
(define-macro-cases :repeat
[(_ COUNT RULE-PROC ...) #'(λ (p) (append-map (λ (i) (list (RULE-PROC p) ...)) (range COUNT)))])
(define-macro-cases define-rule
[(_ ID RULE-PROC)
(with-pattern ([ID$ (suffix-id #'ID "$")])
#'(begin
(define (ID [x (current-input-port)])
(with-handlers ([binary-problem? (λ (exn)
(raise-result-error
'ID
(binary-problem-msg exn)
(binary-problem-val exn)))])
(RULE-PROC x)))
(struct ID$ (val) #:transparent)))])
(define-rule foo (:seq bar zam #:type hash?))
(define-rule bar (:atomic 1 #:type integer?))
(define-rule zam (:atomic 2 #:type integer?))
(define-rule foolist (:seq bar zam bar zam))
(check-equal? #"AB" (zam (zam (open-input-bytes #"AB"))) (zam 16961))
(check-equal? #"123" (foo (foo (open-input-bytes #"123"))) (foo '#hash((bar . 49) (zam . 13106))))
(foolist (open-input-bytes #"123456"))
(foolist '(49 13106 52 13877))
(require rackunit)
#;(check-equal? (parse-with-template "test.gif" gif)
(cons 'gif
(make-hasheq (list (cons 'logical-screen-descriptor '(162 162 (#f #t #f #f #f #t #f #t) 0 0))
'(signature . "GIF")
'(version . "87a")))))
#;(define parse-width-bytes (make-byte-parser width))
Write Preview
Loading…
Cancel
Save