# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1479397838 0
# Node ID 8e58d7eb4d032134b7ccfd0107e76f51e23b7b25
# Parent  fd215349e7bb91b01d6cc05ea1fcc0c189baab48
More work.  Things appear on the screen now.

diff -r fd215349e7bb -r 8e58d7eb4d03 package.lisp
--- a/package.lisp	Wed Nov 16 20:54:13 2016 +0000
+++ b/package.lisp	Thu Nov 17 15:50:38 2016 +0000
@@ -5,8 +5,7 @@
     :iterate
     :cl-arrows
     :chip8.quickutils)
-  (:export)
-  (:shadow :bit))
+  (:export))
 
 
 (defpackage :chip8.gui
diff -r fd215349e7bb -r 8e58d7eb4d03 src/emulator.lisp
--- a/src/emulator.lisp	Wed Nov 16 20:54:13 2016 +0000
+++ b/src/emulator.lisp	Thu Nov 17 15:50:38 2016 +0000
@@ -1,15 +1,26 @@
 (in-package :chip8)
 
-(setf *print-length* 10)
+(setf *print-length* 16)
 (setf *print-base* 10)
 (declaim (optimize (speed 1) (safety 3) (debug 3)))
-(declaim (optimize (speed 3) (safety 0) (debug 3)))
+; (declaim (optimize (speed 3) (safety 1) (debug 3)))
+
+
+;;;; Constants ----------------------------------------------------------------
+(defconstant +screen-width+ 64)
+(defconstant +screen-height+ 32)
+(defconstant +memory-size+ (* 1024 4))
+(defconstant +timer-tick+ (round (* 1/60 internal-time-units-per-second)))
 
 
 ;;;; Types --------------------------------------------------------------------
+(deftype int4 () '(unsigned-byte 4))
 (deftype int8 () '(unsigned-byte 8))
 (deftype int12 () '(unsigned-byte 12))
 (deftype int16 () '(unsigned-byte 16))
+(deftype x-coord () `(integer 0 (,+screen-width+)))
+(deftype y-coord () `(integer 0 (,+screen-height+)))
+(deftype memory-index () `(integer 0 (,+memory-size+)))
 
 (deftype basic-array (element-type size)
   `(simple-array ,(upgraded-array-element-type element-type) (,size)))
@@ -19,7 +30,7 @@
 
 
 ;;;; Utils --------------------------------------------------------------------
-(declaim (inline not= +_8 -_8 chop cat-bytes))
+(declaim (inline not= +_8 -_8 chop cat-bytes get-bit bcd))
 
 (defun make-simple-array (element-type size &rest args)
   (apply #'make-array size
@@ -37,6 +48,9 @@
 (defun cat-bytes (high-order low-order)
   (dpb high-order (byte 8 8) low-order))
 
+(defun get-bit (position integer)
+  (ldb (byte 1 position) integer))
+
 (defun +_8 (x y)
   (let ((result (+ x y)))
     (values (chop 8 result)
@@ -47,6 +61,11 @@
     (values (chop 8 result)
             (if (> x y) 1 0))))
 
+(defun bcd (integer)
+  (values (-<> integer (floor <> 100) (mod <> 10))
+          (-<> integer (floor <> 10) (mod <> 10))
+          (-<> integer (floor <> 1) (mod <> 10))))
+
 (defmacro macro-map ((lambda-list items) &rest body)
   (with-gensyms (macro)
     `(macrolet ((,macro ,(ensure-list lambda-list) ,@body))
@@ -67,17 +86,16 @@
         :read-only t)
   (awaiting-key nil
                 :type (or null (integer 0 15)))
-  (video-raw (error "Required")
-             :type (basic-array fixnum #.(* 32 64))
-             :read-only t)
-  (video (error "Required")
-         :type (array fixnum (32 64)) ; row major :\
+  (video (make-simple-array 'fixnum (* 32 64))
+         :type (basic-array fixnum #.(* 32 64))
          :read-only t)
   (video-dirty t :type boolean)
   (index 0 :type int16)
-  (program-counter 0 :type int12)
+  (program-counter #x200 :type int12)
   (delay-timer 0 :type int8)
   (sound-timer 0 :type int8)
+  (timer-clock +timer-tick+ :type fixnum)
+  (timer-previous 0 :type fixnum)
   (random-state (make-random-state t)
                 :type random-state
                 :read-only t)
@@ -88,33 +106,111 @@
          :type (stack 16)))
 
 (defun make-chip ()
-  (let* ((video-raw (make-simple-array 'fixnum (* 32 64)))
-         (video (make-array '(32 64)
-                  :displaced-to video-raw
-                  :element-type 'fixnum)))
-    (make-chip% :video-raw video-raw :video video)))
+  (let ((chip (make-chip%)))
+    (load-font chip)
+    chip))
 
 (define-with-macro chip
   memory registers
+  flag
   index program-counter
-  delay-timer sound-timer
+  delay-timer sound-timer timer-clock timer-previous
   random-state
-  video video-raw video-dirty
+  video video-dirty
   keys awaiting-key
   stack)
 
+(declaim (inline chip-flag (setf chip-flag)))
+
+(defun chip-flag (chip)
+  (aref (chip-registers chip) #xF))
+
+(defun (setf chip-flag) (new-value chip)
+  (setf (aref (chip-registers chip) #xF) new-value))
+
 
 ;;;; Graphics -----------------------------------------------------------------
-(defmacro vref (video x y)
-  `(aref ,video ,y ,x))
+(declaim (inline font-location vref (setf vref))
+         (ftype (function (chip int8 int8 int4) null) draw-sprite)
+         (ftype (function (chip x-coord y-coord) fixnum) vref)
+         (ftype (function (fixnum chip x-coord y-coord) fixnum) (setf vref)))
+
+
+(defun vref (chip x y)
+  (aref (chip-video chip) (+ (* 64 y) x)))
+
+(defun (setf vref) (new-value chip x y)
+  (setf (aref (chip-video chip) (+ (* 64 y) x))
+        new-value))
+
+
+(defun load-font (chip)
+  ;; Thanks http://www.multigesture.net/articles/how-to-write-an-emulator-chip-8-interpreter/
+  (replace (chip-memory chip)
+           (vector #xF0 #x90 #x90 #x90 #xF0 ; 0
+                   #x20 #x60 #x20 #x20 #x70 ; 1
+                   #xF0 #x10 #xF0 #x80 #xF0 ; 2
+                   #xF0 #x10 #xF0 #x10 #xF0 ; 3
+                   #x90 #x90 #xF0 #x10 #x10 ; 4
+                   #xF0 #x80 #xF0 #x10 #xF0 ; 5
+                   #xF0 #x80 #xF0 #x90 #xF0 ; 6
+                   #xF0 #x10 #x20 #x40 #x40 ; 7
+                   #xF0 #x90 #xF0 #x90 #xF0 ; 8
+                   #xF0 #x90 #xF0 #x10 #xF0 ; 9
+                   #xF0 #x90 #xF0 #x90 #x90 ; A
+                   #xE0 #x90 #xE0 #x90 #xE0 ; B
+                   #xF0 #x80 #x80 #x80 #xF0 ; C
+                   #xE0 #x90 #x90 #x90 #xE0 ; D
+                   #xF0 #x80 #xF0 #x80 #xF0 ; E
+                   #xF0 #x80 #xF0 #x80 #x80) ; F
+           :start1 #x50))
+
+(defun font-location (character)
+  (+ #x50 (* character 5)))
+
+
+(defun draw-sprite (chip start-x start-y size)
+  (with-chip (chip)
+    (assert (< (+ index size) +memory-size+) (index)
+      "Sprite data of size ~D starting at #x~4,'0X would be out of bounds"
+      size index)
+    ; (format t "Drawing sprite at ~d ~d~%" start-x start-y)
+    (setf flag 0)
+    (iterate
+      (declare (iterate:declare-variables))
+      (for (the fixnum y) :from start-y :below (+ start-y size))
+      (for (the y-coord screen-y) = (mod y 32))
+      (for (the fixnum i) :from index)
+      (for sprite = (aref memory i))
+      (iterate (declare (iterate:declare-variables))
+               (for (the fixnum x) :from start-x)
+               (for (the x-coord screen-x) = (mod x 64))
+               (for (the fixnum col) :from 7 :downto 0)
+               (for (the fixnum old-pixel) = (vref chip screen-x screen-y))
+               (for (the fixnum new-pixel) = (get-bit col sprite))
+               ; (when (= old-pixel new-pixel 1)
+               ;   (setf flag 1))
+               (when (and (plusp old-pixel) (plusp new-pixel))
+                 (setf flag 1))
+               ; (setf (vref chip screen-x screen-y)
+               ;       (logxor old-pixel new-pixel))
+               (setf (vref chip screen-x screen-y)
+                     (cond
+                       ((and (plusp old-pixel) (plusp new-pixel)) 0)
+                       ((or (plusp old-pixel) (plusp new-pixel)) 255)
+                       (t 0)))))
+    (setf video-dirty t))
+  nil)
 
 
 ;;;; Keyboard -----------------------------------------------------------------
+(declaim (ftype (function (chip (integer 0 (16)))) keydown keyup))
+
 (defun keydown (chip key)
   (with-chip (chip)
     (setf (aref keys key) t)
-    (when awaiting-key
-      (setf (aref registers awaiting-key) key
+    (when-let* ((waiting-for awaiting-key))
+      (setf (aref registers waiting-for) key
             awaiting-key nil))))
 
 (defun keyup (chip key)
@@ -163,13 +259,13 @@
     (setf ,destination ,source)))
 
 (define-opcode op-cls ()                                ;; CLS
-  (fill video-raw 0)
+  (fill video 0)
   (setf video-dirty t))
 
 (define-opcode op-jp-imm (_ (target 3))                 ;; JP addr
   (setf program-counter target))
 
-(define-opcode op-jp-imm+reg (_ (target 3))             ;; JP V_0 + addr
+(define-opcode op-jp-imm+reg (_ (target 3))             ;; JP V0 + addr
   (setf program-counter (+ target (register 0))))
 
 (define-opcode op-call (_ (target 3))                   ;; CALL addr
@@ -180,15 +276,15 @@
   (setf program-counter (vector-pop stack)))
 
 (macro-map                                              ;; ADD/SUB (8-bit)
-    ((name op source-arg source-expr)
-     ((op-add-reg<imm +_8 (immediate 2) immediate)
-      (op-add-reg<reg +_8 (ry 1) (register ry))
-      (op-sub-reg<reg -_8 (ry 1) (register ry))))
+  ((name op source-arg source-expr)
+   ((op-add-reg<imm +_8 (immediate 2) immediate)
+    (op-add-reg<reg +_8 (ry 1) (register ry))
+    (op-sub-reg<reg -_8 (ry 1) (register ry))))
   `(define-opcode ,name (_ rx ,source-arg)
     (multiple-value-bind (result carry)
         (,op (register rx) ,source-expr)
       (setf (register rx) result
-            (register #xF) carry))))
+            flag carry))))
 
 (define-opcode op-add-index<reg (_ r)                   ;; ADD I, Vx (16-bit)
   (zapf index (chop 16 (+ % (register r)))))
@@ -197,16 +293,16 @@
   (multiple-value-bind (result carry)
       (-_8 (register ry) (register rx)) ; subtraction order is swapped for SUBN
     (setf (register rx) result
-          (register #xF) carry)))
+          flag carry)))
 
 (macro-map                                              ;; SE/SNE
-  ((name test x-arg y-arg)
-   ((op-se-reg-imm  =    (r 1) (immediate 2))
-    (op-sne-reg-imm not= (r 1) (immediate 2))
-    (op-se-reg-reg  =    (rx 1) (ry 1))
-    (op-sne-reg-reg not= (rx 1) (ry 1))))
+  ((name test x-arg x-form y-arg y-form)
+   ((op-se-reg-imm  =    (r 1)  (register r)  (immediate 2) immediate)
+    (op-sne-reg-imm not= (r 1)  (register r)  (immediate 2) immediate)
+    (op-se-reg-reg  =    (rx 1) (register rx) (ry 1)        (register ry))
+    (op-sne-reg-reg not= (rx 1) (register rx) (ry 1)        (register ry))))
   `(define-opcode ,name (_ ,x-arg ,y-arg)
-    (when (,test ,(car x-arg) ,(car y-arg))
+    (when (,test ,x-form ,y-form)
       (incf program-counter 2))))
 
 (macro-map                                              ;; AND/OR/XOR
@@ -218,7 +314,7 @@
     (zapf (register destination)
           (,function % (register source)))))
 
-(define-opcode op-rnd (_ r (mask 2))                    ;; RND
+(define-opcode op-rand (_ r (mask 2))                   ;; RND
   (setf (register r)
         (logand (random 256 random-state) mask)))
 
@@ -230,18 +326,37 @@
   (when (not (aref keys (register r)))
     (incf program-counter 2)))
 
-(define-opcode op-ld-mem<regs (_ n _ _)                 ;; LD [I] < V_n
+(define-opcode op-ld-mem<regs (_ n _ _)                 ;; LD [I] < Vn
   (replace memory registers :start1 index :end2 n))
 
-(define-opcode op-ld-regs<mem (_ n _ _)                 ;; LD V_n < [I]
+(define-opcode op-ld-regs<mem (_ n _ _)                 ;; LD Vn < [I]
   (replace registers memory :end1 n :start2 index))
 
 (define-opcode op-ld-reg<key (_ r _ _)                  ;; LD Vx, Key (await)
   (setf awaiting-key r))
 
+(define-opcode op-shr (_ r _ _)                         ;; SHR
+  (let ((value (register r)))
+    (setf flag (get-bit 0 value)
+          (register r) (ash value -1))))
 
-(define-opcode op-unknown ((instruction 4))
-  (error "Unknown instruction: #x~4,'0X" instruction))
+(define-opcode op-shl (_ r _ _)                         ;; SHL
+  (let ((value (register r)))
+    (setf flag (get-bit 7 value)
+          (register r) (chop 8 (ash value 1)))))
+
+(define-opcode op-ld-font<vx (_ r _ _)                  ;; LD F, Vx
+  (setf index (font-location (register r))))
+
+(define-opcode op-ld-bcd<vx (_ r _ _)                   ;; LD B, Vx
+  (multiple-value-bind (hundreds tens ones)
+      (bcd (register r))
+    (setf (aref memory (+ index 0)) hundreds
+          (aref memory (+ index 1)) tens
+          (aref memory (+ index 2)) ones)))
+
+(define-opcode op-draw (_ rx ry size)                   ;; DRW Vx, Vy, size
+  (draw-sprite chip (register rx) (register ry) size))
 
 
 ;;;; Main ---------------------------------------------------------------------
@@ -253,75 +368,92 @@
 (defparameter *paused* nil)
 (defparameter *c* nil)
 
+
 (defun load-rom (chip filename)
   (replace (chip-memory chip) (read-file-into-byte-vector filename)
            :start1 #x200))
 
+(defun update-timers (chip)
+  (with-chip (chip)
+    (let* ((current-time (get-internal-real-time))
+           (elapsed (- current-time timer-previous)))
+      (decf timer-clock elapsed)
+      (when (minusp timer-clock)
+        (setf timer-clock +timer-tick+)
+        (when (plusp delay-timer) (decf delay-timer))
+        (when (plusp sound-timer) (decf sound-timer))))))
+
 (defun dispatch-instruction (chip instruction)
   (macrolet ((call (name) `(,name chip instruction)))
     (ecase (logand #xF000 instruction)
-      (#x0 (ecase instruction
-             (#x00E0 (call op-cls))
-             (#x00EE (call op-ret))))
-      (#x1 (call op-jp-imm))
-      (#x2 (call op-call))
-      (#x3 (call op-se-reg-imm))
-      (#x4 (call op-sne-reg-imm))
-      (#x5 (ecase (logand #x000F instruction)
-             (#x0 (call op-se-reg-reg))))
-      (#x6 (call op-ld-reg<imm))
-      (#x7 (call op-add-reg<imm))
-      (#x8 (ecase (logand #x000F instruction)
-             (#x0 (call op-ld-reg<reg))
-             (#x1 (call op-or))
-             (#x2 (call op-and))
-             (#x3 (call op-xor))
-             (#x4 (call op-add-reg<reg))
-             (#x5 (call op-sub-reg<reg))
-             (#x6)
-             (#x7 (call op-subn-reg<reg))
-             (#xE)))
-      (#x9 (ecase (logand #x000F instruction)
-             (#x0 (call op-sne-reg-reg))))
-      (#xA (call op-ld-i<imm))
-      (#xB (call op-jp-imm+reg))
-      (#xC (call op-rnd))
-      (#xD)
-      (#xE (ecase (logand #x00FF instruction)
-             (#x9E (call op-skp))
-             (#xA1 (call op-sknp))))
-      (#xF (ecase (logand #x00FF instruction)
-             (#x07 (call op-ld-reg<dt))
-             (#x0A (call op-ld-reg<key))
-             (#x15 (call op-ld-dt<reg))
-             (#x18 (call op-ld-st<reg))
-             (#x1E (call op-add-index<reg))
-             (#x29)
-             (#x33)
-             (#x55 (call op-ld-mem<regs))
-             (#x65 (call op-ld-regs<mem)))))))
+      (#x0000 (ecase instruction
+                (#x00E0 (call op-cls))
+                (#x00EE (call op-ret))))
+      (#x1000 (call op-jp-imm))
+      (#x2000 (call op-call))
+      (#x3000 (call op-se-reg-imm))
+      (#x4000 (call op-sne-reg-imm))
+      (#x5000 (ecase (logand #x000F instruction)
+                (#x0 (call op-se-reg-reg))))
+      (#x6000 (call op-ld-reg<imm))
+      (#x7000 (call op-add-reg<imm))
+      (#x8000 (ecase (logand #x000F instruction)
+                (#x0 (call op-ld-reg<reg))
+                (#x1 (call op-or))
+                (#x2 (call op-and))
+                (#x3 (call op-xor))
+                (#x4 (call op-add-reg<reg))
+                (#x5 (call op-sub-reg<reg))
+                (#x6 (call op-shr))
+                (#x7 (call op-subn-reg<reg))
+                (#xE (call op-shl))))
+      (#x9000 (ecase (logand #x000F instruction)
+                (#x0 (call op-sne-reg-reg))))
+      (#xA000 (call op-ld-i<imm))
+      (#xB000 (call op-jp-imm+reg))
+      (#xC000 (call op-rand))
+      (#xD000 (call op-draw))
+      (#xE000 (ecase (logand #x00FF instruction)
+                (#x9E (call op-skp))
+                (#xA1 (call op-sknp))))
+      (#xF000 (ecase (logand #x00FF instruction)
+                (#x07 (call op-ld-reg<dt))
+                (#x0A (call op-ld-reg<key))
+                (#x15 (call op-ld-dt<reg))
+                (#x18 (call op-ld-st<reg))
+                (#x1E (call op-add-index<reg))
+                (#x29 (call op-ld-font<vx))
+                (#x33 (call op-ld-bcd<vx))
+                (#x55 (call op-ld-mem<regs))
+                (#x65 (call op-ld-regs<mem)))))))
 
 (defun emulate-cycle (chip)
   (with-chip (chip)
-    (if awaiting-key
+    (if (or *paused* awaiting-key)
       (sleep 10/1000)
       (let ((instruction (cat-bytes (aref memory program-counter)
                                     (aref memory (1+ program-counter)))))
+        ; (format t "~4,'0X: ~4,'0X~%" program-counter instruction)
         (zapf program-counter (chop 12 (+ % 2)))
-        (dispatch-instruction chip instruction)))))
+        (dispatch-instruction chip instruction)
+        (sleep 0.001)
+        (update-timers chip)))
+    (setf timer-previous (get-internal-real-time))
+    nil))
 
 
-(defun run ()
+(defun run (rom-filename)
   (let ((chip (make-chip)))
     (setf *running* t
+          *paused* nil
           *c* chip)
-    (chip8.gui::run-gui chip)
-    ;; init
-    ;; load rom
-    #+no(iterate
-      (while *running*)
-      (emulate-cycle chip)
-      (handle-keys chip)
-      )
-    )
-  )
+    (load-rom chip rom-filename)
+    (bt:make-thread
+      (lambda ()
+        (iterate
+          (while *running*)
+          (emulate-cycle chip))))
+    (chip8.gui::run-gui chip)))
+
+
+;;;; Scratch ------------------------------------------------------------------
diff -r fd215349e7bb -r 8e58d7eb4d03 src/gui.lisp
--- a/src/gui.lisp	Wed Nov 16 20:54:13 2016 +0000
+++ b/src/gui.lisp	Thu Nov 17 15:50:38 2016 +0000
@@ -60,40 +60,43 @@
     (die screen)))
 
 
-(defun render-screen (screen)
-  (with-finalizing ((painter (q+:make-qpainter screen)))
-    (q+:begin-native-painting painter)
+(defun render-screen (screen painter)
+  (q+:begin-native-painting painter)
 
-    (gl:clear-color 0.0 0.0 0.0 1.0)
-    (gl:clear :color-buffer-bit)
+  (gl:clear-color 0.0 0.0 0.0 1.0)
+  (gl:clear :color-buffer-bit)
 
-    (gl:bind-texture :texture-2d (screen-texture screen))
-    (gl:tex-sub-image-2d :texture-2d 0 0 0 64 32 :luminance :unsigned-byte
-                         (chip8::chip-video-raw (screen-chip screen)))
+  (gl:bind-texture :texture-2d (screen-texture screen))
 
-    (let ((tw 1)
-          (th 0.5))
-      (gl:with-primitives :quads
-        (gl:tex-coord 0 0)
-        (gl:vertex 0 0)
+  (let ((chip (screen-chip screen)))
+    (when t ; (chip8::chip-video-dirty chip)
+      (setf (chip8::chip-video-dirty chip) nil)
+      (gl:tex-sub-image-2d :texture-2d 0 0 0 64 32 :luminance :unsigned-byte
+                           (chip8::chip-video chip))))
 
-        (gl:tex-coord tw 0)
-        (gl:vertex *width* 0)
+  (let ((tw 1)
+        (th 0.5))
+    (gl:with-primitives :quads
+      (gl:tex-coord 0 0)
+      (gl:vertex 0 0)
 
-        (gl:tex-coord tw th)
-        (gl:vertex *width* *height*)
+      (gl:tex-coord tw 0)
+      (gl:vertex *width* 0)
 
-        (gl:tex-coord 0 th)
-        (gl:vertex 0 *height*)))
+      (gl:tex-coord tw th)
+      (gl:vertex *width* *height*)
 
-    (gl:bind-texture :texture-2d 0)
+      (gl:tex-coord 0 th)
+      (gl:vertex 0 *height*)))
 
-    (q+:end-native-painting painter)))
+  (gl:bind-texture :texture-2d 0)
 
-(defun render-debug (screen)
+  (q+:end-native-painting painter))
+
+(defun render-debug (screen painter)
+  (declare (ignore screen))
   (when chip8::*paused*
-    (with-finalizing* ((painter (q+:make-qpainter screen))
-                       (font (q+:make-qfont "Menlo" 40))
+    (with-finalizing* ((font (q+:make-qfont "Menlo" 40))
                        (border-color (q+:make-qcolor 255 255 255))
                        (fill-color (q+:make-qcolor 0 0 0))
                        (path (q+:make-qpainterpath))
@@ -114,8 +117,9 @@
 
 (define-override (screen paint-event) (ev)
   (declare (ignore ev))
-  (render-screen screen)
-  (render-debug screen))
+  (with-finalizing ((painter (q+:make-qpainter screen)))
+    (render-screen screen painter)
+    (render-debug screen painter)))
 
 
 (defun pad-key-for (code)