# HG changeset patch # User Steve Losh # Date 1479850894 0 # Node ID 503bfe5cd173635960978e91c5d9e4fcd884d074 # Parent 16ee9cf6d7981588793cd9897c8b22da59ed00ee Clean up with some fancy `iterate` drivers diff -r 16ee9cf6d798 -r 503bfe5cd173 src/emulator.lisp --- a/src/emulator.lisp Tue Nov 22 11:55:23 2016 +0000 +++ b/src/emulator.lisp Tue Nov 22 21:41:34 2016 +0000 @@ -14,6 +14,7 @@ ;;;; Constants ---------------------------------------------------------------- (defconstant +cycles-per-second+ 500) +(defconstant +cycles-before-sleep+ 10) (defconstant +screen-width+ 64) (defconstant +screen-height+ 32) (defconstant +memory-size+ (* 1024 4)) @@ -35,7 +36,8 @@ ;;;; Utils -------------------------------------------------------------------- -(declaim (inline not= +_8 -_8 chop cat-bytes get-bit bcd)) +(declaim + (inline not= +_8 -_8 chop cat-bytes get-bit bcd)) (defun make-simple-array (element-type size &rest args) (apply #'make-array size @@ -79,13 +81,15 @@ ;;;; Data --------------------------------------------------------------------- +(declaim + (inline chip-flag (setf chip-flag))) + (defstruct debugger (paused nil :type boolean) (take-step nil :type boolean) (print-needed nil :type boolean) (callbacks-arrived nil :type list)) - (defstruct chip (running t :type boolean) (memory (make-simple-array 'int8 4096) @@ -97,8 +101,8 @@ (keys (make-simple-array 'boolean 16) :type (basic-array boolean 16) :read-only t) - (video (make-simple-array 'fixnum (* 32 64)) - :type (basic-array fixnum #.(* 32 64)) + (video (make-simple-array 'fixnum (* +screen-height+ +screen-width+)) + :type (basic-array fixnum #.(* +screen-height+ +screen-width+)) :read-only t) (video-dirty t :type boolean) (index 0 :type int16) @@ -117,6 +121,7 @@ (loaded-rom nil :type (or null string)) (debugger (make-debugger) :type debugger :read-only t)) + (define-with-macro chip running memory registers @@ -134,7 +139,6 @@ paused take-step print-needed callbacks-arrived) -(declaim (inline chip-flag (setf chip-flag))) (defun chip-flag (chip) (aref (chip-registers chip) #xF)) @@ -241,9 +245,8 @@ ;;;; Debugger ----------------------------------------------------------------- -(declaim (ftype (function (debugger) boolean) - debugger-should-wait-p)) - +(declaim + (ftype (function (debugger) boolean) debugger-should-wait-p)) (defun debugger-pause (debugger) (with-debugger (debugger) @@ -296,36 +299,37 @@ ;;;; Graphics ----------------------------------------------------------------- -(declaim (inline font-location vref (setf vref)) - (ftype (function (chip int8 int8 int4) null) draw-sprite)) +(declaim + (inline font-location vref (setf vref)) + (ftype (function (chip int8 int8 int4) null) draw-sprite)) (defun vref (chip x y) - (aref (chip-video chip) (+ (* 64 y) x))) + (aref (chip-video chip) (+ (* +screen-width+ y) x))) (defun (setf vref) (new-value chip x y) - (setf (aref (chip-video chip) (+ (* 64 y) x)) + (setf (aref (chip-video chip) (+ (* +screen-width+ 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 + (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)) @@ -340,21 +344,18 @@ size index) (setf flag 0) (iterate - (for y :from start-y :below (+ start-y size)) - (for screen-y = (mod y +screen-height+)) + (repeat size) (for i :from index) (for sprite = (aref memory i)) - (iterate (for x :from start-x) - (for screen-x = (mod x +screen-width+)) + (for y :modulo +screen-height+ :from start-y) + (iterate (for x :modulo +screen-width+ :from start-x) (for col :from 7 :downto 0) - (for old-pixel = (plusp (vref chip screen-x screen-y))) + (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 screen-x screen-y) - (if (eql old-pixel new-pixel) - 0 - 255)))) + (setf (vref chip x y) + (if (xor old-pixel new-pixel) 255 0)))) (setf video-dirty t)) nil) @@ -695,14 +696,15 @@ (let ((instruction (cat-bytes (aref memory program-counter) (aref memory (1+ program-counter))))) (zapf program-counter (chop 12 (+ % 2))) - (dispatch-instruction chip instruction) - (sleep (/ 1 +cycles-per-second+)))) + (dispatch-instruction chip instruction))) nil)) (defun run-cpu (chip) (iterate (while (chip-running chip)) - (emulate-cycle chip))) + (emulate-cycle chip) + (for tick :every-nth +cycles-before-sleep+ :do + (sleep (/ +cycles-before-sleep+ +cycles-per-second+))))) ;;;; Main --------------------------------------------------------------------- diff -r 16ee9cf6d798 -r 503bfe5cd173 src/gui.lisp --- a/src/gui.lisp Tue Nov 22 11:55:23 2016 +0000 +++ b/src/gui.lisp Tue Nov 22 21:41:34 2016 +0000 @@ -10,7 +10,6 @@ (defparameter *fps* 60) - ;;;; Data --------------------------------------------------------------------- (defstruct gui chip screen) @@ -22,7 +21,7 @@ (gl:tex-image-2d :texture-2d 0 :luminance size size 0 :luminance :unsigned-byte (cffi:null-pointer)) - (gl:tex-parameter :texture-2d :texture-min-filter :nearest) ; sharp pixels or gtfo + (gl:tex-parameter :texture-2d :texture-min-filter :nearest) (gl:tex-parameter :texture-2d :texture-mag-filter :nearest) (gl:enable :texture-2d) @@ -79,7 +78,7 @@ (gl:bind-texture :texture-2d (screen-texture screen)) (let ((chip (screen-chip screen))) - (when t ; (chip8::chip-video-dirty chip) + (when (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)))) @@ -177,8 +176,7 @@ (let* ((key (q+:key ev)) (pad-key (pad-key-for key))) (if pad-key - (when pad-key - (chip8::keyup chip pad-key)) + (chip8::keyup chip pad-key) (qtenumcase key ((q+:qt.key_escape) (die screen)) @@ -192,7 +190,7 @@ ((q+:qt.key_f7) (-> chip chip8::chip-debugger chip8::debugger-step)) - (t (pr "Unknown key pressed" (format nil "~X" key)))))) + (t (pr :unknown-key (format nil "~X" key)))))) (stop-overriding)) diff -r 16ee9cf6d798 -r 503bfe5cd173 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Tue Nov 22 11:55:23 2016 +0000 +++ b/vendor/make-quickutils.lisp Tue Nov 22 21:41:34 2016 +0000 @@ -14,6 +14,7 @@ :read-file-into-byte-vector :symb :with-gensyms + :xor ) :package "CHIP8.QUICKUTILS") diff -r 16ee9cf6d798 -r 503bfe5cd173 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Tue Nov 22 11:55:23 2016 +0000 +++ b/vendor/quickutils.lisp Tue Nov 22 21:41:34 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :ONCE-ONLY :RCURRY :READ-FILE-INTO-BYTE-VECTOR :SYMB :WITH-GENSYMS) :ensure-package T :package "CHIP8.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :ONCE-ONLY :RCURRY :READ-FILE-INTO-BYTE-VECTOR :SYMB :WITH-GENSYMS :XOR) :ensure-package T :package "CHIP8.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "CHIP8.QUICKUTILS") @@ -19,7 +19,8 @@ :ONCE-ONLY :RCURRY :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE :READ-FILE-INTO-BYTE-VECTOR :MKSTR - :SYMB :STRING-DESIGNATOR :WITH-GENSYMS)))) + :SYMB :STRING-DESIGNATOR :WITH-GENSYMS + :XOR)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-gensym-list (length &optional (x "G")) "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`, @@ -270,9 +271,29 @@ unique symbol the named variable will be bound to." `(with-gensyms ,names ,@forms)) + + (defmacro xor (&rest datums) + "Evaluates its arguments one at a time, from left to right. If more then one +argument evaluates to a true value no further `datums` are evaluated, and `nil` is +returned as both primary and secondary value. If exactly one argument +evaluates to true, its value is returned as the primary value after all the +arguments have been evaluated, and `t` is returned as the secondary value. If no +arguments evaluate to true `nil` is retuned as primary, and `t` as secondary +value." + (with-gensyms (xor tmp true) + `(let (,tmp ,true) + (block ,xor + ,@(mapcar (lambda (datum) + `(if (setf ,tmp ,datum) + (if ,true + (return-from ,xor (values nil nil)) + (setf ,true ,tmp)))) + datums) + (return-from ,xor (values ,true t)))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(compose curry ensure-boolean ensure-gethash ensure-list once-only rcurry read-file-into-byte-vector symb with-gensyms - with-unique-names))) + with-unique-names xor))) ;;;; END OF quickutils.lisp ;;;;