From 3f2feede6a5bf917f37f3e285080b94b53336565 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 4 Jun 2017 11:58:58 -0700 Subject: [PATCH] squish --- pitfall/binparser/gif-parse.rkt | 59 ++++++++++++++++++++++++++------- pitfall/binparser/main.rkt | 39 +++++++++++++--------- 2 files changed, 71 insertions(+), 27 deletions(-) diff --git a/pitfall/binparser/gif-parse.rkt b/pitfall/binparser/gif-parse.rkt index 7579266e..20d7b69c 100644 --- a/pitfall/binparser/gif-parse.rkt +++ b/pitfall/binparser/gif-parse.rkt @@ -3,11 +3,10 @@ ;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp -(define-rule gif (:seq [signature (:bytes 3 #:type string/ascii?)] - [version (:bytes 3 #:type string/ascii?)] - logical-screen-descriptor - global-color-table - #:type assoc?)) +(define-rule gif-header (:seq [signature (:bytes 3 #:type string/ascii?)] + [version (:bytes 3 #:type string/ascii?)] + logical-screen-descriptor + #:type assoc?)) (define-rule logical-screen-descriptor (:seq [width (:bytes 2 #:type integer?)] [height (:bytes 2 #:type integer?)] @@ -20,20 +19,56 @@ [aspect (:bytes 1 #:type integer?)] #:type assoc?)) -(define-rule global-color-table (:repeat 4 (:bytes 3))) -#;(define-rule color (:bytes 3 #:type hex?)) +(define ip (open-input-file "sample.gif")) +(define gh (gif-header ip)) +gh -(define g (gif (open-input-file "sample.gif"))) +(define (global-color-quantity gh) + (expt 2 (add1 (dict-ref* gh 'logical-screen-descriptor 'lsd-flags 'global-color-table)))) -(define (global-color-quantity) - (define val (dict-ref (dict-ref (dict-ref g 'logical-screen-descriptor) 'lsd-flags) 'global-color-table)) - (expt 2 (add1 val))) +(define-rule color (:bytes 1 #:type hex?)) +(define-rule red color) +(define-rule green color) +(define-rule blue color) +(define-rule global-color-table (:repeat (global-color-quantity gh) (:seq red green blue #:type assoc?))) +(define gct (global-color-table ip)) +gct +(define-rule graphic-control-extension + (:seq [extension-introducer (:bytes 1 #:type hex?)] + [graphic-control-label (:bytes 1 #:type hex?)] + [byte-size (:bytes 1 #:type integer?)] + [gce-flags (:seq [transparent-color-flag (:bits 1 #:type boolean?)] + [user-input-flag (:bits 1 #:type boolean?)] + [disposal-method (:bits 3)] + [reserved (:bits 3)] + #:type assoc?)] + [delay-time (:bytes 2 #:type integer?)] + [transparent-color-idx (:bytes 1 #:type integer?)] + [block-terminator (:bytes 1 #:type hex?)] + #:type assoc?)) -g +(graphic-control-extension ip) + + +(define-rule image-descriptor + (:seq [image-separator (:bytes 1 #:type hex?)] + [left (:bytes 2 #:type integer?)] + [top (:bytes 2 #:type integer?)] + [width (:bytes 2 #:type integer?)] + [height (:bytes 2 #:type integer?)] + [id-flags (:seq [local-color-table-size (:bits 3 #:type integer?)] + [reserved (:bits 2)] + [sort-flag (:bits 1)] + [interlace-flag (:bits 1)] + [local-color-table-flag (:bits 1)] + #:type assoc?)] + #:type assoc?)) + +(image-descriptor ip) #;(check-equal? (gif (gif (open-input-file "sample.gif"))) (read-bytes 13 (open-input-file "sample.gif"))) diff --git a/pitfall/binparser/main.rkt b/pitfall/binparser/main.rkt index 3f92d47c..e9e64815 100644 --- a/pitfall/binparser/main.rkt +++ b/pitfall/binparser/main.rkt @@ -1,9 +1,12 @@ #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 racket/bytes racket/string) +(require racket/match racket/function racket/port br/define sugar/list racket/list racket/bytes racket/string racket/dict) (provide (all-defined-out)) +(define (dict-ref* d . keys) + (foldl (λ (key d) (dict-ref d key)) d keys)) + (define string/utf-8? #t) (define string/latin-1? 'string/latin-1?) (define string/ascii? 'string/ascii?) @@ -134,6 +137,8 @@ [integer? (values (curry bytes->integer count) (curry integer->bytes count))] [string/ascii? (values bytes->ascii ascii->bytes)] + [string/utf-8? (values bytes->string/utf-8 string->bytes/utf-8)] + [string/latin-1? (values bytes->string/latin-1 string->bytes/latin-1)] [bitfield? (values bytes->bitfield bitfield->bytes)] [bytes? (values identity identity)] [hex? (values bytes->hexline hexline->bytes)] @@ -168,15 +173,17 @@ (if (members-unique? xs) xs (for/list ([x (in-list xs)] - [idx (in-naturals 1)]) + [idx (in-naturals)]) (string->symbol (format "~a-~a" x idx))))) +(define-for-syntax (process-rule-proc-args args) + (pattern-case-filter args + [(NAME RULE-PROC) #'(let () (define-rule NAME RULE-PROC) NAME)] + [ELSE #'ELSE])) + (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-macro (ID . ARGS) + #`(ID-INNER #,@(process-rule-proc-args #'ARGS)))) (define-seq-style-rule :bitfield bitfield-inner) @@ -191,7 +198,8 @@ (define (seq-inner #:type [type list?] . rule-procs) ((make-inner-proc bytes-append* ':seq) type rule-procs)) -(define-seq-style-rule :repeat repeat-inner) +(define-macro (:repeat COUNT-EXPR . ARGS) + #`(repeat-inner COUNT-EXPR #,@(process-rule-proc-args #'ARGS))) (define (repeat-inner #:type [type list?] count . rule-procs) ((make-inner-proc bytes-append* ':repeat) type (append* (make-list count rule-procs)))) @@ -262,15 +270,16 @@ (define-rule foolist (:seq bar zam bar zam)) (check-equal? #"123456" (foolist (foolist (open-input-bytes #"123456"))) (foolist '(49 13106 52 13877))) + #| (define-rule bam (:bytes 1)) (define-rule bams (:seq bam bam bam)) (define-rule rebams (:seq (:bytes 1) (:bytes 1) (:bytes 1))) (check-equal? (bams (open-input-bytes #"ABC")) (rebams (open-input-bytes #"ABC"))) - +|# (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)))) + (hashrule '#hash((zam-3 . 13877) (bar-2 . 52) (zam-1 . 13106) (bar-0 . 49) (bar-4 . 55)))) (define-rule flag8 (:bits 8)) @@ -284,10 +293,10 @@ (check-equal? (bitint (open-input-bytes #"A")) 65) (check-equal? (bitint 65) '(#t #f #f #f #f #f #t #f)) - #| + (reset-bitfield!) - (define-rule rpt (:repeat 3 (:bytes 1))) - (rpt (open-input-bytes #"ABC")) - (rpt (rpt (open-input-bytes #"ABC"))) -|# + (define-rule thing (:bytes 1)) + (define-rule rpt (:repeat 3 thing)) ; repeat has to use other identifier names, not direct rule procs + (check-equal? (rpt (rpt (open-input-bytes #"ABC"))) #"ABC") + ) \ No newline at end of file