From 510c7b2071c8d778d68f2cf31658824414fcbd3c Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Wed, 20 Apr 2016 23:20:17 -0700
Subject: [PATCH] start chip8

---
 beautiful-racket-lib/br/define.rkt |  6 ++-
 beautiful-racket/br/demo/chip8.rkt | 76 ++++++++++++++++++++++++++++++
 2 files changed, 81 insertions(+), 1 deletion(-)
 create mode 100644 beautiful-racket/br/demo/chip8.rkt

diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt
index 3a06813..9c9ba65 100644
--- a/beautiful-racket-lib/br/define.rkt
+++ b/beautiful-racket-lib/br/define.rkt
@@ -84,7 +84,11 @@
                                #'(zam x x))) (foo 42)) 84) 
   ;; todo: error from define not trapped by check-exn 
   #;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*)))
-  (check-equal? fortytwo 42))
+  (check-equal? fortytwo 42)
+  (begin
+    (br:define #'(redefine ID) #'(define ID 42))
+    (redefine zoombar)
+    (check-equal? zoombar 42)))
 
 
 ;; todo: support `else` case
diff --git a/beautiful-racket/br/demo/chip8.rkt b/beautiful-racket/br/demo/chip8.rkt
new file mode 100644
index 0000000..b294901
--- /dev/null
+++ b/beautiful-racket/br/demo/chip8.rkt
@@ -0,0 +1,76 @@
+#lang br
+;http://www.multigesture.net/articles/how-to-write-an-emulator-chip-8-interpreter/
+; http://devernay.free.fr/hacks/chip8/C8TECH10.HTM
+; http://mattmik.com/files/chip8/mastering/chip8.html
+
+(define (explode-bytes val)
+  (cond
+    [(zero? val) (list 0)]
+    [else
+     (define-values (bytes residual)
+       (for/fold ([bytes empty][residual val])
+                 ([i (in-naturals)]
+                  #:break (zero? residual))
+         (define m (modulo residual 16))
+         (values (cons m bytes) (arithmetic-shift residual -4))))
+     bytes]))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (explode-bytes #x2B45) (list #x2 #xB #x4 #x5))
+  (check-equal? (explode-bytes #xCD) (list #xC #xD))
+  (check-equal? (explode-bytes #xA) (list #xA))
+  (check-equal? (explode-bytes #x0) (list #x0)))
+
+(define (glue-bytes bytes)
+  (for/sum ([b (in-list (reverse bytes))]
+            [i (in-naturals)])
+           (* b (expt 16 i))))
+
+(module+ test
+  (check-equal? #x2B45 (glue-bytes (list #x2 #xB #x4 #x5)))
+  (check-equal? #xCD (glue-bytes (list #xC #xD)))
+  (check-equal? #xA (glue-bytes (list #xA)))
+  (check-equal? #x0 (glue-bytes (list #x0))))
+
+(define-syntax (define-memory-vector stx)
+  (syntax-case stx ()
+    [(_ ID [FIELD LENGTH SIZE] ...)
+     (with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
+                   [(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
+                   [(FIELD-OFFSET ...) (reverse (cdr
+                                                 (for/fold ([offsets '(0)])
+                                                           ([len (in-list (syntax->list #'(LENGTH ...)))]
+                                                            [size (in-list  (syntax->list #'(SIZE ...)))])
+                                                   (cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
+       #'(begin
+           (define ID (make-vector (+ (* LENGTH SIZE) ...)))
+           (define (ID-FIELD-REF idx)
+             (unless (< idx LENGTH)
+               (raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
+             (glue-bytes
+              (for/list ([i (in-range SIZE)])
+                        (vector-ref ID (+ FIELD-OFFSET i idx)))))
+           ...
+           (define (ID-FIELD-SET! idx val)
+             (unless (< idx LENGTH)
+               (raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
+             (unless (< val (expt 16 SIZE))
+               (raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
+             (for ([i (in-range SIZE)]
+                   [b (in-list (explode-bytes val))])
+                  (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
+
+(define-memory-vector chip 
+  [opcode 1 2] ; two bytes
+  [memory 4096 1] ; one byte per
+  [V 16 1] ; one byte per
+  [I 3 1] ; index register, 0x000 to 0xFFF
+  [pc 3 1] ; program counter, 0x000 to 0xFFF
+  [gfx (* 64 32) 1] ; pixels
+  [delay_timer 1 1]
+  [sound_timer 1 1]
+  [stack 16 2] ; 2 bytes each
+  [sp 1 1] ; stack pointer
+  [key 16 1]) ; keys
+