faea86bc8c
Status of the project as it was on 2025-03-07. The commit date is based on the modification time of the files.
209 lines
6.5 KiB
Common Lisp
209 lines
6.5 KiB
Common Lisp
(in-package :chipgr8)
|
|
|
|
(defmacro match-opcode (word &body body)
|
|
(let ((n1-name (gensym)) (n2-name (gensym)) (n3-name (gensym)) (n4-name (gensym)))
|
|
`(destructuring-bind (,n1-name ,n2-name ,n3-name ,n4-name) (num->digits ,word 16 :min-length 4)
|
|
(cond
|
|
,@(mapcar
|
|
(lambda (case)
|
|
(let ((condition (car case)) (statements (cdr case)) (matches ()) (binds ()))
|
|
(destructuring-bind (c1 c2 c3 c4) condition
|
|
(if (symbolp c1)
|
|
(push (list c1 n1-name) binds)
|
|
(push `(equal ,n1-name ,c1) matches))
|
|
(if (symbolp c2)
|
|
(push (list c2 n2-name) binds)
|
|
(push `(equal ,n2-name ,c2) matches))
|
|
(if (symbolp c3)
|
|
(push (list c3 n3-name) binds)
|
|
(push `(equal ,n3-name ,c3) matches))
|
|
(if (symbolp c4)
|
|
(push (list c4 n4-name) binds)
|
|
(push `(equal ,n4-name ,c4) matches))
|
|
|
|
`((and ,@matches) (let ,binds ,@statements)))))
|
|
body)))))
|
|
|
|
(defvar *memory* (make-array (* 4 1024) :initial-element 0)) ; 4kB of memory
|
|
(defvar *register* (make-array 16 :initial-element 0)) ; V0 - VF
|
|
(defvar *pc* 512) ; First 512 bytes are reserved for internal use
|
|
(defvar *i* 0) ; I
|
|
(defvar *stack* ())
|
|
|
|
(defvar *delay-timer* 0)
|
|
(defvar *sound-timer* 0)
|
|
(defvar *last-timer-update* 0)
|
|
|
|
(defun initialize-emulator ()
|
|
; TODO: (load-font)
|
|
)
|
|
|
|
(defun set-delay-timer (duration)
|
|
(setf *delay-timer* duration))
|
|
|
|
(defun get-delay-timer ()
|
|
*delay-timer*)
|
|
|
|
(defun set-sound-timer (duration)
|
|
(setf *sound-timer* duration))
|
|
|
|
;;; Most significant nybble first
|
|
(defun num->digits (num base &key (min-length 0))
|
|
(let ((list ()))
|
|
(do () ((= num 0) list)
|
|
(push (mod num base) list)
|
|
(setf num (floor (/ num base))))
|
|
(do () ((>= (length list) min-length))
|
|
(push 0 list))
|
|
list))
|
|
|
|
(defun digits->num (digits base)
|
|
(let ((num 0))
|
|
(do () ((null digits) num)
|
|
(setf num (+ (* num base) (car digits)))
|
|
(setf digits (cdr digits)))))
|
|
|
|
(defun fetch-word (addr)
|
|
(let (
|
|
(high (aref *memory* addr))
|
|
(low (aref *memory* (1+ addr))))
|
|
(digits->num (list high low) 256)))
|
|
|
|
(defun store-word (addr word)
|
|
(destructuring-bind (high low) (num->digits word 256)
|
|
(setf (aref *memory* addr) high)
|
|
(setf (aref *memory* (1+ addr)) low)))
|
|
|
|
(defun overflowp (num)
|
|
(or (< num 0) (>= num (* 256 256))))
|
|
|
|
(defun word-coerce (num)
|
|
(mod num (* 256 256)))
|
|
|
|
(defun run-opcode ()
|
|
(match-opcode (fetch-word *pc*)
|
|
((0 0 #xE 0)
|
|
(clear-screen)
|
|
(inc *pc* 2))
|
|
((0 0 #xE #xE)
|
|
(setf *pc* (pop *stack*)))
|
|
((1 n1 n2 n3)
|
|
(setf *pc* (digits->num (list n1 n2 n3) 16)))
|
|
((2 n1 n2 n3)
|
|
(push (+ *pc* 2) *stack*)
|
|
(setf *pc* (digits->num (list n1 n2 n3) 16)))
|
|
((3 x n1 n2)
|
|
(when (= (aref *register* x) (digits->num (list n1 n2) 16))
|
|
(inc *pc* 2))
|
|
(inc *pc* 2))
|
|
((4 x n1 n2)
|
|
(when (/= (aref *register* x) (digits->num (list n1 n2) 16))
|
|
(inc *pc* 2))
|
|
(inc *pc* 2))
|
|
((5 x y 0)
|
|
(when (= (aref *register* x) (aref *register* y))
|
|
(inc *pc* 2))
|
|
(inc *pc* 2))
|
|
((6 x n1 n2)
|
|
(setf (aref *register* x) (digits->num (list n1 n2) 16))
|
|
(inc *pc* 2))
|
|
((7 x n1 n2)
|
|
(setf (aref *register* x) (word-coerce (+ (aref *register* x) (digits->num (list n1 n2) 16))))
|
|
(inc *pc* 2))
|
|
((8 x y 0)
|
|
(setf (aref *register* x) (aref *register* y))
|
|
(inc *pc* 2))
|
|
((8 x y 1)
|
|
(setf (aref *register* x) (boole boole-ior (aref *register* x) (aref *register* y)))
|
|
(inc *pc* 2))
|
|
((8 x y 2)
|
|
(setf (aref *register* x) (boole boole-and (aref *register* x) (aref *register* y)))
|
|
(inc *pc* 2))
|
|
((8 x y 3)
|
|
(setf (aref *register* x) (boole boole-xor (aref *register* x) (aref *register* y)))
|
|
(inc *pc* 2))
|
|
((8 x y 4)
|
|
(let ((result (+ (aref *register* x) (aref *register* y))))
|
|
(setf (aref *register* x) (word-coerce result))
|
|
(setf (aref *register* #xF) (if (overflowp result) 1 0)))
|
|
(inc *pc* 2))
|
|
((8 x y 5)
|
|
(let ((result (- (aref *register* x) (aref *register* y))))
|
|
(setf (aref *register* x) (word-coerce result))
|
|
(setf (aref *register* #xF) (if (overflowp result) 0 1)))
|
|
(inc *pc* 2))
|
|
((8 x y 6) ; y is not used for anyhing, but lets include it just in case
|
|
(setf (aref *register* x) (floor (/ (aref *register* x) 2)))
|
|
(setf (aref *register* #xF) (mod (aref *register* x) 2))
|
|
(incp *pc* 2))
|
|
((8 x y 5)
|
|
(let ((result (- (aref *register* y) (aref *register* y))))
|
|
(setf (aref *register* x) (word-coerce result))
|
|
(setf (aref *register* #xF) (if (overflowp result) 0 1)))
|
|
(inc *pc* 2))
|
|
((8 x y #xE) ; y is not used for anyhing, but lets include it just in case
|
|
(setf (aref *register* x) (word-coerce (* (aref *register* x) 2)))
|
|
(setf (aref *register* #xF) (floor (/ (aref *register* x) (* 256 256))))
|
|
(incp *pc* 2))
|
|
((9 x y 0)
|
|
(when (/= (aref *register* x) (aref *register* y))
|
|
(inc *pc* 2))
|
|
(inc *pc* 2))
|
|
((#xA n1 n2 n3)
|
|
(setf *i* (digits->num (list n1 n2 n3) 16))
|
|
(inc *pc* 2))
|
|
((#xB n1 n2 n3)
|
|
(setf *pc* (word-coerce (+ (digits->num (list n1 n2 n3) 16) (aref *register* 0))))
|
|
(inc *pc* 2))
|
|
((#xC x n1 n2)
|
|
(setf (aref *register* x) (random (digits->num (list n1 n2) 16)))
|
|
(inc *pc* 2))
|
|
((#xD x y n)
|
|
(draw-sprite (aref *register* x) (aref *register* y) (subseq *i* (+ *i* (* 8 n)) 2))
|
|
(inc *pc* 2))
|
|
((#xE x 9 #xE)
|
|
(when (key-pressedp (aref *register* x)))
|
|
(inc *pc* 2))
|
|
((#xE x A 1)
|
|
(when (key-pressedp (aref *register* x)))
|
|
(inc *pc* 2))
|
|
((#xF x 0 7)
|
|
(setf (aref *register* x) (get-delay-timer))
|
|
(inc *pc* 2))
|
|
((#xF x 0 #xA)
|
|
(wait-keypress (lambda (key) (setf (aref *register* x) key)))
|
|
(inc *pc* 2))
|
|
((#xF x 1 5)
|
|
(set-sound-timer (aref *register* x))
|
|
(int *pc* 2))
|
|
((#xF x 1 #xE)
|
|
(setf *i* (mod (+ *i* (aref *register* x)) (* 256 256 16)))
|
|
(inc *pc* 2))
|
|
((#xF x 2 9)
|
|
(setf *i* (get-char-sprite (aref *register* x)))
|
|
(inc *pc* 2))
|
|
((#xF x 3 3)
|
|
(destructuring-bind (high middle low) (num->digits (aref *register* x) 10)
|
|
(setf (aref *memory* *i*) high)
|
|
(setf (aref *memory* (1+ *i*)) middle)
|
|
(setf (aref *memory* (+ *i* 2)) low))
|
|
(inc *pc* 2))
|
|
((#xF x 5 5)
|
|
(dotimes (index (+ x 1))
|
|
(setf (aref *memory* (+ *i* index)) (aref *register* index)))
|
|
(inc *pc* 2))
|
|
((#xF x 6 5)
|
|
(dotimes (index (+ x 1))
|
|
(setf (aref *register* index) (aref *memory* (+ *i* index))))
|
|
(inc *pc* 2))))
|
|
|
|
(defun update-timers ()
|
|
(let ((time (sdl:system-ticks)))
|
|
(when (>= time (+ *last-timer-update* 1000/60)) ; 60MHz
|
|
(when (> *delay-timer* 0) (decf *delay-timer*))
|
|
(when (> *sound-timer* 0) (decf *sound-timer*))
|
|
(setf *last-timer-update* time))))
|
|
|
|
(defun emulator-step ()
|
|
(run-opcode)
|
|
(update-timers))
|