From f9f726391a094773b0a63ebc39fcb8fbce02eda8 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Thu, 1 Jun 2017 16:43:55 -0700
Subject: [PATCH] gifparse

---
 pitfall/pitfall/binparser/gif-parse.rkt | 56 +++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 pitfall/pitfall/binparser/gif-parse.rkt

diff --git a/pitfall/pitfall/binparser/gif-parse.rkt b/pitfall/pitfall/binparser/gif-parse.rkt
new file mode 100644
index 00000000..2d623265
--- /dev/null
+++ b/pitfall/pitfall/binparser/gif-parse.rkt
@@ -0,0 +1,56 @@
+#lang br
+(require "../binprint.rkt" racket/file)
+
+;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp
+
+(define-macro-cases :read
+  [(N COUNT) #'(N COUNT (λ (x) x))]
+  [(N COUNT PROC) #'(λ () (PROC (read-bytes COUNT)))])
+
+(define-macro (:seq SEQ ...)
+  #'(λ () (foldl (λ (f h) (f h)) (make-hasheq) (list SEQ ...))))
+
+(define-macro (:element ID WHAT)
+  #'(define ID (λ ([h (make-hasheq)])
+                 (hash-set! h 'ID (WHAT))
+                 h)))
+
+(define (bytes->int bs)
+  (if (= (bytes-length bs) 1)
+      (bytes-ref bs 0)
+      (integer-bytes->integer bs #f #f)))
+
+(define (bytes->bitfield bs)
+  (for*/list ([b (in-bytes bs)]
+              [idx (in-range 8)])
+    (bitwise-bit-set? b idx)))
+
+(:element gif (:seq signature version logical-screen-descriptor))
+(:element signature (:read 3 bytes->string/latin-1))
+(:element version (:read 3 bytes->string/latin-1))
+
+(:element logical-screen-descriptor (:seq width height packed bgcolor-idx aspect))
+(:element width (:read 2 bytes->int))
+(:element height (:read 2 bytes->int))
+(:element packed (:read 1 bytes->bitfield))
+(:element bgcolor-idx (:read 1 bytes->int))
+(:element aspect (:read 1 bytes->int))
+
+
+(define (parse-with-template file template)
+  (parameterize ([current-input-port (open-input-file file)])
+    (template)))
+
+(require rackunit)
+(check-equal? (parse-with-template "test.gif" gif)
+              (make-hasheq (list
+                            (cons 'gif
+                                  (make-hasheq (list (cons 'logical-screen-descriptor
+                                                           (make-hasheq (list
+                                                                         '(aspect . 0)
+                                                                         '(width . 162)
+                                                                         '(bgcolor-idx . 0)
+                                                                         '(packed . (#f #t #f #f #f #t #f #t))
+                                                                         '(height . 162))))
+                                                     '(signature . "GIF")
+                                                     '(version . "87a")))))))