sjl/gui.lisp

## gui.lisp
(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 -------------------------------------------------------------------
(defvar *vertex-shader-program*
  (read-file-into-string "src/shaders/vertex.glsl"))

(defvar *fragment-shader-program*
  (read-file-into-string "src/shaders/fragment.glsl"))


(defmacro with-buffer ((buffer-handle) &body body)
  `(prog1
    (gl:bind-buffer :array-buffer ,buffer-handle)
    (progn ,@body)
    (gl:bind-buffer :array-buffer 0)))

(defmacro with-texture ((texture-handle) &body body)
  `(prog1
    (gl:bind-texture :texture-2d ,texture-handle)
    (progn ,@body)
    (gl:bind-texture :texture-2d 0)))

(defmacro with-vertex-array ((vertex-array-handle) &body body)
  `(prog1
    (gl:bind-vertex-array ,vertex-array-handle)
    (progn ,@body)
    (gl:bind-vertex-array 0)))


(defun initialize-texture (size)
  (let* ((handle (gl:gen-texture)))
    (with-texture (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) ; sharp pixels or gtfo
      (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
      (gl:enable :texture-2d))
    handle))

(defun initialize-buffer (data &key (gl-type :float))
  "Create and initialize an OpenGL buffer with `data` of type `gl-type`.

  Returns the GL handle to the buffer.

  "
  (let ((handle (elt (gl:gen-buffers 1) 0)))              ; create buffer
    (with-buffer (handle)                                 ; bind buffer
      (let ((array (gl:alloc-gl-array gl-type             ; create temp array
                                      (length data))))
        (dotimes (i (length data))                        ; fill array from the data
          (setf (gl:glaref array i) (aref data i)))
        (gl:buffer-data :array-buffer :static-draw array) ; copy array -> buffer
        (gl:free-gl-array array)))                        ; done with array

    handle))

(defun initialize-quad-buffers ()
  "Initialize index, position, and texture coordinate buffers for a quad."
  ;; 0--3
  ;; |\ |
  ;; |_\|
  ;; 1  2
  (let ((index-buffer (initialize-buffer #(0 2 1
                                           0 3 2)
                                         :gl-type :unsigned-short))
        (position-buffer (initialize-buffer #(0.0 0.0 0.0
                                              0.0 1.0 0.0
                                              1.0 1.0 0.0
                                              1.0 0.0 0.0)))
        (texcoord-buffer (initialize-buffer #(0.0 0.0 0.0
                                              0.0 0.5 0.0
                                              1.0 0.5 0.0
                                              1.0 0.0 0.0))))
    (values index-buffer position-buffer texcoord-buffer)))

(defun initialize-vertex-array (index-buffer data-buffer position
                                &key (gl-type :float))
  (let ((vertex-array (gl:gen-vertex-array)))
    (with-vertex-array (vertex-array)
      (gl:bind-buffer :array-buffer data-buffer)
      (gl:enable-vertex-attrib-array position)
      (gl:vertex-attrib-pointer 0 3 gl-type nil 0 (cffi:null-pointer))
      (gl:bind-buffer :element-array-buffer index-buffer))
    vertex-array))


(defun compile-shader (shader source)
  (gl:shader-source shader source)
  (gl:compile-shader shader))

(defun compile-shaders (&key
                        (vertex *vertex-shader-program*)
                        (fragment *fragment-shader-program*))
  "Compile the given shader sources into a shader program.

  Compilation errors will be printed.

  The result is suitable for giving to `gl:use-program`.

  "
  (let ((vertex-shader (gl:create-shader :vertex-shader))
        (fragment-shader (gl:create-shader :fragment-shader)))
    (compile-shader vertex-shader vertex)
    (compile-shader fragment-shader fragment)

    ;; Print any errors
    (format t "Vertex shader log:~%")
    (print (gl:get-shader-info-log vertex-shader))

    (format t "Fragment shader log:~%")
    (print (gl:get-shader-info-log fragment-shader))

    (let ((program (gl:create-program)))
      (gl:attach-shader program vertex-shader)
      (gl:attach-shader program fragment-shader)
      (gl:link-program program)
      (gl:use-program program)
      (values program vertex-shader fragment-shader))))


;;;; Screen -------------------------------------------------------------------
(define-widget screen (QGLWidget)
  ((debugger :accessor screen-debugger :initarg :debugger)
   (chip :accessor screen-chip :initarg :chip)
   (index-buffer :accessor screen-index-buffer)
   (position-buffer :accessor screen-position-buffer)
   (texcoord-buffer :accessor screen-texcoord-buffer)
   (position-array :accessor screen-position-array)
   (texcoord-array :accessor screen-texcoord-array)
   (fragment-shader :accessor screen-fragment-shader)
   (vertex-shader :accessor screen-vertex-shader)
   (shader-program :accessor screen-shader-program)
   (texture :accessor screen-texture)))


(defmethod construct ((screen screen))
  (let ((gl-format (q+:make-qglformat)))
    (setf (q+:version gl-format) (values 3 3)
          (q+:profile gl-format) (q+:qglformat.core-profile))
    (new screen gl-format)
    (let ((glcontext (q+:context screen)))
      (if (q+:is-valid glcontext)
        (format t "Successfully created context ~A.~%" glcontext)
        (format t "Failed to create context.~%")))))


(defun make-screen (chip)
  (make-instance 'screen
    :debugger (chip8.debugger::make-debugger chip)
    :chip chip))


(defun die (screen)
  (setf chip8::*running* 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-finalizer (screen teardown)
  (gl:delete-shader vertex-shader)
  (gl:delete-shader fragment-shader)
  (gl:delete-program shader-program)
  (gl:delete-buffers (list index-buffer
                           position-buffer
                           texcoord-buffer))
  (gl:delete-vertex-arrays (list position-array
                                 texcoord-array)))


(define-override (screen "initializeGL") ()
  (setf texture (initialize-texture 64))
  (multiple-value-bind (index position texcoord) (initialize-quad-buffers)
    (setf index-buffer index
          position-buffer position
          texcoord-buffer texcoord))
  (multiple-value-bind (program vertex fragment) (compile-shaders)
    (setf shader-program program
          vertex-shader vertex
          fragment-shader fragment))
  (setf position-array (initialize-vertex-array index-buffer position-buffer 0)
        texcoord-array (initialize-vertex-array index-buffer texcoord-buffer 1))
  (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::*running*
    (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:use-program (screen-shader-program screen))
  (gl:bind-vertex-array (screen-position-array screen))
  (gl:bind-vertex-array (screen-texcoord-array screen))

  #+no (with-texture (screen-texture screen)
    (let ((chip (screen-chip screen)))
      (when t ; (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*))))

  (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)))


(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
      (when 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_r)
         (-> chip chip8::reset))

        ((q+:qt.key_f7)
         (-> chip chip8::chip-debugger chip8::debugger-step))

        (t (pr "Unknown key pressed" (format nil "~X" key))))))
  (stop-overriding))


;;;; Main ---------------------------------------------------------------------
(defun run-gui (chip)
  (with-main-window
    (window (make-screen chip))))
	(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 -------------------------------------------------------------------
	(defvar vertex-shader-program
	(read-file-into-string "src/shaders/vertex.glsl"))

	(defvar fragment-shader-program
	(read-file-into-string "src/shaders/fragment.glsl"))


	(defmacro with-buffer ((buffer-handle) &body body)
	`(prog1
	(gl:bind-buffer :array-buffer ,buffer-handle)
	(progn ,@body)
	(gl:bind-buffer :array-buffer 0)))

	(defmacro with-texture ((texture-handle) &body body)
	`(prog1
	(gl:bind-texture :texture-2d ,texture-handle)
	(progn ,@body)
	(gl:bind-texture :texture-2d 0)))

	(defmacro with-vertex-array ((vertex-array-handle) &body body)
	`(prog1
	(gl:bind-vertex-array ,vertex-array-handle)
	(progn ,@body)
	(gl:bind-vertex-array 0)))


	(defun initialize-texture (size)
	(let* ((handle (gl:gen-texture)))
	(with-texture (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) ; sharp pixels or gtfo
	(gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
	(gl:enable :texture-2d))
	handle))

	(defun initialize-buffer (data &key (gl-type :float))
	"Create and initialize an OpenGL buffer with `data` of type `gl-type`.

	Returns the GL handle to the buffer.

	"
	(let ((handle (elt (gl:gen-buffers 1) 0))) ; create buffer
	(with-buffer (handle) ; bind buffer
	(let ((array (gl:alloc-gl-array gl-type ; create temp array
	(length data))))
	(dotimes (i (length data)) ; fill array from the data
	(setf (gl:glaref array i) (aref data i)))
	(gl:buffer-data :array-buffer :static-draw array) ; copy array -> buffer
	(gl:free-gl-array array))) ; done with array

	handle))

	(defun initialize-quad-buffers ()
	"Initialize index, position, and texture coordinate buffers for a quad."
	;; 0--3
	;; \|\ \|
	;; \|_\\|
	;; 1 2
	(let ((index-buffer (initialize-buffer #(0 2 1
	0 3 2)
	:gl-type :unsigned-short))
	(position-buffer (initialize-buffer #(0.0 0.0 0.0
	0.0 1.0 0.0
	1.0 1.0 0.0
	1.0 0.0 0.0)))
	(texcoord-buffer (initialize-buffer #(0.0 0.0 0.0
	0.0 0.5 0.0
	1.0 0.5 0.0
	1.0 0.0 0.0))))
	(values index-buffer position-buffer texcoord-buffer)))

	(defun initialize-vertex-array (index-buffer data-buffer position
	&key (gl-type :float))
	(let ((vertex-array (gl:gen-vertex-array)))
	(with-vertex-array (vertex-array)
	(gl:bind-buffer :array-buffer data-buffer)
	(gl:enable-vertex-attrib-array position)
	(gl:vertex-attrib-pointer 0 3 gl-type nil 0 (cffi:null-pointer))
	(gl:bind-buffer :element-array-buffer index-buffer))
	vertex-array))


	(defun compile-shader (shader source)
	(gl:shader-source shader source)
	(gl:compile-shader shader))

	(defun compile-shaders (&key
	(vertex vertex-shader-program)
	(fragment fragment-shader-program))
	"Compile the given shader sources into a shader program.

	Compilation errors will be printed.

	The result is suitable for giving to `gl:use-program`.

	"
	(let ((vertex-shader (gl:create-shader :vertex-shader))
	(fragment-shader (gl:create-shader :fragment-shader)))
	(compile-shader vertex-shader vertex)
	(compile-shader fragment-shader fragment)

	;; Print any errors
	(format t "Vertex shader log:~%")
	(print (gl:get-shader-info-log vertex-shader))

	(format t "Fragment shader log:~%")
	(print (gl:get-shader-info-log fragment-shader))

	(let ((program (gl:create-program)))
	(gl:attach-shader program vertex-shader)
	(gl:attach-shader program fragment-shader)
	(gl:link-program program)
	(gl:use-program program)
	(values program vertex-shader fragment-shader))))


	;;;; Screen -------------------------------------------------------------------
	(define-widget screen (QGLWidget)
	((debugger :accessor screen-debugger :initarg :debugger)
	(chip :accessor screen-chip :initarg :chip)
	(index-buffer :accessor screen-index-buffer)
	(position-buffer :accessor screen-position-buffer)
	(texcoord-buffer :accessor screen-texcoord-buffer)
	(position-array :accessor screen-position-array)
	(texcoord-array :accessor screen-texcoord-array)
	(fragment-shader :accessor screen-fragment-shader)
	(vertex-shader :accessor screen-vertex-shader)
	(shader-program :accessor screen-shader-program)
	(texture :accessor screen-texture)))


	(defmethod construct ((screen screen))
	(let ((gl-format (q+:make-qglformat)))
	(setf (q+:version gl-format) (values 3 3)
	(q+:profile gl-format) (q+:qglformat.core-profile))
	(new screen gl-format)
	(let ((glcontext (q+:context screen)))
	(if (q+:is-valid glcontext)
	(format t "Successfully created context ~A.~%" glcontext)
	(format t "Failed to create context.~%")))))


	(defun make-screen (chip)
	(make-instance 'screen
	:debugger (chip8.debugger::make-debugger chip)
	:chip chip))


	(defun die (screen)
	(setf chip8::running 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-finalizer (screen teardown)
	(gl:delete-shader vertex-shader)
	(gl:delete-shader fragment-shader)
	(gl:delete-program shader-program)
	(gl:delete-buffers (list index-buffer
	position-buffer
	texcoord-buffer))
	(gl:delete-vertex-arrays (list position-array
	texcoord-array)))


	(define-override (screen "initializeGL") ()
	(setf texture (initialize-texture 64))
	(multiple-value-bind (index position texcoord) (initialize-quad-buffers)
	(setf index-buffer index
	position-buffer position
	texcoord-buffer texcoord))
	(multiple-value-bind (program vertex fragment) (compile-shaders)
	(setf shader-program program
	vertex-shader vertex
	fragment-shader fragment))
	(setf position-array (initialize-vertex-array index-buffer position-buffer 0)
	texcoord-array (initialize-vertex-array index-buffer texcoord-buffer 1))
	(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::running
	(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:use-program (screen-shader-program screen))
	(gl:bind-vertex-array (screen-position-array screen))
	(gl:bind-vertex-array (screen-texcoord-array screen))

	#+no (with-texture (screen-texture screen)
	(let ((chip (screen-chip screen)))
	(when t ; (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))))

	(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)))


	(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
	(when 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_r)
	(-> chip chip8::reset))

	((q+:qt.key_f7)
	(-> chip chip8::chip-debugger chip8::debugger-step))

	(t (pr "Unknown key pressed" (format nil "~X" key))))))
	(stop-overriding))


	;;;; Main ---------------------------------------------------------------------
	(defun run-gui (chip)
	(with-main-window
	(window (make-screen chip))))