# HG changeset patch # User Steve Losh # Date 1481917378 18000 # Node ID ee000116796f8842eaf966880d351ed938c0676f # Parent 2dd99e07f36841b65c956cf42bfa8ace02befa26 Move GUI stuff into its own file diff -r 2dd99e07f368 -r ee000116796f cl-chip8.asd --- a/cl-chip8.asd Fri Dec 16 14:36:52 2016 -0500 +++ b/cl-chip8.asd Fri Dec 16 14:42:58 2016 -0500 @@ -27,5 +27,6 @@ (:file "package") (:module "src" :serial t :components ((:file "emulator") - (:file "debugger") - (:file "gui"))))) + (:module "gui" :serial t + :components ((:file "debugger") + (:file "screen"))))))) diff -r 2dd99e07f368 -r ee000116796f package.lisp --- a/package.lisp Fri Dec 16 14:36:52 2016 -0500 +++ b/package.lisp Fri Dec 16 14:42:58 2016 -0500 @@ -8,10 +8,10 @@ (:export)) -(defpackage :chip8.gui +(defpackage :chip8.gui.screen (:use :cl+qt :iterate :losh :cl-arrows :chip8.quickutils)) -(defpackage :chip8.debugger +(defpackage :chip8.gui.debugger (:use :cl+qt :iterate :losh :cl-arrows :chip8.quickutils)) diff -r 2dd99e07f368 -r ee000116796f src/debugger.lisp --- a/src/debugger.lisp Fri Dec 16 14:36:52 2016 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,401 +0,0 @@ -(in-package :chip8.debugger) -(named-readtables:in-readtable :qtools) -(declaim (optimize (debug 3))) - - -(defparameter *font* (q+:make-qfont "Menlo" 12)) -(defparameter *current-instruction-brush* - (q+:make-qbrush (q+:make-qcolor 216 162 223))) - - -;;;; Main GUI ----------------------------------------------------------------- -(define-widget debugger (QWidget) - ((model-disassembly :initarg :model-disassembly) - (model-registers :initarg :model-registers) - (model-stack :initarg :model-stack) - (chip-debugger :initarg :chip-debugger))) - -(define-initializer (debugger setup) - (setf (q+:window-title debugger) "Debugger") - (q+:resize debugger 580 800)) - - -;;;; Utils -------------------------------------------------------------------- -(defun model-index (model row col) - (q+:index model row col (q+:make-qmodelindex))) - -(defun data-changed! (model index-from &optional (index-to index-from)) - (signal! model (data-changed "QModelIndex" "QModelIndex") - index-from - index-to)) - - -;;;; Disassembler ------------------------------------------------------------- -;;;; Code -(defun disassemble-address (chip address) - (-<> chip - chip8::chip-memory - (chip8::instruction-information <> address))) - - -;;;; Model -(define-widget disassembly-model (QAbstractTableModel) - ((chip :initarg :chip) - (parity :initform 0) - (current-address :initform 0))) - - -(defun disassembly-model-address-to-row (model address) - (-<> address - (+ <> (slot-value model 'parity)) - (truncate <> 2) - (values <>))) - - -(defun disassembly-model-update-current-address (model new-address) - (let* ((old-address (slot-value model 'current-address)) - (old-row (disassembly-model-address-to-row model old-address)) - (new-row (disassembly-model-address-to-row model new-address))) - (setf (slot-value model 'current-address) new-address) - (data-changed! model - (model-index model old-row 0) - (model-index model old-row 3)) - (data-changed! model - (model-index model new-row 0) - (model-index model new-row 3)))) - -(defun disassembly-model-toggle-parity (model) - (zapf (slot-value model 'parity) (if (zerop %) 1 0)) - (signal! model (layout-changed))) - - -(define-override (disassembly-model column-count) (index) - (declare (ignore index)) - 4) - -(define-override (disassembly-model row-count) (index) - (declare (ignore index)) - (+ parity (ceiling 4096 2))) - - -(defun disassembly-index-valid-p (index) - (and (q+:is-valid index) - (< (q+:row index) (ceiling 4096 2)))) - -(defun get-disassembly-contents (model row col) - (let ((data (-<> model - (slot-value <> 'chip) - (disassemble-address <> (- (* 2 row) - (slot-value model 'parity))) - (nth col <>)))) - (ecase col - (0 (format nil "~3,'0X" data)) - (1 (format nil "~4,'0X" data)) - (2 (if data - (let ((*print-base* 16)) - (format nil "~A ~{~A~^, ~}" (first data) (rest data))) - "")) - (3 data)))) - -(define-override (disassembly-model data) (index role) - (let ((row (q+:row index)) - (col (q+:column index))) - (if (not (disassembly-index-valid-p index)) - (q+:make-qvariant) - (qtenumcase role - ((q+:qt.display-role) - (get-disassembly-contents disassembly-model row col)) - - ((q+:qt.font-role) *font*) - - ((q+:qt.background-role) - (if (= row (disassembly-model-address-to-row disassembly-model - current-address)) - *current-instruction-brush* - (q+:make-qvariant))) - - ((q+:qt.text-alignment-role) (case col - (0 #x0082) - (1 #x0084) - (2 #x0080) - (3 #x0080))) - - (t (q+:make-qvariant)))))) - -(define-override (disassembly-model header-data) (section orientation role) - (case role - (0 (qtenumcase orientation - ((q+:qt.vertical) (q+:make-qvariant)) - ((q+:qt.horizontal) (case section - (0 "Addr") - (1 "Inst") - (2 "Disassembly") - (3 "Bits"))))) - (t (q+:make-qvariant)))) - - -;;;; Layout -(defun disassembly-update-address (model view address) - (disassembly-model-update-current-address model address) - (-<> address - ;; raw address -> row number - (disassembly-model-address-to-row model <>) - ;; Give ourselves a bit of breathing room at the top of the table - (- <> 4) - (max <> 0) - ;; get a QModelIndex, because passing a pair of ints would be too easy - (model-index model <> 0) - ;; make the debugger show the current line - (q+:scroll-to view <> (q+:qabstractitemview.position-at-top)))) - -(define-subwidget (debugger disassembly-table) - (q+:make-qtableview debugger) - (chip8::debugger-add-callback-arrived - chip-debugger ; bit of a fustercluck here... - (curry #'disassembly-update-address model-disassembly disassembly-table)) - (q+:set-model disassembly-table model-disassembly) - (q+:set-show-grid disassembly-table nil) - (q+:set-column-width disassembly-table 0 40) - (q+:set-column-width disassembly-table 1 60) - (q+:set-column-width disassembly-table 2 200) - (q+:set-column-width disassembly-table 3 90) - (let ((vheader (q+:vertical-header disassembly-table))) - (q+:hide vheader) - (q+:set-resize-mode vheader (q+:qheaderview.fixed)) - (q+:set-default-section-size vheader 14))) - -(define-subwidget (debugger disassembly-parity-button) - (q+:make-qpushbutton "Flip Parity" debugger)) - -(define-slot (debugger disassembly-toggle-parity) () - (declare (connected disassembly-parity-button (pressed))) - (disassembly-model-toggle-parity model-disassembly)) - - - -;;;; Register Viewer ---------------------------------------------------------- -;;;; Code -(defmacro register-case (row &key - register index program-counter delay-timer sound-timer) - (once-only (row) - `(cond - ((<= ,row 15) ,register) - ((= ,row 16) ,index) - ((= ,row 17) ,program-counter) - ((= ,row 18) ,delay-timer) - ((= ,row 19) ,sound-timer) - (t (error "Bad register row ~D" ,row))))) - -(defun registers-label (row) - (register-case row - :register (format nil "V~X" row) - :index "I" - :program-counter "PC" - :delay-timer "DT" - :sound-timer "ST")) - -(defun registers-value (chip row) - (register-case row - :register (format nil "~2,'0X" (aref (chip8::chip-registers chip) row)) - :index (format nil "~4,'0X" (chip8::chip-index chip)) - :program-counter (format nil "~3,'0X" (chip8::chip-program-counter chip)) - :delay-timer (format nil "~2,'0X" (chip8::chip-delay-timer chip)) - :sound-timer (format nil "~2,'0X" (chip8::chip-sound-timer chip)))) - -(defun (setf registers-value) (new-value chip row) - (register-case row - :register (setf (aref (chip8::chip-registers chip) row) new-value) - :index (setf (chip8::chip-index chip) new-value) - :program-counter (setf (chip8::chip-program-counter chip) new-value) - :delay-timer (setf (chip8::chip-delay-timer chip) new-value) - :sound-timer (setf (chip8::chip-sound-timer chip) new-value))) - -(defun registers-max-value (row) - (register-case row - :register #xFF - :index #xFFFF - :program-counter #xFFF - :delay-timer #xFF - :sound-timer #xFF)) - - -;;;; Model -(define-widget registers-model (QAbstractTableModel) - ((chip :initarg :chip))) - - -(define-override (registers-model column-count) (index) - (declare (ignore index)) - 2) - -(define-override (registers-model row-count) (index) - (declare (ignore index)) - 20) - - -(defun registers-index-valid-p (index) - (and (q+:is-valid index) - (< (q+:row index) 20))) - -(define-override (registers-model data) (index role) - (let ((row (q+:row index)) - (col (q+:column index))) - (if (not (registers-index-valid-p index)) - (q+:make-qvariant) - (qtenumcase role - ((q+:qt.display-role) - (ecase col - (0 (registers-label row)) - (1 (registers-value chip row)))) - ((q+:qt.text-alignment-role) #x0082) - ((q+:qt.font-role) *font*) - (t (q+:make-qvariant)))))) - -(define-override (registers-model header-data) (section orientation role) - (declare (ignore section orientation role)) - (q+:make-qvariant)) - -(define-override (registers-model flags) (index) - ;; The register data column should be editable. - (let ((base (call-next-qmethod index))) - (cond - ((not (registers-index-valid-p index)) - (q+:qt.item-is-enabled)) - ((= (q+:column index) 1) - (logior base (q+:qt.item-is-editable))) - (t base)))) - - -(defun parse-hex (string max) - (let ((value (handler-case (parse-integer string :radix 16) - (error () nil)))) - (if (and value (<= value max)) - value - nil))) - -(define-override (registers-model set-data) (index value role) - (if (and (registers-index-valid-p index) - (eql role (q+:qt.edit-role))) - (let* ((row (q+:row index)) - (val (parse-hex value (registers-max-value row)))) - (when val - (setf (registers-value chip row) val) - (data-changed! registers-model index)) - t) - nil)) - - -;;;; Layout -(defun registers-refresh (model view address) - (declare (ignore view address)) - (signal! model (data-changed "QModelIndex" "QModelIndex") - (model-index model 0 1) - (model-index model 18 1))) - -(define-subwidget (debugger registers-table) (q+:make-qtableview debugger) - (chip8::debugger-add-callback-arrived - chip-debugger - (curry #'registers-refresh model-registers registers-table)) - (q+:set-model registers-table model-registers) - (q+:set-show-grid registers-table nil) - (q+:set-column-width registers-table 0 30) - (q+:set-column-width registers-table 1 40) - (let ((vheader (q+:vertical-header registers-table))) - (q+:hide vheader) - (q+:set-resize-mode vheader (q+:qheaderview.fixed)) - (q+:set-default-section-size vheader 14)) - (let ((hheader (q+:horizontal-header registers-table))) - (q+:hide hheader))) - - -;;;; Stack Viewer ------------------------------------------------------------- -;;;; Code -(defun stack-value (chip index) - (aref (chip8::chip-stack chip) index)) - -(defun stack-size (chip) - (length (chip8::chip-stack chip))) - - -;;;; Model -(define-widget stack-model (QAbstractListModel) - ((chip :initarg :chip))) - -(define-override (stack-model row-count) (index) - (declare (ignore index)) - (stack-size chip)) - - -(defun stack-index-valid-p (index chip) - (and (q+:is-valid index) - (< (q+:row index) (stack-size chip)))) - -(defun get-stack-contents (chip row) - (format nil "~3,'0X" (stack-value chip row))) - - -(define-override (stack-model data) (index role) - (let ((row (q+:row index))) - (if (not (stack-index-valid-p index chip)) - (q+:make-qvariant) - (qtenumcase role - ((q+:qt.display-role) (get-stack-contents chip row)) - ((q+:qt.font-role) *font*) - ; ((q+:qt.text-alignment-role) (case col - ; (0 #x0082) - ; (1 #x0084) - ; (2 #x0080) - ; (3 #x0080))) - (t (q+:make-qvariant)))))) - - -;;;; Layout -(defun stack-refresh (model view address) - (declare (ignore view address)) - ;; fuck it just refresh everything - (signal! model (layout-changed))) - -(define-subwidget (debugger stack-list) (q+:make-qlistview debugger) - (chip8::debugger-add-callback-arrived - chip-debugger - (curry #'stack-refresh model-stack stack-list)) - (q+:set-model stack-list model-stack)) - -(define-subwidget (debugger stack-label) - (q+:make-qlabel "Stack" debugger)) - - - -;;;; Main GUI ----------------------------------------------------------------- -(define-subwidget (debugger layout) (q+:make-qhboxlayout debugger) - (let ((disassembly (q+:make-qvboxlayout))) - (q+:add-widget disassembly disassembly-table) - (q+:add-widget disassembly disassembly-parity-button) - (q+:add-layout layout disassembly)) - (let ((values (q+:make-qvboxlayout))) - (q+:set-fixed-width registers-table 90) - (q+:set-fixed-width stack-label 90) - (q+:set-fixed-width stack-list 90) - (q+:set-maximum-height stack-list 260) - (q+:add-widget values registers-table) - (q+:add-widget values stack-label) - (q+:add-widget values stack-list) - (q+:add-layout layout values))) - - -(defun make-debugger (chip) - (let ((model-disassembly (make-instance 'disassembly-model :chip chip)) - (model-registers (make-instance 'registers-model :chip chip)) - (model-stack (make-instance 'stack-model :chip chip))) - (make-instance 'debugger - :model-disassembly model-disassembly - :model-registers model-registers - :model-stack model-stack - :chip-debugger (chip8::chip-debugger chip)))) - -(defun run (chip) - (with-main-window (window (make-debugger chip)))) - - -(defparameter *c* (chip8::make-chip)) -(chip8::load-rom *c* "roms/breakout.rom") diff -r 2dd99e07f368 -r ee000116796f src/emulator.lisp --- a/src/emulator.lisp Fri Dec 16 14:36:52 2016 -0500 +++ b/src/emulator.lisp Fri Dec 16 14:42:58 2016 -0500 @@ -713,7 +713,7 @@ (load-rom chip rom-filename) (when start-paused (debugger-pause (chip-debugger chip))) - (chip8.gui::run-gui + (chip8.gui.screen::run-gui chip (lambda () ;; Really it's just the sound that needs to be here... diff -r 2dd99e07f368 -r ee000116796f src/gui.lisp --- a/src/gui.lisp Fri Dec 16 14:36:52 2016 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,236 +0,0 @@ -(in-package :chip8.gui) -(named-readtables:in-readtable :qtools) - - -;;;; Config ------------------------------------------------------------------- -(defparameter *current* nil) -(defparameter *scale* 8) -(defparameter *width* (* *scale* 64)) -(defparameter *height* (* *scale* 32)) -(defparameter *fps* 60) - - -;;;; Data --------------------------------------------------------------------- -(defstruct gui chip screen) - - -;;;; OpenGL ------------------------------------------------------------------- -(defun initialize-texture (size) - (let* ((handle (gl:gen-texture))) - (gl:bind-texture :texture-2d handle) - - (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) - (gl:tex-parameter :texture-2d :texture-mag-filter :nearest) - (gl:enable :texture-2d) - - (gl:bind-texture :texture-2d 0) - - handle)) - - -;;;; Screen ------------------------------------------------------------------- -(define-widget screen (QGLWidget) - ((texture :accessor screen-texture) - (debugger :accessor screen-debugger :initarg :debugger) - (chip :accessor screen-chip :initarg :chip))) - -(defun make-screen (chip) - (let ((debugger (chip8.debugger::make-debugger chip))) - (make-instance 'screen - :debugger debugger - :chip chip))) - - -(defun die (screen) - (setf (chip8::chip-running (screen-chip screen)) nil) - (q+:close (screen-debugger screen)) - (q+:close screen)) - -(define-initializer (screen setup) - (setf (q+:window-title screen) "cl-chip8" - (q+:fixed-size screen) (values *width* *height*)) - (q+:show debugger)) - -(define-override (screen "initializeGL") () - (setf (screen-texture screen) (initialize-texture 64)) - (stop-overriding)) - -(define-subwidget (screen timer) (q+:make-qtimer screen) - (setf (q+:single-shot timer) NIL) - (q+:start timer (round 1000 *fps*))) - -(define-slot (screen update) () - (declare (connected timer (timeout))) - - (if (chip8::chip-running (screen-chip screen)) - (q+:repaint screen) - (die screen))) - - -(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:bind-texture :texture-2d (screen-texture screen)) - - (let ((chip (screen-chip screen))) - (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)))) - - (let ((tw 1) - (th 0.5)) - (gl:with-primitives :quads - (gl:tex-coord 0 0) - (gl:vertex 0 0) - - (gl:tex-coord tw 0) - (gl:vertex *width* 0) - - (gl:tex-coord tw th) - (gl:vertex *width* *height*) - - (gl:tex-coord 0 th) - (gl:vertex 0 *height*))) - - (gl:bind-texture :texture-2d 0) - - (q+:end-native-painting painter)) - -(defun render-debug (screen painter) - (when (-> screen screen-chip chip8::chip-debugger chip8::debugger-paused) - (with-finalizing* ((font (q+:make-qfont "Menlo" 20)) - (border-color (q+:make-qcolor 255 255 255)) - (fill-color (q+:make-qcolor 0 0 0)) - (path (q+:make-qpainterpath)) - (pen (q+:make-qpen)) - (brush (q+:make-qbrush fill-color))) - (setf (q+:width pen) 1) - (setf (q+:color pen) border-color) - - (setf (q+:pen painter) pen) - (setf (q+:brush painter) brush) - (setf (q+:font painter) font) - (setf (q+:weight font) (q+:qfont.black)) - (setf (q+:style-hint font) (q+:qfont.type-writer)) - - ; (setf (q+:pen painter) (q+:make-qcolor "#ff0000")) - (q+:add-text path 10 20 font "PAUSED") - (q+:draw-path painter path)))) - -(define-override (screen paint-event) (ev) - (declare (ignore ev)) - (with-finalizing ((painter (q+:make-qpainter screen))) - (render-screen screen painter) - (render-debug screen painter))) - - -(defun pad-key-for (code) - ;; Original Chip-8 Pad → Modern Numpad - ;; ┌─┬─┬─┬─┐ ┌─┬─┬─┬─┐ - ;; │1│2│3│C│ │←│/│*│-│ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ - ;; │4│5│6│D│ │7│8│9│+│ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┤ │ - ;; │7│8│9│E│ │4│5│6│ │ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ - ;; │A│0│B│F│ │1│2│3│↲│ - ;; └─┴─┴─┴─┘ ├─┴─┼─┤ │ - ;; │0 │.│ │ - ;; └───┴─┴─┘ - (cond - ((= code (q+:qt.key_clear)) #x1) - ((= code (q+:qt.key_slash)) #x2) - ((= code (q+:qt.key_asterisk)) #x3) - ((= code (q+:qt.key_minus)) #xC) - - ((= code (q+:qt.key_7)) #x4) - ((= code (q+:qt.key_8)) #x5) - ((= code (q+:qt.key_9)) #x6) - ((= code (q+:qt.key_plus)) #xD) - - ((= code (q+:qt.key_4)) #x7) - ((= code (q+:qt.key_5)) #x8) - ((= code (q+:qt.key_6)) #x9) - ((= code (q+:qt.key_enter)) #xE) - - ((= code (q+:qt.key_1)) #xA) - ((= code (q+:qt.key_2)) #x0) - ((= code (q+:qt.key_3)) #xB) - ((= code (q+:qt.key_0)) #xF))) - -(defun pad-key-for (code) - ;; Original Chip-8 Pad → Laptop - ;; ┌─┬─┬─┬─┐ ┌─┬─┬─┬─┐ - ;; │1│2│3│C│ │1│2│3│4│ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ - ;; │4│5│6│D│ │Q│W│E│R│ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ - ;; │7│8│9│E│ │A│S│D│F│ - ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ - ;; │A│0│B│F│ │Z│X│C│V│ - ;; └─┴─┴─┴─┘ └─┴─┴─┴─┘ - ;; - (cond - ((= code (q+:qt.key_1)) #x1) - ((= code (q+:qt.key_2)) #x2) - ((= code (q+:qt.key_3)) #x3) - ((= code (q+:qt.key_4)) #xC) - - ((= code (q+:qt.key_q)) #x4) - ((= code (q+:qt.key_w)) #x5) - ((= code (q+:qt.key_e)) #x6) - ((= code (q+:qt.key_r)) #xD) - - ((= code (q+:qt.key_a)) #x7) - ((= code (q+:qt.key_s)) #x8) - ((= code (q+:qt.key_d)) #x9) - ((= code (q+:qt.key_f)) #xE) - - ((= code (q+:qt.key_z)) #xA) - ((= code (q+:qt.key_x)) #x0) - ((= code (q+:qt.key_c)) #xB) - ((= code (q+:qt.key_v)) #xF))) - - -(define-override (screen key-press-event) (ev) - (let* ((key (q+:key ev)) - (pad-key (pad-key-for key))) - (when pad-key - (chip8::keydown chip pad-key))) - (stop-overriding)) - -(define-override (screen key-release-event) (ev) - (let* ((key (q+:key ev)) - (pad-key (pad-key-for key))) - (if pad-key - (chip8::keyup chip pad-key) - (qtenumcase key - ((q+:qt.key_escape) - (die screen)) - - ((q+:qt.key_space) - (-> chip chip8::chip-debugger chip8::debugger-toggle-pause)) - - ((q+:qt.key_f1) - (-> chip chip8::reset)) - - ((q+:qt.key_f7) - (-> chip chip8::chip-debugger chip8::debugger-step)) - - (t (pr :unknown-key (format nil "~X" key)))))) - (stop-overriding)) - - -;;;; Main --------------------------------------------------------------------- -(defun run-gui (chip thunk) - (with-main-window - (window (make-screen chip)) - (funcall thunk))) - - diff -r 2dd99e07f368 -r ee000116796f src/gui/debugger.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/gui/debugger.lisp Fri Dec 16 14:42:58 2016 -0500 @@ -0,0 +1,401 @@ +(in-package :chip8.gui.debugger) +(named-readtables:in-readtable :qtools) +(declaim (optimize (debug 3))) + + +(defparameter *font* (q+:make-qfont "Menlo" 12)) +(defparameter *current-instruction-brush* + (q+:make-qbrush (q+:make-qcolor 216 162 223))) + + +;;;; Main GUI ----------------------------------------------------------------- +(define-widget debugger (QWidget) + ((model-disassembly :initarg :model-disassembly) + (model-registers :initarg :model-registers) + (model-stack :initarg :model-stack) + (chip-debugger :initarg :chip-debugger))) + +(define-initializer (debugger setup) + (setf (q+:window-title debugger) "Debugger") + (q+:resize debugger 580 800)) + + +;;;; Utils -------------------------------------------------------------------- +(defun model-index (model row col) + (q+:index model row col (q+:make-qmodelindex))) + +(defun data-changed! (model index-from &optional (index-to index-from)) + (signal! model (data-changed "QModelIndex" "QModelIndex") + index-from + index-to)) + + +;;;; Disassembler ------------------------------------------------------------- +;;;; Code +(defun disassemble-address (chip address) + (-<> chip + chip8::chip-memory + (chip8::instruction-information <> address))) + + +;;;; Model +(define-widget disassembly-model (QAbstractTableModel) + ((chip :initarg :chip) + (parity :initform 0) + (current-address :initform 0))) + + +(defun disassembly-model-address-to-row (model address) + (-<> address + (+ <> (slot-value model 'parity)) + (truncate <> 2) + (values <>))) + + +(defun disassembly-model-update-current-address (model new-address) + (let* ((old-address (slot-value model 'current-address)) + (old-row (disassembly-model-address-to-row model old-address)) + (new-row (disassembly-model-address-to-row model new-address))) + (setf (slot-value model 'current-address) new-address) + (data-changed! model + (model-index model old-row 0) + (model-index model old-row 3)) + (data-changed! model + (model-index model new-row 0) + (model-index model new-row 3)))) + +(defun disassembly-model-toggle-parity (model) + (zapf (slot-value model 'parity) (if (zerop %) 1 0)) + (signal! model (layout-changed))) + + +(define-override (disassembly-model column-count) (index) + (declare (ignore index)) + 4) + +(define-override (disassembly-model row-count) (index) + (declare (ignore index)) + (+ parity (ceiling 4096 2))) + + +(defun disassembly-index-valid-p (index) + (and (q+:is-valid index) + (< (q+:row index) (ceiling 4096 2)))) + +(defun get-disassembly-contents (model row col) + (let ((data (-<> model + (slot-value <> 'chip) + (disassemble-address <> (- (* 2 row) + (slot-value model 'parity))) + (nth col <>)))) + (ecase col + (0 (format nil "~3,'0X" data)) + (1 (format nil "~4,'0X" data)) + (2 (if data + (let ((*print-base* 16)) + (format nil "~A ~{~A~^, ~}" (first data) (rest data))) + "")) + (3 data)))) + +(define-override (disassembly-model data) (index role) + (let ((row (q+:row index)) + (col (q+:column index))) + (if (not (disassembly-index-valid-p index)) + (q+:make-qvariant) + (qtenumcase role + ((q+:qt.display-role) + (get-disassembly-contents disassembly-model row col)) + + ((q+:qt.font-role) *font*) + + ((q+:qt.background-role) + (if (= row (disassembly-model-address-to-row disassembly-model + current-address)) + *current-instruction-brush* + (q+:make-qvariant))) + + ((q+:qt.text-alignment-role) (case col + (0 #x0082) + (1 #x0084) + (2 #x0080) + (3 #x0080))) + + (t (q+:make-qvariant)))))) + +(define-override (disassembly-model header-data) (section orientation role) + (case role + (0 (qtenumcase orientation + ((q+:qt.vertical) (q+:make-qvariant)) + ((q+:qt.horizontal) (case section + (0 "Addr") + (1 "Inst") + (2 "Disassembly") + (3 "Bits"))))) + (t (q+:make-qvariant)))) + + +;;;; Layout +(defun disassembly-update-address (model view address) + (disassembly-model-update-current-address model address) + (-<> address + ;; raw address -> row number + (disassembly-model-address-to-row model <>) + ;; Give ourselves a bit of breathing room at the top of the table + (- <> 4) + (max <> 0) + ;; get a QModelIndex, because passing a pair of ints would be too easy + (model-index model <> 0) + ;; make the debugger show the current line + (q+:scroll-to view <> (q+:qabstractitemview.position-at-top)))) + +(define-subwidget (debugger disassembly-table) + (q+:make-qtableview debugger) + (chip8::debugger-add-callback-arrived + chip-debugger ; bit of a fustercluck here... + (curry #'disassembly-update-address model-disassembly disassembly-table)) + (q+:set-model disassembly-table model-disassembly) + (q+:set-show-grid disassembly-table nil) + (q+:set-column-width disassembly-table 0 40) + (q+:set-column-width disassembly-table 1 60) + (q+:set-column-width disassembly-table 2 200) + (q+:set-column-width disassembly-table 3 90) + (let ((vheader (q+:vertical-header disassembly-table))) + (q+:hide vheader) + (q+:set-resize-mode vheader (q+:qheaderview.fixed)) + (q+:set-default-section-size vheader 14))) + +(define-subwidget (debugger disassembly-parity-button) + (q+:make-qpushbutton "Flip Parity" debugger)) + +(define-slot (debugger disassembly-toggle-parity) () + (declare (connected disassembly-parity-button (pressed))) + (disassembly-model-toggle-parity model-disassembly)) + + + +;;;; Register Viewer ---------------------------------------------------------- +;;;; Code +(defmacro register-case (row &key + register index program-counter delay-timer sound-timer) + (once-only (row) + `(cond + ((<= ,row 15) ,register) + ((= ,row 16) ,index) + ((= ,row 17) ,program-counter) + ((= ,row 18) ,delay-timer) + ((= ,row 19) ,sound-timer) + (t (error "Bad register row ~D" ,row))))) + +(defun registers-label (row) + (register-case row + :register (format nil "V~X" row) + :index "I" + :program-counter "PC" + :delay-timer "DT" + :sound-timer "ST")) + +(defun registers-value (chip row) + (register-case row + :register (format nil "~2,'0X" (aref (chip8::chip-registers chip) row)) + :index (format nil "~4,'0X" (chip8::chip-index chip)) + :program-counter (format nil "~3,'0X" (chip8::chip-program-counter chip)) + :delay-timer (format nil "~2,'0X" (chip8::chip-delay-timer chip)) + :sound-timer (format nil "~2,'0X" (chip8::chip-sound-timer chip)))) + +(defun (setf registers-value) (new-value chip row) + (register-case row + :register (setf (aref (chip8::chip-registers chip) row) new-value) + :index (setf (chip8::chip-index chip) new-value) + :program-counter (setf (chip8::chip-program-counter chip) new-value) + :delay-timer (setf (chip8::chip-delay-timer chip) new-value) + :sound-timer (setf (chip8::chip-sound-timer chip) new-value))) + +(defun registers-max-value (row) + (register-case row + :register #xFF + :index #xFFFF + :program-counter #xFFF + :delay-timer #xFF + :sound-timer #xFF)) + + +;;;; Model +(define-widget registers-model (QAbstractTableModel) + ((chip :initarg :chip))) + + +(define-override (registers-model column-count) (index) + (declare (ignore index)) + 2) + +(define-override (registers-model row-count) (index) + (declare (ignore index)) + 20) + + +(defun registers-index-valid-p (index) + (and (q+:is-valid index) + (< (q+:row index) 20))) + +(define-override (registers-model data) (index role) + (let ((row (q+:row index)) + (col (q+:column index))) + (if (not (registers-index-valid-p index)) + (q+:make-qvariant) + (qtenumcase role + ((q+:qt.display-role) + (ecase col + (0 (registers-label row)) + (1 (registers-value chip row)))) + ((q+:qt.text-alignment-role) #x0082) + ((q+:qt.font-role) *font*) + (t (q+:make-qvariant)))))) + +(define-override (registers-model header-data) (section orientation role) + (declare (ignore section orientation role)) + (q+:make-qvariant)) + +(define-override (registers-model flags) (index) + ;; The register data column should be editable. + (let ((base (call-next-qmethod index))) + (cond + ((not (registers-index-valid-p index)) + (q+:qt.item-is-enabled)) + ((= (q+:column index) 1) + (logior base (q+:qt.item-is-editable))) + (t base)))) + + +(defun parse-hex (string max) + (let ((value (handler-case (parse-integer string :radix 16) + (error () nil)))) + (if (and value (<= value max)) + value + nil))) + +(define-override (registers-model set-data) (index value role) + (if (and (registers-index-valid-p index) + (eql role (q+:qt.edit-role))) + (let* ((row (q+:row index)) + (val (parse-hex value (registers-max-value row)))) + (when val + (setf (registers-value chip row) val) + (data-changed! registers-model index)) + t) + nil)) + + +;;;; Layout +(defun registers-refresh (model view address) + (declare (ignore view address)) + (signal! model (data-changed "QModelIndex" "QModelIndex") + (model-index model 0 1) + (model-index model 18 1))) + +(define-subwidget (debugger registers-table) (q+:make-qtableview debugger) + (chip8::debugger-add-callback-arrived + chip-debugger + (curry #'registers-refresh model-registers registers-table)) + (q+:set-model registers-table model-registers) + (q+:set-show-grid registers-table nil) + (q+:set-column-width registers-table 0 30) + (q+:set-column-width registers-table 1 40) + (let ((vheader (q+:vertical-header registers-table))) + (q+:hide vheader) + (q+:set-resize-mode vheader (q+:qheaderview.fixed)) + (q+:set-default-section-size vheader 14)) + (let ((hheader (q+:horizontal-header registers-table))) + (q+:hide hheader))) + + +;;;; Stack Viewer ------------------------------------------------------------- +;;;; Code +(defun stack-value (chip index) + (aref (chip8::chip-stack chip) index)) + +(defun stack-size (chip) + (length (chip8::chip-stack chip))) + + +;;;; Model +(define-widget stack-model (QAbstractListModel) + ((chip :initarg :chip))) + +(define-override (stack-model row-count) (index) + (declare (ignore index)) + (stack-size chip)) + + +(defun stack-index-valid-p (index chip) + (and (q+:is-valid index) + (< (q+:row index) (stack-size chip)))) + +(defun get-stack-contents (chip row) + (format nil "~3,'0X" (stack-value chip row))) + + +(define-override (stack-model data) (index role) + (let ((row (q+:row index))) + (if (not (stack-index-valid-p index chip)) + (q+:make-qvariant) + (qtenumcase role + ((q+:qt.display-role) (get-stack-contents chip row)) + ((q+:qt.font-role) *font*) + ; ((q+:qt.text-alignment-role) (case col + ; (0 #x0082) + ; (1 #x0084) + ; (2 #x0080) + ; (3 #x0080))) + (t (q+:make-qvariant)))))) + + +;;;; Layout +(defun stack-refresh (model view address) + (declare (ignore view address)) + ;; fuck it just refresh everything + (signal! model (layout-changed))) + +(define-subwidget (debugger stack-list) (q+:make-qlistview debugger) + (chip8::debugger-add-callback-arrived + chip-debugger + (curry #'stack-refresh model-stack stack-list)) + (q+:set-model stack-list model-stack)) + +(define-subwidget (debugger stack-label) + (q+:make-qlabel "Stack" debugger)) + + + +;;;; Main GUI ----------------------------------------------------------------- +(define-subwidget (debugger layout) (q+:make-qhboxlayout debugger) + (let ((disassembly (q+:make-qvboxlayout))) + (q+:add-widget disassembly disassembly-table) + (q+:add-widget disassembly disassembly-parity-button) + (q+:add-layout layout disassembly)) + (let ((values (q+:make-qvboxlayout))) + (q+:set-fixed-width registers-table 90) + (q+:set-fixed-width stack-label 90) + (q+:set-fixed-width stack-list 90) + (q+:set-maximum-height stack-list 260) + (q+:add-widget values registers-table) + (q+:add-widget values stack-label) + (q+:add-widget values stack-list) + (q+:add-layout layout values))) + + +(defun make-debugger (chip) + (let ((model-disassembly (make-instance 'disassembly-model :chip chip)) + (model-registers (make-instance 'registers-model :chip chip)) + (model-stack (make-instance 'stack-model :chip chip))) + (make-instance 'debugger + :model-disassembly model-disassembly + :model-registers model-registers + :model-stack model-stack + :chip-debugger (chip8::chip-debugger chip)))) + +(defun run (chip) + (with-main-window (window (make-debugger chip)))) + + +(defparameter *c* (chip8::make-chip)) +(chip8::load-rom *c* "roms/breakout.rom") diff -r 2dd99e07f368 -r ee000116796f src/gui/screen.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/gui/screen.lisp Fri Dec 16 14:42:58 2016 -0500 @@ -0,0 +1,236 @@ +(in-package :chip8.gui.screen) +(named-readtables:in-readtable :qtools) + + +;;;; Config ------------------------------------------------------------------- +(defparameter *current* nil) +(defparameter *scale* 8) +(defparameter *width* (* *scale* 64)) +(defparameter *height* (* *scale* 32)) +(defparameter *fps* 60) + + +;;;; Data --------------------------------------------------------------------- +(defstruct gui chip screen) + + +;;;; OpenGL ------------------------------------------------------------------- +(defun initialize-texture (size) + (let* ((handle (gl:gen-texture))) + (gl:bind-texture :texture-2d handle) + + (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) + (gl:tex-parameter :texture-2d :texture-mag-filter :nearest) + (gl:enable :texture-2d) + + (gl:bind-texture :texture-2d 0) + + handle)) + + +;;;; Screen ------------------------------------------------------------------- +(define-widget screen (QGLWidget) + ((texture :accessor screen-texture) + (debugger :accessor screen-debugger :initarg :debugger) + (chip :accessor screen-chip :initarg :chip))) + +(defun make-screen (chip) + (let ((debugger (chip8.gui.debugger::make-debugger chip))) + (make-instance 'screen + :debugger debugger + :chip chip))) + + +(defun die (screen) + (setf (chip8::chip-running (screen-chip screen)) nil) + (q+:close (screen-debugger screen)) + (q+:close screen)) + +(define-initializer (screen setup) + (setf (q+:window-title screen) "cl-chip8" + (q+:fixed-size screen) (values *width* *height*)) + (q+:show debugger)) + +(define-override (screen "initializeGL") () + (setf (screen-texture screen) (initialize-texture 64)) + (stop-overriding)) + +(define-subwidget (screen timer) (q+:make-qtimer screen) + (setf (q+:single-shot timer) NIL) + (q+:start timer (round 1000 *fps*))) + +(define-slot (screen update) () + (declare (connected timer (timeout))) + + (if (chip8::chip-running (screen-chip screen)) + (q+:repaint screen) + (die screen))) + + +(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:bind-texture :texture-2d (screen-texture screen)) + + (let ((chip (screen-chip screen))) + (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)))) + + (let ((tw 1) + (th 0.5)) + (gl:with-primitives :quads + (gl:tex-coord 0 0) + (gl:vertex 0 0) + + (gl:tex-coord tw 0) + (gl:vertex *width* 0) + + (gl:tex-coord tw th) + (gl:vertex *width* *height*) + + (gl:tex-coord 0 th) + (gl:vertex 0 *height*))) + + (gl:bind-texture :texture-2d 0) + + (q+:end-native-painting painter)) + +(defun render-debug (screen painter) + (when (-> screen screen-chip chip8::chip-debugger chip8::debugger-paused) + (with-finalizing* ((font (q+:make-qfont "Menlo" 20)) + (border-color (q+:make-qcolor 255 255 255)) + (fill-color (q+:make-qcolor 0 0 0)) + (path (q+:make-qpainterpath)) + (pen (q+:make-qpen)) + (brush (q+:make-qbrush fill-color))) + (setf (q+:width pen) 1) + (setf (q+:color pen) border-color) + + (setf (q+:pen painter) pen) + (setf (q+:brush painter) brush) + (setf (q+:font painter) font) + (setf (q+:weight font) (q+:qfont.black)) + (setf (q+:style-hint font) (q+:qfont.type-writer)) + + ; (setf (q+:pen painter) (q+:make-qcolor "#ff0000")) + (q+:add-text path 10 20 font "PAUSED") + (q+:draw-path painter path)))) + +(define-override (screen paint-event) (ev) + (declare (ignore ev)) + (with-finalizing ((painter (q+:make-qpainter screen))) + (render-screen screen painter) + (render-debug screen painter))) + + +(defun pad-key-for (code) + ;; Original Chip-8 Pad → Modern Numpad + ;; ┌─┬─┬─┬─┐ ┌─┬─┬─┬─┐ + ;; │1│2│3│C│ │←│/│*│-│ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ + ;; │4│5│6│D│ │7│8│9│+│ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┤ │ + ;; │7│8│9│E│ │4│5│6│ │ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ + ;; │A│0│B│F│ │1│2│3│↲│ + ;; └─┴─┴─┴─┘ ├─┴─┼─┤ │ + ;; │0 │.│ │ + ;; └───┴─┴─┘ + (cond + ((= code (q+:qt.key_clear)) #x1) + ((= code (q+:qt.key_slash)) #x2) + ((= code (q+:qt.key_asterisk)) #x3) + ((= code (q+:qt.key_minus)) #xC) + + ((= code (q+:qt.key_7)) #x4) + ((= code (q+:qt.key_8)) #x5) + ((= code (q+:qt.key_9)) #x6) + ((= code (q+:qt.key_plus)) #xD) + + ((= code (q+:qt.key_4)) #x7) + ((= code (q+:qt.key_5)) #x8) + ((= code (q+:qt.key_6)) #x9) + ((= code (q+:qt.key_enter)) #xE) + + ((= code (q+:qt.key_1)) #xA) + ((= code (q+:qt.key_2)) #x0) + ((= code (q+:qt.key_3)) #xB) + ((= code (q+:qt.key_0)) #xF))) + +(defun pad-key-for (code) + ;; Original Chip-8 Pad → Laptop + ;; ┌─┬─┬─┬─┐ ┌─┬─┬─┬─┐ + ;; │1│2│3│C│ │1│2│3│4│ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ + ;; │4│5│6│D│ │Q│W│E│R│ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ + ;; │7│8│9│E│ │A│S│D│F│ + ;; ├─┼─┼─┼─┤ ├─┼─┼─┼─┤ + ;; │A│0│B│F│ │Z│X│C│V│ + ;; └─┴─┴─┴─┘ └─┴─┴─┴─┘ + ;; + (cond + ((= code (q+:qt.key_1)) #x1) + ((= code (q+:qt.key_2)) #x2) + ((= code (q+:qt.key_3)) #x3) + ((= code (q+:qt.key_4)) #xC) + + ((= code (q+:qt.key_q)) #x4) + ((= code (q+:qt.key_w)) #x5) + ((= code (q+:qt.key_e)) #x6) + ((= code (q+:qt.key_r)) #xD) + + ((= code (q+:qt.key_a)) #x7) + ((= code (q+:qt.key_s)) #x8) + ((= code (q+:qt.key_d)) #x9) + ((= code (q+:qt.key_f)) #xE) + + ((= code (q+:qt.key_z)) #xA) + ((= code (q+:qt.key_x)) #x0) + ((= code (q+:qt.key_c)) #xB) + ((= code (q+:qt.key_v)) #xF))) + + +(define-override (screen key-press-event) (ev) + (let* ((key (q+:key ev)) + (pad-key (pad-key-for key))) + (when pad-key + (chip8::keydown chip pad-key))) + (stop-overriding)) + +(define-override (screen key-release-event) (ev) + (let* ((key (q+:key ev)) + (pad-key (pad-key-for key))) + (if pad-key + (chip8::keyup chip pad-key) + (qtenumcase key + ((q+:qt.key_escape) + (die screen)) + + ((q+:qt.key_space) + (-> chip chip8::chip-debugger chip8::debugger-toggle-pause)) + + ((q+:qt.key_f1) + (-> chip chip8::reset)) + + ((q+:qt.key_f7) + (-> chip chip8::chip-debugger chip8::debugger-step)) + + (t (pr :unknown-key (format nil "~X" key)))))) + (stop-overriding)) + + +;;;; Main --------------------------------------------------------------------- +(defun run-gui (chip thunk) + (with-main-window + (window (make-screen chip)) + (funcall thunk))) + +