# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1481948853 18000
# Node ID 8155568555ec110cac2be902ba7860682fc6c4ad
# Parent  9671aac2bbb59b702b07b95e163db815c3629119
Fix screen-wrapping bullshit, move declarations, opcode->instruction

diff -r 9671aac2bbb5 -r 8155568555ec src/emulator.lisp
--- a/src/emulator.lisp	Fri Dec 16 23:27:18 2016 -0500
+++ b/src/emulator.lisp	Fri Dec 16 23:27:33 2016 -0500
@@ -1,5 +1,5 @@
 (in-package :chip8)
-(declaim (optimize (speed 1) (safety 3) (debug 3)))
+(declaim (optimize (speed 3) (safety 1) (debug 2)))
 
 
 ;;;; Constants ----------------------------------------------------------------
@@ -78,6 +78,7 @@
          :type (simple-array fixnum (#.(* +screen-height+ +screen-width+)))
          :read-only t)
   (video-dirty t :type boolean)
+  (screen-wrapping-enabled t :type boolean)
   (delay-timer 0 :type fixnum)
   (sound-timer 0 :type fixnum)
   (stack (make-array 16 :element-type 'int12 :fill-pointer 0)
@@ -91,7 +92,7 @@
   memory
   registers flag index program-counter
   delay-timer sound-timer
-  video video-dirty
+  video video-dirty screen-wrapping-enabled
   keys
   stack
   loaded-rom
@@ -106,10 +107,6 @@
 
 
 ;;;; Graphics -----------------------------------------------------------------
-(declaim
-  (ftype (function (chip int8 int8 int4) null) draw-sprite))
-
-
 (defun-inline vref (chip x y)
   (aref (chip-video chip) (+ (* +screen-width+ y) x)))
 
@@ -143,33 +140,40 @@
   (+ #x50 (* character 5)))
 
 
+(defun-inline wrap (chip x y)
+  (cond
+    ((chip-screen-wrapping-enabled chip)
+     (values (mod x +screen-width+)
+             (mod y +screen-height+)
+             t))
+    ((and (in-range-p 0 x +screen-width+)
+          (in-range-p 0 y +screen-height+))
+     (values x y t))
+    (t (values nil nil nil))))
+
 (defun draw-sprite (chip start-x start-y size)
   (with-chip (chip)
     (setf flag 0)
-    (iterate
-      (repeat size)
-      (for i :from index)
-      (for y :from start-y)
-      (for sprite = (aref memory i))
-      (iterate
-        (for x :from start-x)
-        (for col :from 7 :downto 0)
-        (when (and (in-range-p 0 x +screen-width+)
-                   (in-range-p 0 y +screen-height+))
-          (for old-pixel = (plusp (vref chip x y)))
-          (for new-pixel = (plusp (get-bit col sprite)))
-          (when (and old-pixel new-pixel)
-            (setf flag 1))
-          (setf (vref chip x y)
-                (if (xor old-pixel new-pixel) 255 0)))))
+    (iterate (repeat size)
+             (for i :from index)
+             (for y :from start-y)
+             (for sprite = (aref memory i))
+             (iterate
+               (for x :from start-x)
+               (for col :from 7 :downto 0)
+               (multiple-value-bind (x y draw) (wrap chip x y)
+                 (when draw
+                   (for old-pixel = (plusp (vref chip x y)))
+                   (for new-pixel = (plusp (get-bit col sprite)))
+                   (when (and old-pixel new-pixel)
+                     (setf flag 1))
+                   (setf (vref chip x y)
+                         (if (xor old-pixel new-pixel) 255 0))))))
     (setf video-dirty t))
   nil)
 
 
 ;;;; Keyboard -----------------------------------------------------------------
-(declaim
-  (ftype (function (chip (integer 0 (16)))) keydown keyup))
-
 (defun keydown (chip key)
   (setf (aref (chip-keys chip) key) t))
 
@@ -177,9 +181,9 @@
   (setf (aref (chip-keys chip) key) nil))
 
 
-;;;; Opcodes ------------------------------------------------------------------
+;;;; Instructions -------------------------------------------------------------
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun parse-opcode-argument-bindings (argument-list)
+  (defun parse-instruction-argument-bindings (argument-list)
     (flet ((normalize-arg (arg)
              (destructuring-bind (symbol &optional (nibbles 1))
                  (ensure-list arg)
@@ -190,19 +194,19 @@
         (when (not (eql symbol '_))
           (collect `(,symbol (ldb (byte ,(* nibbles 4)
                                         ,(* position 4))
-                                  opcode))))))))
+                                  instruction))))))))
 
-(defmacro define-opcode (name argument-list &body body)
+(defmacro define-instruction (name argument-list &body body)
   `(progn
     (declaim (ftype (function (chip int16)
                               (values null &optional))
                     ,name))
-    (defun ,name (chip opcode)
-      (declare (ignorable opcode))
+    (defun ,name (chip instruction)
+      (declare (ignorable instruction))
       (with-chip (chip)
         (macrolet ((register (index)
                      `(aref registers ,index)))
-          (let ,(parse-opcode-argument-bindings argument-list)
+          (let ,(parse-instruction-argument-bindings argument-list)
             ,@body))
         nil))))
 
@@ -215,42 +219,42 @@
       (op-ld-reg<dt  (_ r _ _)       (register r)  delay-timer)
       (op-ld-dt<reg  (_ r _ _)       delay-timer   (register r))
       (op-ld-st<reg  (_ r _ _)       sound-timer   (register r))))
-  `(define-opcode ,name ,arglist
+  `(define-instruction ,name ,arglist
     (setf ,destination ,source)))
 
-(define-opcode op-cls ()                                ;; CLS
+(define-instruction op-cls ()                           ;; CLS
   (fill video 0)
   (setf video-dirty t))
 
-(define-opcode op-jp-imm (_ (target 3))                 ;; JP addr
+(define-instruction op-jp-imm (_ (target 3))            ;; JP addr
   (setf program-counter target))
 
-(define-opcode op-jp-imm+reg (_ (target 3))             ;; JP V0 + addr
+(define-instruction op-jp-imm+reg (_ (target 3))        ;; JP V0 + addr
   (setf program-counter (+ target (register 0))))
 
-(define-opcode op-call (_ (target 3))                   ;; CALL addr
+(define-instruction op-call (_ (target 3))              ;; CALL addr
   (vector-push program-counter stack)
   (setf program-counter target))
 
-(define-opcode op-ret ()                                ;; RET
+(define-instruction op-ret ()                           ;; RET
   (setf program-counter (vector-pop stack)))
 
-(define-opcode op-add-reg<imm (_ r (immediate 2))       ;; ADD Vx, Imm
+(define-instruction op-add-reg<imm (_ r (immediate 2))  ;; ADD Vx, Imm
   ;; For some weird reason the ADD immediate op doesn't set the flag
   (zapf (register r) (+_8 % immediate)))
 
-(define-opcode op-add-reg<reg (_ rx ry)                 ;; ADD Vx, Vy (8-bit)
+(define-instruction op-add-reg<reg (_ rx ry)            ;; ADD Vx, Vy (8-bit)
     (setf (values (register rx) flag)
           (+_8 (register rx) (register ry))))
 
-(define-opcode op-sub-reg<reg (_ rx ry)                 ;; SUB Vx, Vy (8-bit)
+(define-instruction op-sub-reg<reg (_ rx ry)            ;; SUB Vx, Vy (8-bit)
   (setf (values (register rx) flag)
         (-_8 (register rx) (register ry))))
 
-(define-opcode op-add-index<reg (_ r)                   ;; ADD I, Vx (16-bit)
+(define-instruction op-add-index<reg (_ r)              ;; ADD I, Vx (16-bit)
   (zapf index (chop 16 (+ % (register r)))))
 
-(define-opcode op-subn-reg<reg (_ rx ry)                ;; SUBN Vx, Vy (8-bit)
+(define-instruction op-subn-reg<reg (_ rx ry)           ;; SUBN Vx, Vy (8-bit)
   (setf (values (register rx) flag)
         ;; subtraction order is swapped for SUBN
         (-_8 (register ry) (register rx))))
@@ -261,7 +265,7 @@
     (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)
+  `(define-instruction ,name (_ ,x-arg ,y-arg)
     (when (,test ,x-form ,y-form)
       (incf program-counter 2))))
 
@@ -270,28 +274,28 @@
    ((op-and logand)
     (op-or  logior)
     (op-xor logxor)))
-  `(define-opcode ,name (_ destination source _)
+  `(define-instruction ,name (_ destination source _)
     (zapf (register destination) (,op % (register source)))))
 
-(define-opcode op-rand (_ r (mask 2))                   ;; RND
+(define-instruction op-rand (_ r (mask 2))              ;; RND
   (setf (register r)
         (logand (random 256) mask)))
 
-(define-opcode op-skp (_ r _ _)                         ;; SKP
+(define-instruction op-skp (_ r _ _)                    ;; SKP
   (when (aref keys (register r))
     (incf program-counter 2)))
 
-(define-opcode op-sknp (_ r _ _)                        ;; SKNP
+(define-instruction op-sknp (_ r _ _)                   ;; SKNP
   (when (not (aref keys (register r)))
     (incf program-counter 2)))
 
-(define-opcode op-ld-mem<regs (_ n _ _)                 ;; LD [I] < Vn
+(define-instruction op-ld-mem<regs (_ n _ _)            ;; LD [I] < Vn
   (replace memory registers :start1 index :end2 (1+ n)))
 
-(define-opcode op-ld-regs<mem (_ n _ _)                 ;; LD Vn < [I]
+(define-instruction op-ld-regs<mem (_ n _ _)            ;; LD Vn < [I]
   (replace registers memory :end1 (1+ n) :start2 index))
 
-(define-opcode op-ld-reg<key (_ r _ _)                  ;; LD Vx, Key (await)
+(define-instruction op-ld-reg<key (_ r _ _)             ;; LD Vx, Key (await)
   ;; I'm unsure how this instruction is supposed to interact with the timers.
   ;;
   ;; Either the timers should continue to count down while we wait for a key, or
@@ -305,24 +309,24 @@
       ;; If we don't have a key, just execute this instruction again next time.
       (decf program-counter 2))))
 
-(define-opcode op-shr (_ r _ _)                         ;; SHR
+(define-instruction op-shr (_ r _ _)                    ;; SHR
   (setf (values (register r) flag)
         (>>_8 (register r))))
 
-(define-opcode op-shl (_ r _ _)                         ;; SHL
+(define-instruction op-shl (_ r _ _)                    ;; SHL
   (setf (values (register r) flag)
         (<<_8 (register r))))
 
-(define-opcode op-ld-font<vx (_ r _ _)                  ;; LD F, Vx
+(define-instruction op-ld-font<vx (_ r _ _)             ;; LD F, Vx
   (setf index (font-location (register r))))
 
-(define-opcode op-ld-bcd<vx (_ r _ _)                   ;; LD B, Vx
+(define-instruction op-ld-bcd<vx (_ r _ _)              ;; LD B, Vx
   (setf (values (aref memory (+ index 0)) ; hundreds
                 (aref memory (+ index 1)) ; tens
                 (aref memory (+ index 2))) ; ones
         (bcd (register r))))
 
-(define-opcode op-draw (_ rx ry size)                   ;; DRW Vx, Vy, size
+(define-instruction op-draw (_ rx ry size)              ;; DRW Vx, Vy, size
   (draw-sprite chip (register rx) (register ry) size))
 
 
@@ -393,13 +397,11 @@
                    (progn
                      (setf angle (fill-sawtooth buffer rate angle))
                      (portaudio:write-stream audio-stream buffer))
-                   (sleep +audio-buffer-time+)))))))
+                   (sleep +audio-buffer-time+))))))
+  nil)
 
 
 ;;;; Timers -------------------------------------------------------------------
-(declaim
-  (ftype (function (chip) null) decrement-timers run-timers))
-
 (defun decrement-timers (chip)
   (flet ((decrement (i)
            (if (plusp i)
@@ -420,11 +422,6 @@
 
 
 ;;;; CPU ----------------------------------------------------------------------
-(declaim
-  (ftype (function (chip) null) run-cpu emulate-cycle)
-  (ftype (function (chip int16) null) dispatch-instruction))
-
-
 (defun reset (chip)
   (with-chip (chip)
     (fill memory 0)