Permalink
Browse files

Clean up overall, rip out everything Qt*, make context backends switc…

…hable.

* The only Qt thing remaining is the image loading for the textures.
  Will replace that in due time.
  • Loading branch information...
Shinmera committed Jun 4, 2017
1 parent 2de89f8 commit 9aa61571362782fd4a0bfc1429d2497376b7e95e
Showing with 824 additions and 868 deletions.
  1. +1 −0 asset.lisp
  2. +91 −160 context.lisp
  3. +25 −51 display.lisp
  4. +0 −6 event-loop.lisp
  5. +11 −12 fullscreenable.lisp
  6. +235 −0 gamepad.lisp
  7. +0 −148 geometry.lisp
  8. +0 −72 helpers.lisp
  9. +0 −104 input.lisp
  10. +1 −1 { → launcher}/launcher.lisp
  11. +12 −0 launcher/package.lisp
  12. +22 −0 launcher/trial-launcher.asd
  13. +20 −43 main.lisp
  14. +111 −1 package.lisp
  15. +197 −0 qt/context.lisp
  16. +1 −167 { → qt}/input-tables.lisp
  17. +49 −0 qt/input.lisp
  18. +14 −0 qt/package.lisp
  19. +24 −0 qt/trial-qt.asd
  20. +5 −2 renderable.lisp
  21. +0 −70 sprite.lisp
  22. +0 −1 subjects.lisp
  23. +0 −21 toolkit.lisp
  24. +1 −3 trial.asd
  25. +4 −6 window.lisp
View
@@ -382,6 +382,7 @@
(check-texture-wrapping (second wrapping))
(check-texture-wrapping (third wrapping)))
;; FIXME: Figure out how to do this without Qt.
(defmethod coerce-input ((asset texture-asset) (file pathname))
(with-finalizing ((image (q+:make-qimage (uiop:native-namestring file))))
(when (q+:is-null image)
View
@@ -5,7 +5,6 @@
|#
(in-package #:org.shirakumo.fraf.trial)
(in-readtable :qtools)
(defvar *context* NIL)
@@ -24,167 +23,91 @@
(let ((*context* *context*))
,acquiring-body))))))
(define-widget context (QGLWidget)
((glformat :initform NIL :reader glformat)
(glcontext :initform NIL :reader glcontext)
(current-thread :initform NIL :accessor current-thread)
(defun launch-with-context (&optional main &rest initargs)
(apply #'make-instance main initargs))
(defun make-context (&optional handler)
(declare (ignore handler))
(error "No context implementation is present.~%~
Please load a Trial backend."))
(defclass context ()
((current-thread :initform NIL :accessor current-thread)
(waiting :initform 0 :accessor context-waiting)
(lock :initform (bt:make-lock "Context lock") :reader context-lock)
(wait-lock :initform (bt:make-lock "Context wait lock") :reader context-wait-lock)
(context-needs-recreation :initform NIL :accessor context-needs-recreation)
(assets :initform (make-hash-table :test 'eq) :accessor assets)))
(assets :initform (make-hash-table :test 'eq) :accessor assets)
(handler :initarg :handler :accessor handler))
(:default-initargs
:title "Trial"
:width 800
:height 600
:version '(3 3)
:profile :core
:double-buffering T
:accumulation-buffer NIL
:alpha-buffer T
:depth-buffer T
:stencil-buffer T
:stereo-buffer NIL
:handler NIL))
(defmethod print-object ((context context) stream)
(print-unreadable-object (context stream :type T :identity T)))
(defmethod construct ((context context))
(new context (glformat context))
(let ((glcontext (q+:context context)))
(if (q+:is-valid glcontext)
(v:info :trial.context "~a successfully created context." context)
(error "Failed to create context."))
(acquire-context context)
(context-note-debug-info context)))
(defmethod shared-initialize :after ((context context)
slots
&key (accumulation-buffer NIL)
(alpha-buffer T)
(depth-buffer T)
(stencil-buffer T)
(stereo-buffer NIL)
(direct-rendering T)
(double-buffering T)
(overlay NIL)
(plane 0)
(multisampling T)
(samples 1)
(swap-interval 0)
(profile :core)
(version '(3 3)))
(let ((initialized (glformat context)))
(unless initialized (setf (slot-value context 'glformat) (q+:make-qglformat)))
(macrolet ((format-set (value &optional (accessor value))
(let ((keyword (intern (string value) :keyword)))
`(cond ((eql :keep ,value))
((not initialized) (setf (,accessor context) ,value))
(T (setf (,accessor context) ,value))))))
(format-set accumulation-buffer)
(format-set alpha-buffer)
(format-set depth-buffer)
(format-set stencil-buffer)
(format-set stereo-buffer)
(format-set direct-rendering)
(format-set double-buffering)
(format-set overlay)
(format-set plane)
(format-set multisampling)
(format-set samples)
(format-set swap-interval)
(format-set version)
(format-set profile))))
(defmethod initialize-instance :after ((context context) &key)
(setf (context-needs-recreation context) NIL)
(setf (q+:updates-enabled context) NIL)
(setf (q+:auto-buffer-swap context) NIL)
(setf (q+:focus-policy context) (q+:qt.strong-focus))
(setf (q+:mouse-tracking context) T))
(defmethod reinitialize-instance :after ((context context) &key)
(when (context-needs-recreation context)
(with-context (context)
(destroy-context context)
(create-context context))))
(defmacro define-context-accessor (name reader &optional (writer reader))
`(progn (defmethod ,name ((context context))
(q+ ,reader (glformat context)))
(defmethod (setf ,name) (value (context context))
(setf (q+ ,writer (glformat context)) value)
(setf (context-needs-recreation context) T)
value)))
(define-context-accessor accumulation-buffer accum)
(define-context-accessor alpha-buffer alpha)
(define-context-accessor depth-buffer depth)
(define-context-accessor stencil-buffer stencil)
(define-context-accessor stereo-buffer stereo)
(define-context-accessor direct-rendering direct-rendering)
(define-context-accessor double-buffering double-buffer)
(define-context-accessor overlay has-overlay overlay)
(define-context-accessor plane plane)
(define-context-accessor multisampling sample-buffers)
(define-context-accessor samples samples)
(define-context-accessor swap-interval swap-interval)
(defmethod profile ((context context))
(qtenumcase (q+:profile (glformat context))
((q+:qglformat.no-profile) NIL)
((q+:qglformat.core-profile) :core)
((q+:qglformat.compatibility-profile) :compatibility)))
(defmethod (setf profile) (profile (context context))
(setf (q+:profile (glformat context))
(ecase profile
(NIL (q+:qglformat.no-profile))
(:core (q+:qglformat.core-profile))
(:compatibility (q+:qglformat.compatibility-profile))))
(setf (context-needs-recreation context) T)
profile)
(defmethod version ((context context))
(list (q+:major-version (glformat context))
(q+:minor-version (glformat context))))
(with-context (context)
(destroy-context context)
(create-context context)))
(defmethod (setf version) (version (context context))
(setf (q+:version (glformat context)) (values (first version) (second version)))
(setf (context-needs-recreation context) T)
version)
(defmethod initialize-instance :after ((context context) &key)
(release-context context))
(defgeneric create-context (context))
(defgeneric valid-p (context))
(defgeneric destroy-context (context))
(defgeneric make-current (context))
(defgeneric done-current (context))
(defgeneric hide (context))
(defgeneric show (context &key fullscreen))
(defgeneric resize (context width height))
(defgeneric swap-buffers (context))
(defgeneric show-cursor (context))
(defgeneric hide-cursor (context))
(defgeneric title (context))
(defgeneric (setf title) (value context))
(defgeneric width (context))
(defgeneric height (context))
(defgeneric profile (context))
(defgeneric version (context))
(defmethod finalize ((context context))
(destroy-context context)
(call-next-method)
(finalize (glformat context)))
(call-next-method))
(defmethod destroy-context :around ((context context))
(with-context (context)
(call-next-method)))
(defmethod destroy-context ((context context))
(when (q+:is-valid context)
(v:info :trial.context "Destroying context.")
(q+:hide context)
(hide context)
(clear-asset-cache)
(loop for asset being the hash-values of (assets context)
do (offload asset))
(q+:reset (q+:context context))))
(defmethod create-context :around ((context context))
(with-context (context)
(call-next-method)))
(defmethod create-context ((context context))
(unless (q+:is-valid context)
(if (q+:create (q+:context context))
(v:info :trial.context "Recreated context successfully.")
(error "Failed to recreate context. Game over."))
(q+:make-current context)
(context-note-debug-info context)
(setf (context-needs-recreation context) NIL)
(dolist (pool (pools))
(dolist (asset (assets pool))
(let ((resource (resource asset)))
(when resource
(setf (slot-value resource 'data) (load-data asset))))))
(q+:show context)))
(defmethod (setf parent) (parent (context context))
;; This is so annoying because Microsoft® Windows®™©
(defmethod create-context :around ((context context))
(with-context (context)
#+windows (destroy-context context)
(setf (q+:parent context) parent)
#+windows (create-context context)))
(unless (valid-p context)
(call-next-method)
(v:info :trial.context "Recreated context successfully.")
(make-current context)
(context-note-debug-info context)
(dolist (pool (pools))
(dolist (asset (assets pool))
(let ((resource (resource asset)))
(when resource
(setf (slot-value resource 'data) (load-data asset))))))
(show context))))
(defmethod acquire-context ((context context) &key force)
(let ((current (current-thread context))
@@ -201,12 +124,12 @@
(decf (context-waiting context))))
(T
(bt:acquire-lock (context-lock context))))
(unless (q+:is-valid context)
(unless (valid-p context)
(error "Attempting to acquire invalid context ~a" context))
(v:info :trial.context "~a acquiring ~a." this context)
(setf (current-thread context) this)
(setf *context* context)
(q+:make-current context))))
(make-current context))))
(defmethod release-context ((context context) &key reentrant)
(let ((current (current-thread context))
@@ -216,17 +139,25 @@
(cond ((eql *context* context)
(v:info :trial.context "~a releasing ~a." this context)
(setf (current-thread context) NIL)
(when (q+:is-valid context)
(q+:done-current context))
(when (valid-p context)
(done-current context))
(bt:release-lock (context-lock context))
(setf *context* NIL))
(T
(v:warn :trial.context "~a attempted to release ~a even through ~a is active."
this context *context*))))))
(defclass resize (event)
((width :initarg :width :reader width)
(height :initarg :height :reader height)))
(defmethod describe-object :after ((context context) stream)
(context-info context stream))
(defun gl-property (name)
(handler-case (gl:get* name)
(error (err) :unavailable)))
(defun context-info (context stream)
(format stream "~&~%Running GL~a.~a ~a~%~
Sample buffers: ~a (~a sample~:p)~%~
@@ -237,23 +168,23 @@
GL Version: ~a~%~
GL Shader Language: ~a~%~
GL Extensions: ~{~a~^ ~}~%"
(ignore-errors (gl:get* :major-version))
(ignore-errors (gl:get* :minor-version))
(ignore-errors (profile context))
(ignore-errors (gl:get* :sample-buffers))
(ignore-errors (gl:get* :samples))
(ignore-errors (gl:get* :max-texture-size))
(ignore-errors (gl:get* :max-vertex-texture-image-units))
(gl-property :major-version)
(gl-property :minor-version)
(profile context)
(gl-property :sample-buffers)
(gl-property :samples)
(gl-property :max-texture-size)
(gl-property :max-vertex-texture-image-units)
;; Fuck you, GL, and your stupid legacy crap.
(ignore-errors (gl:get* :max-texture-image-units))
(ignore-errors (gl:get* :max-tess-control-texture-image-units))
(ignore-errors (gl:get* :max-tess-evaluation-texture-image-units))
(ignore-errors (gl:get* :max-geometry-texture-image-units))
(ignore-errors (gl:get* :max-compute-texture-image-units))
(ignore-errors (gl:get-string :vendor))
(ignore-errors (gl:get-string :renderer))
(ignore-errors (gl:get-string :version))
(ignore-errors (gl:get-string :shading-language-version))
(gl-property :max-texture-image-units)
(gl-property :max-tess-control-texture-image-units)
(gl-property :max-tess-evaluation-texture-image-units)
(gl-property :max-geometry-texture-image-units)
(gl-property :max-compute-texture-image-units)
(gl-property :vendor)
(gl-property :renderer)
(gl-property :version)
(gl-property :shading-language-version)
(ignore-errors
(loop for i from 0 below (gl:get* :num-extensions)
collect (gl:get-string-i :extensions i)))))
Oops, something went wrong.

0 comments on commit 9aa6157

Please sign in to comment.