From b1c615b2dc9098b5bb0215d853d1adc5f46ac713 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 5 Jun 2017 15:05:11 -0700 Subject: [PATCH] more better --- pitfall/binparser/gif-parse.rkt | 80 ++++++++++++++++++++------------- 1 file changed, 49 insertions(+), 31 deletions(-) diff --git a/pitfall/binparser/gif-parse.rkt b/pitfall/binparser/gif-parse.rkt index 20d7b69c..b28ea790 100644 --- a/pitfall/binparser/gif-parse.rkt +++ b/pitfall/binparser/gif-parse.rkt @@ -3,6 +3,9 @@ ;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp +(define ip (open-input-file "sample.gif")) + + (define-rule gif-header (:seq [signature (:bytes 3 #:type string/ascii?)] [version (:bytes 3 #:type string/ascii?)] logical-screen-descriptor @@ -10,29 +13,33 @@ (define-rule logical-screen-descriptor (:seq [width (:bytes 2 #:type integer?)] [height (:bytes 2 #:type integer?)] - [lsd-flags (:seq [global-color-table-size (:bits 3 #:type integer?)] - [sort (:bits 1 #:type boolean?)] - [resolution (:bits 3 #:type integer?)] - [global-color-table (:bits 1 #:type integer?)] - #:type assoc?)] + [lsd-flags (:bitfield [global-color-table-size (:bits 3 #:type integer?)] + [sort (:bits 1 #:type boolean?)] + [resolution (:bits 3 #:type integer?)] + [global-color-table (:bits 1 #:type integer?)] + #:type assoc?)] [bgcolor-idx (:bytes 1 #:type integer?)] [aspect (:bytes 1 #:type integer?)] #:type assoc?)) -(define ip (open-input-file "sample.gif")) (define gh (gif-header ip)) gh -(define (global-color-quantity gh) - (expt 2 (add1 (dict-ref* gh 'logical-screen-descriptor 'lsd-flags 'global-color-table)))) +(define (color-quantity table-size) + (expt 2 (add1 table-size))) + + -(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-rule hex-color (:bytes 1 #:type hex?)) +(define-rule red hex-color) +(define-rule green hex-color) +(define-rule blue hex-color) +(define-rule color (:seq red green blue)) +(define (global-color-quantity gh) + (color-quantity (dict-ref* gh 'logical-screen-descriptor 'lsd-flags 'global-color-table))) +(define-rule global-color-table (:repeat (global-color-quantity gh) color #:type assoc?)) (define gct (global-color-table ip)) gct @@ -41,11 +48,11 @@ gct (: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?)] + [gce-flags (:bitfield [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?)] @@ -61,20 +68,31 @@ gct [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?)] + [reserved (:bits 2)] + [sort-flag (:bits 1)] + [interlace-flag (:bits 1)] + [local-color-table-flag (:bits 1 #:type integer?)] + #:type assoc?)] #:type assoc?)) -(image-descriptor ip) +(define img-descriptor (image-descriptor ip)) + +(define (local-color-quantity gh) + (* (dict-ref* img-descriptor 'id-flags 'local-color-table-flag) + (color-quantity (dict-ref* img-descriptor 'id-flags 'local-color-table-size)))) +(define-rule local-color-table (:repeat (local-color-quantity gh) color #:type assoc?)) +(define lct (local-color-table ip)) + +lct + +(define-rule lzw-minimum-code-size (:bytes 1 #:type integer?)) + +(lzw-minimum-code-size ip) + +(for/list ([block-len (in-port read-byte ip)] + #:break (zero? block-len)) + ((:bytes block-len #:type hex?) ip)) -#;(check-equal? (gif (gif (open-input-file "sample.gif"))) (read-bytes 13 (open-input-file "sample.gif"))) +(define-rule trailer (:bytes 1 #:type hex?)) -(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"))))) +(trailer ip) \ No newline at end of file