Start porting the graphics to use VAOs/shaders
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Mon, 21 Nov 2016 16:58:27 +0000 |
| parents |
8b67739b3eb8 |
| children |
(none) |
(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)))
(define-widget unfucked-context (QGLContext)
())
(define-override (unfucked-context choose-mac-visual) (handle)
(pr "Visual")
(stop-overriding))
(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)
(q+:sample-buffers gl-format) t)
(new screen (new unfucked-context gl-format))
(pr (q+:major-version (q+:format screen)))
(pr (q+:minor-version (q+:format screen)))
(break)
(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))))