5e7aa5bae23f

--- a/src/debugger.lisp	Thu Nov 17 21:04:40 2016 +0000
+++ b/src/debugger.lisp	Thu Nov 17 23:54:14 2016 +0000
@@ -1,7 +1,7 @@
 (in-package :chip8.debugger)
 (named-readtables:in-readtable :qtools)
 
-
+;;;; Disassembler -------------------------------------------------------------
 (defun disassemble-instruction (instruction)
   (let ((_x__ (ldb (byte 4 8) instruction))
         (__x_ (ldb (byte 4 4) instruction))
@@ -71,17 +71,101 @@
                                          (if (< (1+ i) len)
                                            (aref array (1+ i))
                                            0)))
-    (collect (list i
-                   instruction
-                   (disassemble-instruction instruction)
-                   (bit-diagram instruction)))))
+    (collect (vector i
+                     instruction
+                     (disassemble-instruction instruction)
+                     (bit-diagram instruction))
+             :result-type vector)))
 
 (defun dump (array start &optional (offset 0))
   (iterate (for (address instruction disassembly bits)
-                :in (disassemble-instructions array start))
+                :in-array (disassemble-instructions array start))
            (sleep 0.005)
            (format t "~3,'0X: ~4,'0X ~24A ~8A~%"
                    (+ address offset)
                    instruction
                    (or disassembly "")
                    bits)))
+
+(defparameter *test*
+  (disassemble-instructions (read-file-into-byte-vector "roms/tictac.rom")
+                            0))
+
+(defparameter *font* (q+:make-qfont "Menlo" 12))
+
+
+;;;; Model --------------------------------------------------------------------
+(define-widget disassembly-model (QAbstractTableModel)
+  ((data :accessor model-data :initarg :data :initform *test*)))
+
+(define-override (disassembly-model column-count) (index)
+  (declare (ignore index))
+  4)
+
+(define-override (disassembly-model row-count) (index)
+  (declare (ignore index))
+  (-<> disassembly-model
+    model-data
+    length))
+
+(define-override (disassembly-model data) (index role)
+  (let ((row (q+:row index))
+        (col (q+:column index)))
+    (qtenumcase role
+      ((q+:qt.display-role)
+       (let ((data (-<> disassembly-model
+                     model-data
+                     (aref <> row)
+                     (aref <> col))))
+         (case (q+:column index)
+           (0 (format nil "~3,'0X" data))
+           (1 (format nil "~4,'0X" data))
+           (2 (if data
+                (let ((*print-base* 16))
+                  (format nil "~A ~{~S~^, ~}" (first data) (rest data)))
+                ""))
+           (3 data))))
+      ((q+:qt.font-role) *font*)
+      ((q+:qt.text-alignment-role) (case col
+                                     (0 #x0082)
+                                     (1 #x0084)
+                                     (2 #x0080)
+                                     (3 #x0084)))
+      (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))))
+
+
+(define-widget debugger (QWidget)
+  ((model :accessor debugger-model
+          :initform (make-instance 'disassembly-model))))
+
+
+(define-subwidget (debugger table) (q+:make-qtableview debugger)
+  (q+:set-model table model)
+  (q+:set-show-grid table nil)
+  (q+:set-column-width table 0 40)
+  (q+:set-column-width table 1 60)
+  (q+:set-column-width table 2 200)
+  (q+:set-column-width table 3 90)
+  (let ((vheader (q+:vertical-header table)))
+    (q+:set-resize-mode vheader (q+:qheaderview.fixed))
+    (q+:set-default-section-size vheader 15)
+    )
+  )
+
+(define-subwidget (debugger layout) (q+:make-qvboxlayout debugger)
+  (q+:add-widget layout table))
+
+
+(defun run ()
+  (with-main-window (window 'debugger)))