From 01c41aad484d84a75fcb7628a6680d432c0e3d9a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 3 Jun 2017 11:54:30 -0700 Subject: [PATCH] more --- pitfall/.gitignore | 16 ++++ pitfall/binparser/gif-parse.rkt | 12 +-- pitfall/binparser/main.rkt | 154 ++++++++++++++++++++------------ 3 files changed, 119 insertions(+), 63 deletions(-) create mode 100644 pitfall/.gitignore diff --git a/pitfall/.gitignore b/pitfall/.gitignore new file mode 100644 index 00000000..89c83e65 --- /dev/null +++ b/pitfall/.gitignore @@ -0,0 +1,16 @@ +# for Racket +compiled/ +*~ + +# for Mac OS X +.DS_Store +.AppleDouble +.LSOverride +Icon + +# Thumbnails +._* + +# Files that might appear on external disk +.Spotlight-V100 +.Trashes diff --git a/pitfall/binparser/gif-parse.rkt b/pitfall/binparser/gif-parse.rkt index 0e663cd0..1c9eb15d 100644 --- a/pitfall/binparser/gif-parse.rkt +++ b/pitfall/binparser/gif-parse.rkt @@ -10,18 +10,18 @@ (define-rule logical-screen-descriptor (:seq [width (:bytes 2 #:type integer?)] [height (:bytes 2 #:type integer?)] - [lsd-flags (:seq [reserved (:bits 3)] - [disposal (:bits 3)] - [user-input (:bits 1)] - [transparent (:bits 1)] - #:type hash?)] + [lsd-flags (:bitfield [reserved (:bits 3)] + [disposal (:bits 3 #:type integer?)] + [user-input (:bits 1 #:type boolean?)] + [transparent (:bits 1 #:type boolean?)] + #:type hash?)] [bgcolor-idx (:bytes 1 #:type integer?)] [aspect (:bytes 1 #:type integer?)] #:type hash?)) (gif (open-input-file "test.gif")) -#;(check-equal? (gif (gif (open-input-file "test.gif"))) (read-bytes 13 (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) diff --git a/pitfall/binparser/main.rkt b/pitfall/binparser/main.rkt index 0effa6f9..c8ed278c 100644 --- a/pitfall/binparser/main.rkt +++ b/pitfall/binparser/main.rkt @@ -1,9 +1,8 @@ #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 define-rules let-rule :bytes :seq :repeat :bits) -(provide string/utf-8? string/latin-1? string/ascii? bitfield?) +(require racket/match racket/function racket/port br/define sugar/list racket/list racket/bytes) +(provide (all-defined-out)) (define string/utf-8? #t) (define string/latin-1? 'string/latin-1?) @@ -13,6 +12,7 @@ (struct binary-problem (msg val) #:transparent) (define bitfield #f) +(define (reset-bitfield!) (set! bitfield #f)) (define (read-bits-exact count p) (unless (pair? bitfield) (set! bitfield (bytes->bitfield (read-bytes 1 p)))) @@ -40,18 +40,18 @@ (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)))))) + (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)))) + (char->integer c)))) (define (bytes->bitfield bs) (for*/list ([b (in-bytes bs)] [idx (in-range 8)]) - (bitwise-bit-set? b idx))) + (bitwise-bit-set? b idx))) (define (bitfield->bytes bf) (unless (zero? (modulo (length bf) 8)) @@ -61,29 +61,49 @@ (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))))))) + (loop rest (cons (bitfield->integer bits) acc))))))) (module+ test (check-equal? (bitfield->bytes (bytes->bitfield #"AB")) #"AB")) +(define (bitfield->integer bits) + (for/sum ([b (in-list bits)] + [pow (in-range 8)] + #:when b) + (expt 2 pow))) + +(define (integer->bitfield len int) + (define digits (reverse (string->list (number->string int 2)))) + (append (map (curry char=? #\1) digits) (make-list (- len (length digits)) #f))) + + (define bit? boolean?) -(define (:bits count #:type [type #f]) +(define-macro-cases case-proc + [(N PROC [TEST-PROC . EXPRS] ... [else . ELSE-EXPRS]) + #'(cond [(equal? PROC TEST-PROC) . EXPRS] ... [else . ELSE-EXPRS])] + [(N ARG ...) #'(N ARG ... [else (void)])]) + + +(define (:bits count #:type [type list?]) (procedure-rename (λ (x) (define-values (input-proc output-proc) - (cond - [(equal? type bitfield?) (values bytes->bitfield bitfield->bytes)] - [else (values identity identity)])) + (case-proc type + [integer? (values bitfield->integer (curry integer->bitfield count))] + [bitfield? (values bytes->bitfield bitfield->bytes)] + [boolean? + (unless (= 1 count) + (raise-argument-error ':bits "boolean type only supported for 1-bit" count)) + (values (λ (bitfield) (car bitfield)) (λ (boolean) (list boolean)))] + [list? (values identity identity)] + [else (raise-argument-error ':bits "not a supported type" type)])) (if (input-port? x) (input-proc (read-bits-exact count x)) (let ([result (output-proc x)]) - (unless (andmap bit? result) (= (length result) count)) - (raise (binary-problem (format "bit string length ~a" count) result)) + (unless (and (andmap bit? result) (= (length result) count)) + (raise (binary-problem (format "bit string length ~a" count) result))) result))) (gensym 'bits-))) @@ -91,12 +111,13 @@ (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)])) + (case-proc type + [integer? (values (curry bytes->integer count) + (curry integer->bytes count))] + [string/ascii? (values bytes->ascii ascii->bytes)] + [bitfield? (values bytes->bitfield bitfield->bytes)] + [list? (values identity identity)] + [else (raise-argument-error ':bytes "not a supported type" type)])) (if (input-port? x) (input-proc (read-bytes-exact count x)) @@ -110,7 +131,7 @@ (define (hash->list-with-keys keys h) (for/list ([k (in-list keys)]) - (hash-ref h k))) + (hash-ref h k))) (define (procedure-name proc) (string->symbol (cadr (regexp-match #rx"^#$" (with-output-to-string (λ () (display proc))))))) @@ -125,36 +146,47 @@ xs (for/list ([x (in-list xs)] [idx (in-naturals 1)]) - (string->symbol (format "~a-~a" x idx))))) - - -(require (for-syntax sugar/debug)) -(define-macro (:seq ARG ...) - (with-pattern ([(ARG ...) (pattern-case-filter #'(ARG ...) - [(NAME RULE-PROC) #'(let () (define-rule NAME RULE-PROC) NAME)] - [ELSE #'ELSE])]) - #'(seq-inner ARG ...))) - -(define (seq-inner #: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))) + (string->symbol (format "~a-~a" x idx))))) + +(define-macro (define-seq-style-rule ID ID-INNER) + #'(define-macro (ID ARG (... ...)) + (with-pattern ([(ARG (... ...)) (pattern-case-filter #'(ARG (... ...)) + [(NAME RULE-PROC) #'(let () (define-rule NAME RULE-PROC) NAME)] + [ELSE #'ELSE])]) + #'(ID-INNER ARG (... ...))))) + +(define-seq-style-rule :bitfield bitfield-inner) + +(define (bitfield-inner #:type [type list?] . rule-procs) + ((make-inner-proc (λ (xs) (bitfield->bytes (append* xs))) 'bitfield) type rule-procs)) + +(define-seq-style-rule :seq seq-inner) + +(define (seq-inner #:type [type list?] . rule-procs) + ((make-inner-proc bytes-append* 'seq) type rule-procs)) + +(define (make-inner-proc post-proc sym) + (λ (type rule-procs) + (procedure-rename + (λ (x) (define-values (input-proc output-proc output-check) + (case-proc 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)))))] + [list? (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)))))] + [else (raise-argument-error sym "not a supported type" type)])) + (match x + [(? input-port? p) (input-proc (map (λ (rule-proc) (rule-proc p)) rule-procs))] + [else + (output-check x) + (post-proc (map (λ (rp xi) (rp xi)) rule-procs (output-proc x)))])) (gensym sym)))) (define (:repeat count . rule-procs) @@ -195,6 +227,14 @@ (hashrule '#hash((zam-4 . 13877) (bar-3 . 52) (zam-2 . 13106) (bar-1 . 49) (bar-5 . 55)))) - (define-rule flag (:bits 4)) - (check-equal? (flag (open-input-bytes #"A")) '(#t #f #f #f)) + (define-rule flag8 (:bits 8)) + (check-equal? (flag8 (open-input-bytes #"A")) '(#t #f #f #f #f #f #t #f)) + + (define-rule flag4 (:bits 4)) + (check-equal? (flag4 (open-input-bytes #"A")) '(#t #f #f #f)) + + (reset-bitfield!) + (define-rule bitint (:bits 8 #:type integer?)) + (check-equal? (bitint (open-input-bytes #"A")) 65) + (check-equal? (bitint 65) '(#t #f #f #f #f #f #t #f)) ) \ No newline at end of file