From 89ef7699b3b47fdfe5a10d19bff7f43683690cee Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 11 Feb 2024 14:15:20 +0100 Subject: [PATCH 1/9] Move field definitions out of env --- src/drawing.lisp | 18 ++++++++ src/environment.lisp | 108 +++++++++++++++++-------------------------- src/figures.lisp | 2 +- src/font.lisp | 4 +- src/pen.lisp | 33 ++++++------- src/resources.lisp | 4 +- src/shaders.lisp | 5 ++ src/sketch.lisp | 37 +++++++++++++-- src/transforms.lisp | 4 ++ 9 files changed, 124 insertions(+), 91 deletions(-) diff --git a/src/drawing.lisp b/src/drawing.lisp index 7c66a66..67083e7 100644 --- a/src/drawing.lisp +++ b/src/drawing.lisp @@ -11,6 +11,19 @@ ;;; http://onrendering.blogspot.com/2011/10/buffer-object-streaming-in-opengl.html ;;; http://www.java-gaming.org/index.php?topic=32169.0 +(add-to-environment :buffer-position 0) +(add-to-environment :vao (make-instance 'kit.gl.vao:vao :type 'sketch-vao)) +(add-to-environment :white-pixel-texture (make-white-pixel-texture)) +(add-to-environment :white-color-vector #(255 255 255 255)) + +(defun make-white-pixel-texture () + "Sent to shaders when no image is active." + (let ((texture (car (gl:gen-textures 1)))) + (gl:bind-texture :texture-2d texture) + (gl:tex-parameter :texture-2d :texture-min-filter :linear) + (gl:tex-image-2d :texture-2d 0 :rgba 1 1 0 :bgra :unsigned-byte #(255 255 255 255)) + texture)) + (kit.gl.vao:defvao sketch-vao () (:interleave () (vertex :float 2) @@ -33,6 +46,11 @@ `(let ((*uv-rect* ,rect)) ,@body)) +(defun background (color) + "Fills the sketch window with COLOR." + (apply #'gl:clear-color (color-rgba color)) + (gl:clear :color-buffer)) + (defun start-draw () (%gl:bind-buffer :array-buffer (aref (slot-value (env-vao *env*) 'kit.gl.vao::vbos) 0)) (%gl:buffer-data :array-buffer *buffer-size* (cffi:null-pointer) :stream-draw) diff --git a/src/environment.lisp b/src/environment.lisp index 6a2ef22..a01ee30 100644 --- a/src/environment.lisp +++ b/src/environment.lisp @@ -7,74 +7,52 @@ ;;; | _| | \| |\ \ / / | || |_) | | | | \| | |\/| | _| | \| | | | ;;; | |___| |\ | \ V / | || _ <| |_| | |\ | | | | |___| |\ | | | ;;; |_____|_| \_| \_/ |___|_| \_\\___/|_| \_|_| |_|_____|_| \_| |_| - -(defstruct env - ;; Drawing - (pen nil) - (programs nil) - (model-matrix (sb-cga:identity-matrix)) ; TODO: sb-cga shouldn't be used directly from here - (view-matrix nil) - (matrix-stack nil) - (y-axis-sgn +1) - (vao nil) - (buffer-position 0) - ;; Typography - (font nil) - ;; Textures - (white-pixel-texture nil) - (white-color-vector nil) - ;; Resources - (resources (make-hash-table)) - ;; Debugging - (debug-key-pressed nil) - (red-screen nil)) +;;; +;;; ENVIRONMENT is a contextual store of sketch properties, such as PENs and FONTs. +;;; TODO: Say more. + +(defparameter *environment-initializers* (make-hash-table :size 255)) + +(defun add-environment-initializer (name value) + (setf (gethash name *environment-initializers*) value)) + +(defclass environment () + ((%properties :initform (make-hash-table :size 255) :accessor environment-%properties))) + +(defmethod set-environment-property ((environment environment) property value) + (setf (gethash property (environment-%properties environment)) value)) + +(defmethod get-environment-property ((environment environment) property) + (gethash property (environment-%properties environment))) + +(defun make-env () + (let ((env (make-instance 'environment))) + (loop for property being the hash-key + using (hash-value initializer) of *environment-initializers* + do (set-environment-property env property (funcall initializer))) + env)) + +;;; TODO: Remove. Temporary, for the backend refactor. +(defun make-fake-env () + (let ((env (make-instance 'environment))) + (loop for property being the hash-key of *environment-initializers* + do (set-environment-property env property nil)) + env)) + +(defmacro add-to-environment (name &body initializer) + (let ((fname (alexandria:symbolicate 'env- name)) + (setter-fname (alexandria:symbolicate 'set-env- name) ;(alexandria:make-gensym name) + )) + `(eval-when (:load-toplevel) + (add-environment-initializer ,name (lambda () ,@initializer)) + (defun ,fname (environment) + (get-environment-property environment ,name)) + (defun ,setter-fname (environment value) + (set-environment-property environment ,name value)) + (defsetf ,fname ,setter-fname)))) (defparameter *env* nil) -(defun make-white-pixel-texture () - "Sent to shaders when no image is active." - (let ((texture (car (gl:gen-textures 1)))) - (gl:bind-texture :texture-2d texture) - (gl:tex-parameter :texture-2d :texture-min-filter :linear) - (gl:tex-image-2d :texture-2d 0 :rgba 1 1 0 :bgra :unsigned-byte #(255 255 255 255)) - texture)) - -(defun initialize-environment (sketch) - (with-slots ((env %env) width height y-axis) sketch - (setf (env-programs env) (kit.gl.shader:compile-shader-dictionary 'sketch-programs) - (env-vao env) (make-instance 'kit.gl.vao:vao :type 'sketch-vao) - (env-white-pixel-texture env) (make-white-pixel-texture) - (env-white-color-vector env) #(255 255 255 255) - (env-pen env) (make-default-pen) - (env-font env) (make-default-font)) - (initialize-view-matrix sketch) - (kit.gl.shader:use-program (env-programs env) :fill-shader))) - -(defun initialize-view-matrix (sketch) - (with-slots ((env %env) width height y-axis %viewport-changed) sketch - (setf (env-view-matrix env) (if (eq y-axis :down) - (kit.glm:ortho-matrix 0 width height 0 -1 1) - (kit.glm:ortho-matrix 0 width 0 height -1 1)) - (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) - %viewport-changed t))) - -(defun initialize-gl (sketch) - (with-slots ((w %window)) sketch - (handler-case (sdl2:gl-set-swap-interval 1) - ;; Some OpenGL drivers do not allow to control swapping. - ;; In this case SDL2 sets an error that needs to be cleared. - (sdl2::sdl-rc-error (e) - (warn "VSYNC was not enabled; frame rate was not restricted to 60fps.~% ~A" e) - (sdl2-ffi.functions:sdl-clear-error))) - (setf (kit.sdl2:idle-render w) t) - (gl:enable :blend :line-smooth :polygon-smooth) - (gl:blend-func :src-alpha :one-minus-src-alpha) - (gl:hint :line-smooth-hint :nicest) - (gl:hint :polygon-smooth-hint :nicest) - (gl:clear-color 0.0 0.0 0.0 1.0) - (gl:clear :color-buffer :depth-buffer) - (gl:flush))) - (defmacro with-environment (env &body body) `(let ((*env* ,env)) ,@body)) diff --git a/src/figures.lisp b/src/figures.lisp index 5145731..96f2518 100644 --- a/src/figures.lisp +++ b/src/figures.lisp @@ -41,7 +41,7 @@ h nil body (cons opt body))) `(let ((*draw-sequence* nil)) - (let ((*env* (make-env)) + (let ((*env* (make-fake-env)) (*draw-mode* :figure)) (with-pen (make-default-pen) ,@body)) diff --git a/src/font.lisp b/src/font.lisp index 2be834b..3b36f89 100644 --- a/src/font.lisp +++ b/src/font.lisp @@ -8,6 +8,8 @@ ;;; | _|| |_| | |\ | | | ;;; |_| \___/|_| \_| |_| +(add-to-environment :font (make-default-font)) + (defclass font (resource) ((face :accessor font-face :initarg :face) (color :accessor font-color :initarg :color) @@ -16,7 +18,7 @@ (align :accessor font-align :initarg :align :initform :left))) (defun make-font (&key face color size line-height align) - (let* ((*env* (or *env* (make-env)))) + (let* ((*env* (or *env* (make-fake-env)))) (make-instance 'font :face (or face (font-face (or (env-font *env*) diff --git a/src/pen.lisp b/src/pen.lisp index 883b958..ecdd2a3 100644 --- a/src/pen.lisp +++ b/src/pen.lisp @@ -8,6 +8,8 @@ ;;; | __/| |___| |\ | ;;; |_| |_____|_| \_| +(add-to-environment :pen (make-default-pen)) + (defstruct pen (fill nil) (stroke nil) @@ -16,17 +18,11 @@ (winding-rule :nonzero :type (member :odd :nonzero :positive :negative :abs-geq-two))) -(defmacro with-pen (pen &body body) - (with-shorthand (pen make-pen) - (alexandria:with-gensyms (previous-pen) - `(let ((,previous-pen (env-pen *env*))) - (unwind-protect (progn - (setf (env-pen *env*) ,pen) - ,@body) - (setf (env-pen *env*) ,previous-pen)))))) +(let ((pen)) + (defun make-default-pen () + (setf pen (or pen (make-pen :weight 1 :fill +white+ :stroke +black+))))) (defun set-pen (pen) - "Sets environment pen to PEN." (setf (env-pen *env*) pen)) (defun flip-pen (pen) @@ -38,14 +34,11 @@ :curve-steps (pen-curve-steps pen) :winding-rule (pen-winding-rule pen))) -(defun background (color) - "Fills the sketch window with COLOR." - (apply #'gl:clear-color (color-rgba color)) - (gl:clear :color-buffer)) - -(let ((pen)) - (defun make-default-pen () - (setf pen (or pen - (make-pen :weight 1 - :fill +white+ - :stroke +black+))))) +(defmacro with-pen (pen &body body) + (with-shorthand (pen make-pen) + (alexandria:with-gensyms (previous-pen) + `(let ((,previous-pen (env-pen *env*))) + (unwind-protect (progn + (setf (env-pen *env*) ,pen) + ,@body) + (setf (env-pen *env*) ,previous-pen)))))) diff --git a/src/resources.lisp b/src/resources.lisp index 2796605..465f6aa 100644 --- a/src/resources.lisp +++ b/src/resources.lisp @@ -8,6 +8,8 @@ ;;; | _ <| |___ ___) | |_| | |_| | _ <| |___| |___ ___) | ;;; |_| \_\_____|____/ \___/ \___/|_| \_\\____|_____|____/ +(add-to-environment :resources (make-hash-table)) + ;;; Classes (defclass resource () ()) @@ -55,7 +57,7 @@ (subseq name (1+ pos))))) (defun load-resource (filename &rest all-keys &key type force-reload-p &allow-other-keys) - (let ((*env* (or *env* (make-env)))) ;; try faking env if we still don't have one + (let ((*env* (or *env* (make-fake-env)))) ;; try faking env if we still don't have one (symbol-macrolet ((resource (gethash key (env-resources *env*)))) (alexandria:remove-from-plistf all-keys :force-reload-p) (let* ((key (alexandria:make-keyword diff --git a/src/shaders.lisp b/src/shaders.lisp index 83fefee..ce35b0b 100644 --- a/src/shaders.lisp +++ b/src/shaders.lisp @@ -8,6 +8,11 @@ ;;; ___) | _ |/ ___ \| |_| | |___| _ < ___) | ;;; |____/|_| |_/_/ \_\____/|_____|_| \_\____/ +(add-to-environment :programs ; TODO: should probably be PROGRAM - this is for compat + (let ((programs (kit.gl.shader:compile-shader-dictionary 'sketch-programs))) + (kit.gl.shader:use-program programs :fill-shader) + programs)) + (kit.gl.shader:defdict sketch-programs () (kit.gl.shader:program :fill-shader (:view-m :model-m :texid) (:vertex-shader " diff --git a/src/sketch.lisp b/src/sketch.lisp index da10b4d..583f22b 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -16,7 +16,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Sketch class +(add-to-environment :debug-key-pressed nil) +(add-to-environment :red-screen nil) +(add-to-environment :y-axis-sgn +1) + + ;;; Sketch class (defparameter *sketch* nil "The current sketch instance.") @@ -27,7 +31,7 @@ "The default height of sketch window") (defclass sketch () - ((%env :initform (make-env) :reader sketch-%env) + ((%env :initform nil :reader sketch-%env) (%setup-called :initform nil :accessor sketch-%setup-called) (%viewport-changed :initform t) (%entities :initform (make-hash-table) :accessor sketch-%entities) @@ -138,7 +142,8 @@ :fullscreen (sketch-fullscreen instance) :resizable (sketch-resizable instance) :sketch instance)) - (initialize-environment instance) + (setf (slot-value instance '%env) (make-env)) + (initialize-view-matrix instance) (initialize-gl instance) ;; These will have been added in the call to PREPARE. (with-slots ((fs %delayed-init-funs)) instance @@ -146,6 +151,23 @@ do (funcall f)) (setf fs (make-array 0 :adjustable t :fill-pointer t)))) +(defun initialize-gl (sketch) + (with-slots ((w %window)) sketch + (handler-case (sdl2:gl-set-swap-interval 1) + ;; Some OpenGL drivers do not allow to control swapping. + ;; In this case SDL2 sets an error that needs to be cleared. + (sdl2::sdl-rc-error (e) + (warn "VSYNC was not enabled; frame rate was not restricted to 60fps.~% ~A" e) + (sdl2-ffi.functions:sdl-clear-error))) + (setf (kit.sdl2:idle-render w) t) + (gl:enable :blend :line-smooth :polygon-smooth) + (gl:blend-func :src-alpha :one-minus-src-alpha) + (gl:hint :line-smooth-hint :nicest) + (gl:hint :polygon-smooth-hint :nicest) + (gl:clear-color 0.0 0.0 0.0 1.0) + (gl:clear :color-buffer :depth-buffer) + (gl:flush))) + (defmethod update-instance-for-redefined-class :after ((instance sketch) added-slots discarded-slots property-list &rest initargs) (declare (ignore added-slots discarded-slots property-list)) @@ -239,6 +261,15 @@ (defmethod kit.sdl2:render ((instance sketch)) (kit.sdl2:render (sketch-%window instance))) +;;; TODO: Would be great to move it to transforms. +(defun initialize-view-matrix (sketch) + (with-slots ((env %env) width height y-axis %viewport-changed) sketch + (setf (env-view-matrix env) (if (eq y-axis :down) + (kit.glm:ortho-matrix 0 width height 0 -1 1) + (kit.glm:ortho-matrix 0 width 0 height -1 1)) + (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) + %viewport-changed t))) + ;;; Support for resizable windows (defmethod kit.sdl2:window-event :before ((instance sketch-window) (type (eql :size-changed)) timestamp data1 data2) diff --git a/src/transforms.lisp b/src/transforms.lisp index 22da5b5..e740aa0 100644 --- a/src/transforms.lisp +++ b/src/transforms.lisp @@ -8,6 +8,10 @@ ;;; | | | _ < / ___ \| |\ |___) | _|| |_| | _ <| | | |___) | ;;; |_| |_| \_\/_/ \_\_| \_|____/|_| \___/|_| \_\_| |_|____/ +(add-to-environment :model-matrix (sb-cga:identity-matrix)) +(add-to-environment :view-matrix nil) +(add-to-environment :matrix-stack nil) + (defun set-matrix (matrix) (setf (env-model-matrix *env*) matrix)) From 623956887d79cd06320931b4d4e579499d1d8e1d Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 11 Feb 2024 14:43:20 +0100 Subject: [PATCH 2/9] Move surface-format from utils to resources --- src/resources.lisp | 4 ++++ src/utils.lisp | 4 ---- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/resources.lisp b/src/resources.lisp index 465f6aa..880752a 100644 --- a/src/resources.lisp +++ b/src/resources.lisp @@ -155,6 +155,10 @@ dst-surface) surface)) +(defun surface-format (surface) + (plus-c:c-let ((surface sdl2-ffi:sdl-surface :from surface)) + (surface :format :format))) + (defmethod load-typed-resource (filename (type (eql :typeface)) &key (size 18) &allow-other-keys) (make-instance 'typeface diff --git a/src/utils.lisp b/src/utils.lisp index 1a72fdb..6e3d7e7 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -94,10 +94,6 @@ but may be considered unique for all practical purposes." path (format nil "~a" (asdf:system-relative-pathname system path)))) -(defun surface-format (surface) - (plus-c:c-let ((surface sdl2-ffi:sdl-surface :from surface)) - (surface :format :format))) - (defmacro with-shorthand ((var maker) &body body) `(let ((,var (if (and (listp ,var) (keywordp (car ,var))) (cons ',maker ,var) From e04be633f18fe8e2495975e2606df9933cfcb554 Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 11 Feb 2024 14:52:25 +0100 Subject: [PATCH 3/9] Reorder system components --- sketch.asd | 11 +-- src/complex-transforms.lisp | 37 --------- src/drawing.lisp | 22 ++++++ src/image.lisp | 22 ------ src/resource-loading.lisp | 144 ++++++++++++++++++++++++++++++++++++ src/resources.lisp | 131 -------------------------------- src/transforms.lisp | 34 +++++++++ 7 files changed, 206 insertions(+), 195 deletions(-) delete mode 100644 src/complex-transforms.lisp create mode 100644 src/resource-loading.lisp diff --git a/sketch.asd b/sketch.asd index 970405a..f79a950 100644 --- a/sketch.asd +++ b/sketch.asd @@ -28,18 +28,19 @@ (:file "resources") (:file "color") (:file "channels") - (:file "shaders") (:file "pen") - (:file "font") (:file "geometry") (:file "image") (:file "shapes") (:file "transforms") - (:file "complex-transforms") - (:file "drawing") (:file "bindings") + ;; Backend-dependent + (:file "resource-loading") + (:file "font") + (:file "shaders") + (:file "drawing") (:file "sketch") - (:file "entities") + (:file "entities") ; depends on sketch (:file "figures") (:file "controllers") (:file "canvas"))) diff --git a/src/complex-transforms.lisp b/src/complex-transforms.lisp deleted file mode 100644 index e13b1cc..0000000 --- a/src/complex-transforms.lisp +++ /dev/null @@ -1,37 +0,0 @@ -;;;; complex-transforms.lisp - -(in-package #:sketch) - -;;; FIT, WITH-FIT -;;; Modes were taken from GTK, see https://docs.gtk.org/gtk4/enum.ContentFit.html -(defun fit (to-width to-height from-width from-height &key (mode :contain)) - (check-type mode (member :contain :cover :scale-down :fill)) - (ecase mode - ((:contain :cover :scale-down) - (flet ((%fit-scale (scale) - (let ((x-shift (/ (- from-width - (* to-width scale)) - 2)) - (y-shift (/ (- from-height - (* to-height scale)) - 2))) - (translate x-shift y-shift) - (scale scale)))) - (%fit-scale - (ecase mode - (:contain (min (/ from-width to-width) - (/ from-height to-height))) - (:cover (max (/ from-width to-width) - (/ from-height to-height))) - (:scale-down (min (/ from-width to-width) - (/ from-height to-height) - 1)))))) - (:fill - (scale (/ from-width to-width) - (/ from-height to-height))))) - -(defmacro with-fit ((to-width to-height from-width from-height &key (mode :contain)) - &body body) - `(with-current-matrix - (fit ,to-width ,to-height ,from-width ,from-height :mode ,mode) - ,@body)) diff --git a/src/drawing.lisp b/src/drawing.lisp index 67083e7..d91d844 100644 --- a/src/drawing.lisp +++ b/src/drawing.lisp @@ -148,3 +148,25 @@ (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 1)) (aref color 1) (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 2)) (aref color 2) (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 3)) (aref color 3)))) + +(defun save-png (pathname) + (let ((width (sketch-width *sketch*)) + (height (sketch-height *sketch*))) + (flet ((ptr (vec offset) + (static-vectors:static-vector-pointer vec :offset offset)) + (from (row col width) + (+ col (* row (* 4 width)))) + (to (row col width height) + (+ col (* (- height row 1) 4 width)))) + (static-vectors:with-static-vector (buffer (* 4 width height)) + (%gl:read-pixels 0 0 width height :rgba :unsigned-byte (ptr buffer 0)) + (dotimes (row (truncate height 2)) + (dotimes (col (* 4 width)) + (rotatef (cffi:mem-aref (ptr buffer (from row col width)) :uint8) + (cffi:mem-aref (ptr buffer (to row col width height)) :uint8)))) + (let ((png (make-instance 'zpng:png + :width width + :height height + :color-type :truecolor-alpha + :image-data buffer))) + (zpng:write-png png pathname)))))) diff --git a/src/image.lisp b/src/image.lisp index 539f5ba..1a5bb63 100644 --- a/src/image.lisp +++ b/src/image.lisp @@ -27,25 +27,3 @@ are set to the width & height of the image if not provided." of the image is drawn to the rect of X,Y,W,H, which are all in pixel values, and X & Y are relative to the image." (cropped-image-from-image image-resource x y w h)) - -(defun save-png (pathname) - (let ((width (sketch-width *sketch*)) - (height (sketch-height *sketch*))) - (flet ((ptr (vec offset) - (static-vectors:static-vector-pointer vec :offset offset)) - (from (row col width) - (+ col (* row (* 4 width)))) - (to (row col width height) - (+ col (* (- height row 1) 4 width)))) - (static-vectors:with-static-vector (buffer (* 4 width height)) - (%gl:read-pixels 0 0 width height :rgba :unsigned-byte (ptr buffer 0)) - (dotimes (row (truncate height 2)) - (dotimes (col (* 4 width)) - (rotatef (cffi:mem-aref (ptr buffer (from row col width)) :uint8) - (cffi:mem-aref (ptr buffer (to row col width height)) :uint8)))) - (let ((png (make-instance 'zpng:png - :width width - :height height - :color-type :truecolor-alpha - :image-data buffer))) - (zpng:write-png png pathname)))))) diff --git a/src/resource-loading.lisp b/src/resource-loading.lisp new file mode 100644 index 0000000..e6d5686 --- /dev/null +++ b/src/resource-loading.lisp @@ -0,0 +1,144 @@ +;;;; resources.lisp + +(in-package #:sketch) + +;;; ____ _____ ____ ___ _ _ ____ ____ _____ +;;; | _ \| ____/ ___| / _ \| | | | _ \ / ___| ____| +;;; | |_) | _| \___ \| | | | | | | |_) | | | _| +;;; | _ <| |___ ___) | |_| | |_| | _ <| |___| |___ +;;; |_| \_\_____|____/ \___/ \___/|_| \_\\____|_____| +;;; +;;; _ ___ _ ____ ___ _ _ ____ +;;; | | / _ \ / \ | _ \_ _| \ | |/ ___| +;;; | | | | | |/ _ \ | | | | || \| | | _ +;;; | |__| |_| / ___ \| |_| | || |\ | |_| | +;;; |_____\___/_/ \_\____/___|_| \_|\____| + +(defun file-name-extension (name) + ;; taken from dto's xelf code + (let ((pos (position #\. name :from-end t))) + (when (numberp pos) + (subseq name (1+ pos))))) + +(defun load-resource (filename &rest all-keys &key type force-reload-p &allow-other-keys) + (let ((*env* (or *env* (make-fake-env)))) ;; try faking env if we still don't have one + (symbol-macrolet ((resource (gethash key (env-resources *env*)))) + (alexandria:remove-from-plistf all-keys :force-reload-p) + (let* ((key (alexandria:make-keyword + (alexandria:symbolicate filename (format nil "~a" all-keys))))) + (when force-reload-p + (free-resource resource) + (remhash key (env-resources *env*))) + (when (not resource) + (setf resource + (apply #'load-typed-resource + (list* filename + (or type + (case (alexandria:make-keyword + (alexandria:symbolicate + (string-upcase (file-name-extension filename)))) + ((:png :jpg :jpeg :tga :gif :bmp) :image) + ((:ttf :otf) :typeface))) + all-keys)))) + resource)))) + +(defgeneric load-typed-resource (filename type &key &allow-other-keys)) + +(defmethod load-typed-resource (filename type &key &allow-other-keys) + (if (not type) + (error (format nil "~a's type cannot be deduced." filename)) + (error (format nil "Unsupported resource type ~a" type)))) + +(defun make-image-from-surface (surface &key (free-surface t) + (min-filter :linear) + (mag-filter :linear)) + (let ((image (make-instance 'image + :width (sdl2:surface-width surface) + :height (sdl2:surface-height surface) + :texture nil))) + (init-image-texture! image + surface + :free-surface free-surface + :min-filter min-filter + :mag-filter mag-filter) + image)) + +(defmethod load-typed-resource (filename (type (eql :image)) + &key (min-filter :linear) + (mag-filter :linear) + (x nil) + (y nil) + (w nil) + (h nil) + &allow-other-keys) + (make-image-from-surface + (cut-surface (sdl2-image:load-image filename) x y w h) + :min-filter min-filter + :mag-filter mag-filter)) + +(defun init-image-texture! (image surface &key (free-surface t) + (min-filter :linear) + (mag-filter :linear)) + (flet ((init () + (let ((texture (car (gl:gen-textures 1))) + (rgba-surface + (if (eq (sdl2:surface-format-format surface) sdl2:+pixelformat-rgba32+) + surface + (sdl2:convert-surface-format surface sdl2:+pixelformat-rgba32+)))) + (gl:bind-texture :texture-2d texture) + (gl:tex-parameter :texture-2d :texture-min-filter min-filter) + (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) + (gl:pixel-store :unpack-row-length (/ (sdl2:surface-pitch rgba-surface) 4)) + (gl:tex-image-2d :texture-2d 0 :rgba + (sdl2:surface-width rgba-surface) + (sdl2:surface-height rgba-surface) + 0 + :rgba + :unsigned-byte (sdl2:surface-pixels rgba-surface)) + (gl:bind-texture :texture-2d 0) + (unless (eq rgba-surface surface) (sdl2:free-surface rgba-surface)) + (when free-surface + (when (eq free-surface :font) + (tg:cancel-finalization surface)) + (sdl2:free-surface surface)) + (setf (image-texture image) texture)))) + (if (delay-init-p) + (add-delayed-init-fun! #'init) + (init)))) + +(defun cut-surface (surface x y w h) + (if (and x y w h) + (let ((src-rect (sdl2:make-rect x y w h)) + (dst-rect (sdl2:make-rect 0 0 w h)) + (dst-surface (sdl2-ffi.functions:sdl-create-rgb-surface-with-format + 0 w h 32 + (surface-format surface)))) + (sdl2-ffi.functions:sdl-set-surface-blend-mode surface sdl2-ffi:+sdl-blendmode-none+) + (sdl2:blit-surface surface src-rect dst-surface dst-rect) + (sdl2:free-surface surface) + dst-surface) + surface)) + +(defun surface-format (surface) + (plus-c:c-let ((surface sdl2-ffi:sdl-surface :from surface)) + (surface :format :format))) + +(defmethod load-typed-resource (filename (type (eql :typeface)) + &key (size 18) &allow-other-keys) + (make-instance 'typeface + :filename filename + :pointer (sdl2-ttf:open-font filename + (coerce (truncate size) + '(signed-byte 32))))) + +(defgeneric free-resource (resource)) + +(defmethod free-resource ((resource (eql nil)))) + +(defmethod free-resource ((image image)) + (gl:delete-textures (list (image-texture image)))) + +(defmethod free-resource ((typeface typeface)) + (let ((pointer (typeface-pointer typeface))) + (setf (typeface-pointer typeface) nil) + (sdl2-ttf:close-font pointer))) diff --git a/src/resources.lisp b/src/resources.lisp index 880752a..d04880c 100644 --- a/src/resources.lisp +++ b/src/resources.lisp @@ -47,134 +47,3 @@ (defclass typeface (resource) ((filename :accessor typeface-filename :initarg :filename) (pointer :accessor typeface-pointer :initarg :pointer))) - -;;; Loading - -(defun file-name-extension (name) - ;; taken from dto's xelf code - (let ((pos (position #\. name :from-end t))) - (when (numberp pos) - (subseq name (1+ pos))))) - -(defun load-resource (filename &rest all-keys &key type force-reload-p &allow-other-keys) - (let ((*env* (or *env* (make-fake-env)))) ;; try faking env if we still don't have one - (symbol-macrolet ((resource (gethash key (env-resources *env*)))) - (alexandria:remove-from-plistf all-keys :force-reload-p) - (let* ((key (alexandria:make-keyword - (alexandria:symbolicate filename (format nil "~a" all-keys))))) - (when force-reload-p - (free-resource resource) - (remhash key (env-resources *env*))) - (when (not resource) - (setf resource - (apply #'load-typed-resource - (list* filename - (or type - (case (alexandria:make-keyword - (alexandria:symbolicate - (string-upcase (file-name-extension filename)))) - ((:png :jpg :jpeg :tga :gif :bmp) :image) - ((:ttf :otf) :typeface))) - all-keys)))) - resource)))) - -(defgeneric load-typed-resource (filename type &key &allow-other-keys)) - -(defmethod load-typed-resource (filename type &key &allow-other-keys) - (if (not type) - (error (format nil "~a's type cannot be deduced." filename)) - (error (format nil "Unsupported resource type ~a" type)))) - -(defun make-image-from-surface (surface &key (free-surface t) - (min-filter :linear) - (mag-filter :linear)) - (let ((image (make-instance 'image - :width (sdl2:surface-width surface) - :height (sdl2:surface-height surface) - :texture nil))) - (init-image-texture! image - surface - :free-surface free-surface - :min-filter min-filter - :mag-filter mag-filter) - image)) - -(defmethod load-typed-resource (filename (type (eql :image)) - &key (min-filter :linear) - (mag-filter :linear) - (x nil) - (y nil) - (w nil) - (h nil) - &allow-other-keys) - (make-image-from-surface - (cut-surface (sdl2-image:load-image filename) x y w h) - :min-filter min-filter - :mag-filter mag-filter)) - -(defun init-image-texture! (image surface &key (free-surface t) - (min-filter :linear) - (mag-filter :linear)) - (flet ((init () - (let ((texture (car (gl:gen-textures 1))) - (rgba-surface - (if (eq (sdl2:surface-format-format surface) sdl2:+pixelformat-rgba32+) - surface - (sdl2:convert-surface-format surface sdl2:+pixelformat-rgba32+)))) - (gl:bind-texture :texture-2d texture) - (gl:tex-parameter :texture-2d :texture-min-filter min-filter) - (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) - (gl:pixel-store :unpack-row-length (/ (sdl2:surface-pitch rgba-surface) 4)) - (gl:tex-image-2d :texture-2d 0 :rgba - (sdl2:surface-width rgba-surface) - (sdl2:surface-height rgba-surface) - 0 - :rgba - :unsigned-byte (sdl2:surface-pixels rgba-surface)) - (gl:bind-texture :texture-2d 0) - (unless (eq rgba-surface surface) (sdl2:free-surface rgba-surface)) - (when free-surface - (when (eq free-surface :font) - (tg:cancel-finalization surface)) - (sdl2:free-surface surface)) - (setf (image-texture image) texture)))) - (if (delay-init-p) - (add-delayed-init-fun! #'init) - (init)))) - -(defun cut-surface (surface x y w h) - (if (and x y w h) - (let ((src-rect (sdl2:make-rect x y w h)) - (dst-rect (sdl2:make-rect 0 0 w h)) - (dst-surface (sdl2-ffi.functions:sdl-create-rgb-surface-with-format - 0 w h 32 - (surface-format surface)))) - (sdl2-ffi.functions:sdl-set-surface-blend-mode surface sdl2-ffi:+sdl-blendmode-none+) - (sdl2:blit-surface surface src-rect dst-surface dst-rect) - (sdl2:free-surface surface) - dst-surface) - surface)) - -(defun surface-format (surface) - (plus-c:c-let ((surface sdl2-ffi:sdl-surface :from surface)) - (surface :format :format))) - -(defmethod load-typed-resource (filename (type (eql :typeface)) - &key (size 18) &allow-other-keys) - (make-instance 'typeface - :filename filename - :pointer (sdl2-ttf:open-font filename - (coerce (truncate size) - '(signed-byte 32))))) - -(defgeneric free-resource (resource)) - -(defmethod free-resource ((resource (eql nil)))) - -(defmethod free-resource ((image image)) - (gl:delete-textures (list (image-texture image)))) - -(defmethod free-resource ((typeface typeface)) - (let ((pointer (typeface-pointer typeface))) - (setf (typeface-pointer typeface) nil) - (sdl2-ttf:close-font pointer))) diff --git a/src/transforms.lisp b/src/transforms.lisp index e740aa0..22b9168 100644 --- a/src/transforms.lisp +++ b/src/transforms.lisp @@ -77,3 +77,37 @@ ;; TODO: This is painfully inelegant. ;; No consing should happen at this point. (list (elt transformed 0) (elt transformed 1)))) + +;;; FIT, WITH-FIT +;;; Modes were taken from GTK, see https://docs.gtk.org/gtk4/enum.ContentFit.html +(defun fit (to-width to-height from-width from-height &key (mode :contain)) + (check-type mode (member :contain :cover :scale-down :fill)) + (ecase mode + ((:contain :cover :scale-down) + (flet ((%fit-scale (scale) + (let ((x-shift (/ (- from-width + (* to-width scale)) + 2)) + (y-shift (/ (- from-height + (* to-height scale)) + 2))) + (translate x-shift y-shift) + (scale scale)))) + (%fit-scale + (ecase mode + (:contain (min (/ from-width to-width) + (/ from-height to-height))) + (:cover (max (/ from-width to-width) + (/ from-height to-height))) + (:scale-down (min (/ from-width to-width) + (/ from-height to-height) + 1)))))) + (:fill + (scale (/ from-width to-width) + (/ from-height to-height))))) + +(defmacro with-fit ((to-width to-height from-width from-height &key (mode :contain)) + &body body) + `(with-current-matrix + (fit ,to-width ,to-height ,from-width ,from-height :mode ,mode) + ,@body)) From b0539f9528433fc1071af7a4f7e0c41360e3345c Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Thu, 15 Feb 2024 00:37:10 +0100 Subject: [PATCH 4/9] Move SKETCH-WINDOW to a separate file, rename to WINDOW --- sketch.asd | 1 + src/controllers.lisp | 28 +++--- src/sketch.lisp | 202 +--------------------------------------- src/window.lisp | 213 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 233 insertions(+), 211 deletions(-) create mode 100644 src/window.lisp diff --git a/sketch.asd b/sketch.asd index f79a950..9c8c6c7 100644 --- a/sketch.asd +++ b/sketch.asd @@ -40,6 +40,7 @@ (:file "shaders") (:file "drawing") (:file "sketch") + (:file "window") (:file "entities") ; depends on sketch (:file "figures") (:file "controllers") diff --git a/src/controllers.lisp b/src/controllers.lisp index 6345650..9424d19 100644 --- a/src/controllers.lisp +++ b/src/controllers.lisp @@ -60,10 +60,10 @@ x & y are assumed to come last in the argument list." (on-enter entity)) (call-next-method))) -(defmethod kit.sdl2:mousebutton-event ((instance sketch-window) state timestamp button x y) +(defmethod kit.sdl2:mousebutton-event ((instance window) state timestamp button x y) ;; For backward compatibility. - (kit.sdl2:mousebutton-event (%sketch instance) state timestamp button x y) - (on-mouse-button (%sketch instance) + (kit.sdl2:mousebutton-event (window-sketch instance) state timestamp button x y) + (on-mouse-button (window-sketch instance) (translate-sdl2-button button) (translate-sdl2-button-state state) x @@ -106,10 +106,10 @@ x & y are assumed to come last in the argument list." (defmethod on-mouse-right-up :after ((instance sketch) x y) (on-right-click instance x y)) -(defmethod kit.sdl2:mousemotion-event ((instance sketch-window) timestamp button-mask x y xrel yrel) +(defmethod kit.sdl2:mousemotion-event ((instance window) timestamp button-mask x y xrel yrel) ;; For backward compatibility. - (kit.sdl2:mousemotion-event (%sketch instance) timestamp button-mask x y xrel yrel) - (with-slots ((sketch %sketch)) instance + (kit.sdl2:mousemotion-event (window-sketch instance) timestamp button-mask x y xrel yrel) + (let ((sketch (window-sketch instance))) (on-hover sketch x y) (unless (loop for entity being the hash-key of (sketch-%entities sketch) @@ -122,7 +122,7 @@ x & y are assumed to come last in the argument list." (on-leave *current-entity*) (setf *current-entity* nil))))) -(defmethod kit.sdl2:mousemotion-event :after ((instance sketch-window) +(defmethod kit.sdl2:mousemotion-event :after ((instance window) timestamp button-mask x y xrel yrel) (out :mouse (cons x y) :mouse-x x @@ -131,15 +131,15 @@ x & y are assumed to come last in the argument list." :mouse-xrel xrel :mouse-yrel yrel)) -(defmethod kit.sdl2:mousewheel-event :after ((instance sketch-window) +(defmethod kit.sdl2:mousewheel-event :after ((instance window) timestamp x y) (out :mouse-wheel (cons x y) :mouse-wheel-x x :mouse-wheel-y y)) -(defmethod kit.sdl2:mousebutton-event :after ((instance sketch-window) +(defmethod kit.sdl2:mousebutton-event :after ((instance window) state timestamp button x y) - (with-slots (%env) (%sketch instance) + (with-slots (%env) (window-sketch instance) (when (env-red-screen %env) (when (eq state :mousebuttonup) (setf (env-debug-key-pressed %env) t))))) @@ -159,12 +159,12 @@ x & y are assumed to come last in the argument list." (let ((*draw-mode* nil)) (call-next-method)))) -(defmethod kit.sdl2:textinput-event :after ((instance sketch-window) timestamp text) - (on-text (%sketch instance) text)) +(defmethod kit.sdl2:textinput-event :after ((instance window) timestamp text) + (on-text (window-sketch instance) text)) -(defmethod kit.sdl2:keyboard-event :after ((instance sketch-window) state timestamp repeat-p keysym) +(defmethod kit.sdl2:keyboard-event :after ((instance window) state timestamp repeat-p keysym) (when (not repeat-p) - (on-key (%sketch instance) + (on-key (window-sketch instance) (without-sdl2-scancode-prefix keysym) (translate-sdl2-key-state state)))) diff --git a/src/sketch.lisp b/src/sketch.lisp index 583f22b..7802b46 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -26,16 +26,15 @@ "The current sketch instance.") (defparameter *default-width* 400 - "The default width of sketch window") + "The default sketch width.") (defparameter *default-height* 400 - "The default height of sketch window") + "The default sketch height.") (defclass sketch () ((%env :initform nil :reader sketch-%env) (%setup-called :initform nil :accessor sketch-%setup-called) (%viewport-changed :initform t) (%entities :initform (make-hash-table) :accessor sketch-%entities) - (%window :initform nil :accessor sketch-%window :initarg :window) (%delayed-init-funs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor sketch-%delayed-init-funs) (title :initform "Sketch" :accessor sketch-title :initarg :title) @@ -47,59 +46,13 @@ (y-axis :initform :down :accessor sketch-y-axis :initarg :y-axis) (close-on :initform :escape :accessor sketch-close-on :initarg :close-on))) -(defclass sketch-window (kit.sdl2:gl-window) - ((%sketch - :initarg :sketch - :accessor %sketch - :documentation "The sketch associated with this window.") - (%closing :initform nil :accessor window-%closing))) - -;; Always enabled -(defmethod kit.sdl2:render-enabled ((window sketch-window)) - t) - -;; So don't do anything on SETF as well -(defmethod (setf kit.sdl2:render-enabled) (value (window sketch-window)) - value) - - ;;; Non trivial sketch writers - -(defmacro define-sketch-writer (slot &body body) - `(defmethod (setf ,(alexandria:symbolicate 'sketch- slot)) :after (value (instance sketch)) - (alexandria:when-let (win (sketch-%window instance)) - (let ((win (kit.sdl2:sdl-window win))) - ,@body)))) - -(define-sketch-writer title - (sdl2:set-window-title win value)) - -(define-sketch-writer width - (sdl2:set-window-size win value (sketch-height instance)) - (initialize-view-matrix instance)) - -(define-sketch-writer height - (sdl2:set-window-size win (sketch-width instance) value) - (initialize-view-matrix instance)) - -(define-sketch-writer fullscreen - (sdl2:set-window-fullscreen win value)) - -(define-sketch-writer resizable - (sdl2-ffi.functions:sdl-set-window-resizable - win - (if value sdl2-ffi:+true+ sdl2-ffi:+false+))) - -(define-sketch-writer y-axis - (declare (ignorable win)) - (initialize-view-matrix instance)) - ;;; Generic functions (defgeneric prepare (instance &key &allow-other-keys) (:documentation "Generated by DEFSKETCH.")) (defgeneric setup (instance &key &allow-other-keys) - (:documentation "Called before creating the sketch window.") + (:documentation "Called before creating the sketch.") (:method ((instance sketch) &key &allow-other-keys) ())) (defgeneric draw (instance &key x y width height mode &allow-other-keys) @@ -132,42 +85,6 @@ (call-next-method)) (kit.sdl2:start)) -(defmethod initialize-instance :after ((instance sketch) &rest initargs &key &allow-other-keys) - (apply #'prepare instance initargs) - (setf (sketch-%window instance) - (make-instance 'sketch-window - :title (sketch-title instance) - :w (sketch-width instance) - :h (sketch-height instance) - :fullscreen (sketch-fullscreen instance) - :resizable (sketch-resizable instance) - :sketch instance)) - (setf (slot-value instance '%env) (make-env)) - (initialize-view-matrix instance) - (initialize-gl instance) - ;; These will have been added in the call to PREPARE. - (with-slots ((fs %delayed-init-funs)) instance - (loop for f across fs - do (funcall f)) - (setf fs (make-array 0 :adjustable t :fill-pointer t)))) - -(defun initialize-gl (sketch) - (with-slots ((w %window)) sketch - (handler-case (sdl2:gl-set-swap-interval 1) - ;; Some OpenGL drivers do not allow to control swapping. - ;; In this case SDL2 sets an error that needs to be cleared. - (sdl2::sdl-rc-error (e) - (warn "VSYNC was not enabled; frame rate was not restricted to 60fps.~% ~A" e) - (sdl2-ffi.functions:sdl-clear-error))) - (setf (kit.sdl2:idle-render w) t) - (gl:enable :blend :line-smooth :polygon-smooth) - (gl:blend-func :src-alpha :one-minus-src-alpha) - (gl:hint :line-smooth-hint :nicest) - (gl:hint :polygon-smooth-hint :nicest) - (gl:clear-color 0.0 0.0 0.0 1.0) - (gl:clear :color-buffer :depth-buffer) - (gl:flush))) - (defmethod update-instance-for-redefined-class :after ((instance sketch) added-slots discarded-slots property-list &rest initargs) (declare (ignore added-slots discarded-slots property-list)) @@ -242,24 +159,6 @@ (gl:viewport 0 0 width height) (setf %viewport-changed nil)))) -(defmethod kit.sdl2:render ((win sketch-window) &aux (sketch (%sketch win))) - (maybe-change-viewport sketch) - (with-sketch (sketch) - (with-gl-draw - (with-error-handling (sketch) - (unless (sketch-copy-pixels sketch) - (background (gray 0.4))) - (when (or (env-red-screen *env*) - (not (sketch-%setup-called sketch))) - (setf (env-red-screen *env*) nil - (sketch-%setup-called sketch) t) - (with-stage :setup - (setup sketch))) - (with-stage :draw - (draw sketch)))))) - -(defmethod kit.sdl2:render ((instance sketch)) - (kit.sdl2:render (sketch-%window instance))) ;;; TODO: Would be great to move it to transforms. (defun initialize-view-matrix (sketch) @@ -270,16 +169,6 @@ (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) %viewport-changed t))) -;;; Support for resizable windows - -(defmethod kit.sdl2:window-event :before ((instance sketch-window) (type (eql :size-changed)) timestamp data1 data2) - (with-slots ((sketch %sketch)) instance - (with-slots ((env %env) width height y-axis) sketch - (setf width data1 - height data2) - (initialize-view-matrix sketch))) - (kit.sdl2:render instance)) - ;;; Default events (defconstant +scancode-prefix-length+ (length "scancode-")) @@ -295,16 +184,6 @@ (when (and (eql state :keyup) (eq (without-sdl2-scancode-prefix keysym) close-on)) (kit.sdl2:close-window instance)))) -(defmethod close-window :before ((instance sketch-window)) - (with-environment (slot-value (%sketch instance) '%env) - (loop for resource being the hash-values of (env-resources *env*) - do (free-resource resource)))) - -(defmethod close-window :after ((instance sketch)) - (when (and *build* (not (kit.sdl2:all-windows))) - (sdl2-ttf:quit) - (kit.sdl2:quit))) - ;;; DEFSKETCH macro (defun define-sketch-defclass (name bindings) @@ -322,7 +201,7 @@ ; TODO: Should this really depend on kit.sdl2? (let ((win (kit.sdl2:last-window))) (when win - (setf (,(binding-accessor b) (%sketch win)) + (setf (,(binding-accessor b) (window-sketch win)) (in ,(binding-channel-name b) ,(binding-initform b)))))))) @@ -358,84 +237,13 @@ (make-instances-obsolete ',sketch-name) (find-class ',sketch-name)))) -;;; Control flow - -(defun stop-loop () - (setf (sdl2.kit:idle-render (sketch-%window *sketch*)) nil)) - -(defun start-loop () - (setf (sdl2.kit:idle-render (sketch-%window *sketch*)) t)) - -;;; Backward compatibility. -;; Previously, the main `sketch` class inherited from -;; `kit.sdl2:gl-window`, and input was handled by specialising on methods from -;; sdl2kit. So we need to forward sdl2kit input calls to the `sketch` class for -;; old sketches that rely on that approach. -(defmacro define-sdl2-forward (name (&rest args) &optional already-defined?) - `(progn - ;; An empty method so we don't get an error if we try to forward - ;; when the user hasn't defined it. - (defmethod ,name ((w sketch) ,@args)) - ,@(when (not already-defined?) - `((defmethod ,name ((w sketch-window) ,@args) - (,name (%sketch w) ,@args) - (call-next-method)))))) -(define-sdl2-forward kit.sdl2:mousebutton-event (state timestamp button x y) t) -(define-sdl2-forward kit.sdl2:mousemotion-event (timestamp button-mask x y xrel yrel) t) -(define-sdl2-forward kit.sdl2:textinput-event (timestamp text)) -(define-sdl2-forward kit.sdl2:keyboard-event (state timestamp repeatp keysym)) -(define-sdl2-forward kit.sdl2:mousewheel-event (timestamp x y)) -(define-sdl2-forward kit.sdl2:window-event (type timestamp data1 data2)) -(define-sdl2-forward kit.sdl2:controller-added-event (c)) -(define-sdl2-forward kit.sdl2:controller-removed-event (c)) -(define-sdl2-forward kit.sdl2:controller-axis-motion-event (controller timestamp axis value)) -(define-sdl2-forward kit.sdl2:controller-button-event (controller state timestamp button)) - -(defmethod kit.sdl2:idle-render ((instance sketch)) - (kit.sdl2:idle-render (sketch-%window instance))) - -(defmethod (setf kit.sdl2:idle-render) (value (instance sketch)) - (setf (kit.sdl2:idle-render (sketch-%window instance)) value)) - -(defmethod kit.sdl2:sdl-window ((instance sketch)) - (kit.sdl2:sdl-window (sketch-%window instance))) - -(defmethod kit.sdl2:gl-context ((instance sketch)) - (kit.sdl2:gl-context (sketch-%window instance))) - -(defmethod kit.sdl2:render-enabled ((instance sketch)) - (kit.sdl2:render-enabled (sketch-%window instance))) - -(defmethod (setf kit.sdl2:render-enabled) (value (instance sketch)) - (setf (kit.sdl2:render-enabled (sketch-%window instance)) value)) - -;; KIT.SDL2:CLOSE-WINDOW is tricky: it should always be called on both -;; the sketch and sketch's window; but it also can be first called on -;; both the window or the sketch. -;; It also should be called in sdl2's main thread, which is done by an -;; :AROUND method defined on KIT.SDL2:WINDOW. -;; The primary method defined on the SKETCH-WINDOW should -;; (call-next-method) because there is a primary method defined on -;; GL-WINDOW. -;; Finally, the :AFTER method defined on SKETCH calls KIT.SDL2:QUIT and -;; SDL2-TTF:QUIT. -(defmethod kit.sdl2:close-window ((instance sketch)) - (with-slots ((window %window)) instance - (setf (window-%closing window) t) - (kit.sdl2:close-window window))) - -(defmethod kit.sdl2:close-window :around ((instance sketch-window)) - (if (window-%closing instance) - (call-next-method) - (kit.sdl2:close-window (%sketch instance)))) - ;;; Resource-handling (defun delay-init-p () "This checks whether the OpenGL context has been created yet. If not, we need to wait before initializing certain resources." (and *sketch* - (null (sketch-%window *sketch*)))) + (null (sketch-window *sketch*)))) (defun add-delayed-init-fun! (f) "F should be a function with no arguments." diff --git a/src/window.lisp b/src/window.lisp new file mode 100644 index 0000000..4c8c702 --- /dev/null +++ b/src/window.lisp @@ -0,0 +1,213 @@ +;;;; window.lisp + +(in-package #:sketch) + +;;; __ _____ _ _ ____ _____ __ +;;; \ \ / /_ _| \ | | _ \ / _ \ \ / / +;;; \ \ /\ / / | || \| | | | | | | \ \ /\ / / +;;; \ V V / | || |\ | |_| | |_| |\ V V / +;;; \_/\_/ |___|_| \_|____/ \___/ \_/\_/ + +(defclass window (kit.sdl2:gl-window) + ((sketch :initarg :sketch :accessor window-sketch + :documentation "The sketch associated with this window.") + (closing :initform nil :accessor window-closing))) + +;; Make sure that the rendering is always enabled. + +(defmethod kit.sdl2:render-enabled ((window window)) + t) + +(defmethod (setf kit.sdl2:render-enabled) (value (window window)) + value) + +;;; Sketch window. + +(defparameter *sketch-window* (make-hash-table)) + +(defun sketch-window (sketch) + (gethash sketch *sketch-window*)) + +;;; Backwards compatibility (sketch -> window) + +(defmethod kit.sdl2:idle-render ((instance sketch)) + (kit.sdl2:idle-render (sketch-window instance))) + +(defmethod (setf kit.sdl2:idle-render) (value (instance sketch)) + (setf (kit.sdl2:idle-render (sketch-window instance)) value)) + +(defmethod kit.sdl2:sdl-window ((instance sketch)) + (kit.sdl2:sdl-window (sketch-window instance))) + +(defmethod kit.sdl2:gl-context ((instance sketch)) + (kit.sdl2:gl-context (sketch-window instance))) + +(defmethod kit.sdl2:render-enabled ((instance sketch)) + (kit.sdl2:render-enabled (sketch-window instance))) + +(defmethod (setf kit.sdl2:render-enabled) (value (instance sketch)) + (setf (kit.sdl2:render-enabled (sketch-window instance)) value)) + +;;; Non trivial sketch writers + +(defmacro define-sketch-writer (slot &body body) + `(defmethod (setf ,(alexandria:symbolicate 'sketch- slot)) :after (value (instance sketch)) + (alexandria:when-let (win (sketch-window instance)) + (let ((win (kit.sdl2:sdl-window win))) + ,@body)))) + +(define-sketch-writer title + (sdl2:set-window-title win value)) + +(define-sketch-writer width + (sdl2:set-window-size win value (sketch-height instance)) + (initialize-view-matrix instance)) + +(define-sketch-writer height + (sdl2:set-window-size win (sketch-width instance) value) + (initialize-view-matrix instance)) + +(define-sketch-writer fullscreen + (sdl2:set-window-fullscreen win value)) + +(define-sketch-writer resizable + (sdl2-ffi.functions:sdl-set-window-resizable + win + (if value sdl2-ffi:+true+ sdl2-ffi:+false+))) + +(define-sketch-writer y-axis + (declare (ignorable win)) + (initialize-view-matrix instance)) + +;;; Backwards compatible initialization + +(defmethod initialize-instance :after ((instance sketch) &rest initargs &key &allow-other-keys) + (apply #'prepare instance initargs) + (let ((window + (make-instance 'window + :title (sketch-title instance) + :w (sketch-width instance) + :h (sketch-height instance) + :fullscreen (sketch-fullscreen instance) + :resizable (sketch-resizable instance) + :sketch instance))) + (setf (gethash instance *sketch-window*) window) + (setf (slot-value instance '%env) (make-env)) + (initialize-view-matrix instance) + (initialize-gl window) + ;; These will have been added in the call to PREPARE. + (with-slots ((fs %delayed-init-funs)) instance + (loop for f across fs + do (funcall f)) + (setf fs (make-array 0 :adjustable t :fill-pointer t))))) + +(defun initialize-gl (window) + (handler-case (sdl2:gl-set-swap-interval 1) + ;; Some OpenGL drivers do not allow to control swapping. + ;; In this case SDL2 sets an error that needs to be cleared. + (sdl2::sdl-rc-error (e) + (warn "VSYNC was not enabled; frame rate was not restricted to 60fps.~% ~A" e) + (sdl2-ffi.functions:sdl-clear-error))) + (setf (kit.sdl2:idle-render window) t) + (gl:enable :blend :line-smooth :polygon-smooth) + (gl:blend-func :src-alpha :one-minus-src-alpha) + (gl:hint :line-smooth-hint :nicest) + (gl:hint :polygon-smooth-hint :nicest) + (gl:clear-color 0.0 0.0 0.0 1.0) + (gl:clear :color-buffer :depth-buffer) + (gl:flush)) + +;;; Support for resizable windows + +(defmethod kit.sdl2:window-event :before ((instance window) (type (eql :size-changed)) timestamp data1 data2) + (let ((sketch (window-sketch instance))) + (with-slots ((env %env) width height y-axis) sketch + (setf width data1 + height data2) + (initialize-view-matrix sketch))) + (kit.sdl2:render instance)) + +;;; Rendering + +(defmethod kit.sdl2:render ((window window) &aux (sketch (window-sketch window))) + (maybe-change-viewport sketch) + (with-sketch (sketch) + (with-gl-draw + (with-error-handling (sketch) + (unless (sketch-copy-pixels sketch) + (background (gray 0.4))) + (when (or (env-red-screen *env*) + (not (sketch-%setup-called sketch))) + (setf (env-red-screen *env*) nil + (sketch-%setup-called sketch) t) + (with-stage :setup + (setup sketch))) + (with-stage :draw + (draw sketch)))))) + +(defmethod kit.sdl2:render ((instance sketch)) + (kit.sdl2:render (sketch-window instance))) + +;;; Control flow + +(defun stop-loop () + (setf (sdl2.kit:idle-render (sketch-window *sketch*)) nil)) + +(defun start-loop () + (setf (sdl2.kit:idle-render (sketch-window *sketch*)) t)) + +;;; Backward compatibility. +;; Previously, the main `sketch` class inherited from +;; `kit.sdl2:gl-window`, and input was handled by specialising on methods from +;; sdl2kit. So we need to forward sdl2kit input calls to the `sketch` class for +;; old sketches that rely on that approach. +(defmacro define-sdl2-forward (name (&rest args) &optional already-defined?) + `(progn + ;; An empty method so we don't get an error if we try to forward + ;; when the user hasn't defined it. + (defmethod ,name ((w sketch) ,@args)) + ,@(when (not already-defined?) + `((defmethod ,name ((w window) ,@args) + (,name (window-sketch w) ,@args) + (call-next-method)))))) +(define-sdl2-forward kit.sdl2:mousebutton-event (state timestamp button x y) t) +(define-sdl2-forward kit.sdl2:mousemotion-event (timestamp button-mask x y xrel yrel) t) +(define-sdl2-forward kit.sdl2:textinput-event (timestamp text)) +(define-sdl2-forward kit.sdl2:keyboard-event (state timestamp repeatp keysym)) +(define-sdl2-forward kit.sdl2:mousewheel-event (timestamp x y)) +(define-sdl2-forward kit.sdl2:window-event (type timestamp data1 data2)) +(define-sdl2-forward kit.sdl2:controller-added-event (c)) +(define-sdl2-forward kit.sdl2:controller-removed-event (c)) +(define-sdl2-forward kit.sdl2:controller-axis-motion-event (controller timestamp axis value)) +(define-sdl2-forward kit.sdl2:controller-button-event (controller state timestamp button)) + +;;; Close window + +;; KIT.SDL2:CLOSE-WINDOW is tricky: it should always be called on both +;; the sketch and sketch's window; but it also can be first called on +;; both the window or the sketch. +;; It also should be called in sdl2's main thread, which is done by an +;; :AROUND method defined on KIT.SDL2:WINDOW. +;; The primary method defined on the SKETCH-WINDOW should +;; (call-next-method) because there is a primary method defined on +;; GL-WINDOW. +;; Finally, the :AFTER method defined on SKETCH calls KIT.SDL2:QUIT and +;; SDL2-TTF:QUIT. +(defmethod kit.sdl2:close-window ((instance sketch)) + (setf (window-closing (sketch-window instance)) t) + (kit.sdl2:close-window (sketch-window instance))) + +(defmethod kit.sdl2:close-window :around ((window window)) + (if (window-closing window) + (call-next-method) + (kit.sdl2:close-window (window-sketch window)))) + +(defmethod close-window :before ((instance window)) + (with-environment (slot-value (window-sketch instance) '%env) + (loop for resource being the hash-values of (env-resources *env*) + do (free-resource resource)))) + +(defmethod close-window :after ((instance sketch)) + (when (and *build* (not (kit.sdl2:all-windows))) + (sdl2-ttf:quit) + (kit.sdl2:quit))) From f5fbb2c9dbd8f9686a42475e13113facb88db281 Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Thu, 15 Feb 2024 01:45:20 +0100 Subject: [PATCH 5/9] backend module, viewport --- sketch.asd | 5 ++++- src/{ => backend}/window.lisp | 19 ++++++++++++++++++- src/sketch.lisp | 18 ------------------ 3 files changed, 22 insertions(+), 20 deletions(-) rename src/{ => backend}/window.lisp (89%) diff --git a/sketch.asd b/sketch.asd index 9c8c6c7..c65b0fc 100644 --- a/sketch.asd +++ b/sketch.asd @@ -40,7 +40,10 @@ (:file "shaders") (:file "drawing") (:file "sketch") - (:file "window") + (:module "backend" + :depends-on ("package") + :serial t + :components ((:file "window"))) (:file "entities") ; depends on sketch (:file "figures") (:file "controllers") diff --git a/src/window.lisp b/src/backend/window.lisp similarity index 89% rename from src/window.lisp rename to src/backend/window.lisp index 4c8c702..4cb8360 100644 --- a/src/window.lisp +++ b/src/backend/window.lisp @@ -11,7 +11,8 @@ (defclass window (kit.sdl2:gl-window) ((sketch :initarg :sketch :accessor window-sketch :documentation "The sketch associated with this window.") - (closing :initform nil :accessor window-closing))) + (closing :initform nil :accessor window-closing) + (viewport-changed :initform t :accessor window-viewport-changed))) ;; Make sure that the rendering is always enabled. @@ -148,6 +149,22 @@ (defmethod kit.sdl2:render ((instance sketch)) (kit.sdl2:render (sketch-window instance))) +(defun maybe-change-viewport (sketch &aux (window (sketch-window sketch))) + (with-slots (%env width height) sketch + (when (window-viewport-changed window) + (kit.gl.shader:uniform-matrix (env-programs %env) :view-m 4 (vector (env-view-matrix %env))) + (gl:viewport 0 0 width height) + (setf (window-viewport-changed window) nil)))) + +;;; TODO: Would be great to move it to transforms. +(defun initialize-view-matrix (sketch &aux (window (sketch-window sketch))) + (with-slots ((env %env) width height y-axis) sketch + (setf (env-view-matrix env) (if (eq y-axis :down) + (kit.glm:ortho-matrix 0 width height 0 -1 1) + (kit.glm:ortho-matrix 0 width 0 height -1 1)) + (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) + (window-viewport-changed window) t))) + ;;; Control flow (defun stop-loop () diff --git a/src/sketch.lisp b/src/sketch.lisp index 7802b46..82576a5 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -33,7 +33,6 @@ (defclass sketch () ((%env :initform nil :reader sketch-%env) (%setup-called :initform nil :accessor sketch-%setup-called) - (%viewport-changed :initform t) (%entities :initform (make-hash-table) :accessor sketch-%entities) (%delayed-init-funs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor sketch-%delayed-init-funs) @@ -152,23 +151,6 @@ ,@body (end-draw))) -(defun maybe-change-viewport (sketch) - (with-slots (%env %viewport-changed width height) sketch - (when %viewport-changed - (kit.gl.shader:uniform-matrix (env-programs %env) :view-m 4 (vector (env-view-matrix %env))) - (gl:viewport 0 0 width height) - (setf %viewport-changed nil)))) - - -;;; TODO: Would be great to move it to transforms. -(defun initialize-view-matrix (sketch) - (with-slots ((env %env) width height y-axis %viewport-changed) sketch - (setf (env-view-matrix env) (if (eq y-axis :down) - (kit.glm:ortho-matrix 0 width height 0 -1 1) - (kit.glm:ortho-matrix 0 width 0 height -1 1)) - (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) - %viewport-changed t))) - ;;; Default events (defconstant +scancode-prefix-length+ (length "scancode-")) From 4ef7bbddb08b33e3c160b0773e2ca79ca44e5c41 Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Thu, 15 Feb 2024 23:49:41 +0100 Subject: [PATCH 6/9] Temporarily remove delayed initialization of images The fix will be built again on top of backend functionality. --- src/backend/window.lisp | 7 +--- src/resource-loading.lisp | 68 ++++++++++++++++++--------------------- src/sketch.lisp | 14 -------- 3 files changed, 33 insertions(+), 56 deletions(-) diff --git a/src/backend/window.lisp b/src/backend/window.lisp index 4cb8360..c850c62 100644 --- a/src/backend/window.lisp +++ b/src/backend/window.lisp @@ -95,12 +95,7 @@ (setf (gethash instance *sketch-window*) window) (setf (slot-value instance '%env) (make-env)) (initialize-view-matrix instance) - (initialize-gl window) - ;; These will have been added in the call to PREPARE. - (with-slots ((fs %delayed-init-funs)) instance - (loop for f across fs - do (funcall f)) - (setf fs (make-array 0 :adjustable t :fill-pointer t))))) + (initialize-gl window))) (defun initialize-gl (window) (handler-case (sdl2:gl-set-swap-interval 1) diff --git a/src/resource-loading.lisp b/src/resource-loading.lisp index e6d5686..0edfea5 100644 --- a/src/resource-loading.lisp +++ b/src/resource-loading.lisp @@ -32,14 +32,14 @@ (when (not resource) (setf resource (apply #'load-typed-resource - (list* filename - (or type - (case (alexandria:make-keyword - (alexandria:symbolicate - (string-upcase (file-name-extension filename)))) - ((:png :jpg :jpeg :tga :gif :bmp) :image) - ((:ttf :otf) :typeface))) - all-keys)))) + (list* filename + (or type + (case (alexandria:make-keyword + (alexandria:symbolicate + (string-upcase (file-name-extension filename)))) + ((:png :jpg :jpeg :tga :gif :bmp) :image) + ((:ttf :otf) :typeface))) + all-keys)))) resource)))) (defgeneric load-typed-resource (filename type &key &allow-other-keys)) @@ -77,34 +77,30 @@ :mag-filter mag-filter)) (defun init-image-texture! (image surface &key (free-surface t) - (min-filter :linear) - (mag-filter :linear)) - (flet ((init () - (let ((texture (car (gl:gen-textures 1))) - (rgba-surface - (if (eq (sdl2:surface-format-format surface) sdl2:+pixelformat-rgba32+) - surface - (sdl2:convert-surface-format surface sdl2:+pixelformat-rgba32+)))) - (gl:bind-texture :texture-2d texture) - (gl:tex-parameter :texture-2d :texture-min-filter min-filter) - (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) - (gl:pixel-store :unpack-row-length (/ (sdl2:surface-pitch rgba-surface) 4)) - (gl:tex-image-2d :texture-2d 0 :rgba - (sdl2:surface-width rgba-surface) - (sdl2:surface-height rgba-surface) - 0 - :rgba - :unsigned-byte (sdl2:surface-pixels rgba-surface)) - (gl:bind-texture :texture-2d 0) - (unless (eq rgba-surface surface) (sdl2:free-surface rgba-surface)) - (when free-surface - (when (eq free-surface :font) - (tg:cancel-finalization surface)) - (sdl2:free-surface surface)) - (setf (image-texture image) texture)))) - (if (delay-init-p) - (add-delayed-init-fun! #'init) - (init)))) + (min-filter :linear) + (mag-filter :linear)) + (let ((texture (car (gl:gen-textures 1))) + (rgba-surface + (if (eq (sdl2:surface-format-format surface) sdl2:+pixelformat-rgba32+) + surface + (sdl2:convert-surface-format surface sdl2:+pixelformat-rgba32+)))) + (gl:bind-texture :texture-2d texture) + (gl:tex-parameter :texture-2d :texture-min-filter min-filter) + (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) + (gl:pixel-store :unpack-row-length (/ (sdl2:surface-pitch rgba-surface) 4)) + (gl:tex-image-2d :texture-2d 0 :rgba + (sdl2:surface-width rgba-surface) + (sdl2:surface-height rgba-surface) + 0 + :rgba + :unsigned-byte (sdl2:surface-pixels rgba-surface)) + (gl:bind-texture :texture-2d 0) + (unless (eq rgba-surface surface) (sdl2:free-surface rgba-surface)) + (when free-surface + (when (eq free-surface :font) + (tg:cancel-finalization surface)) + (sdl2:free-surface surface)) + (setf (image-texture image) texture))) (defun cut-surface (surface x y w h) (if (and x y w h) diff --git a/src/sketch.lisp b/src/sketch.lisp index 82576a5..4786696 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -34,8 +34,6 @@ ((%env :initform nil :reader sketch-%env) (%setup-called :initform nil :accessor sketch-%setup-called) (%entities :initform (make-hash-table) :accessor sketch-%entities) - (%delayed-init-funs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor sketch-%delayed-init-funs) (title :initform "Sketch" :accessor sketch-title :initarg :title) (width :initform *default-width* :accessor sketch-width :initarg :width) (height :initform *default-height* :accessor sketch-height :initarg :height) @@ -218,15 +216,3 @@ (make-instances-obsolete ',sketch-name) (find-class ',sketch-name)))) - -;;; Resource-handling - -(defun delay-init-p () - "This checks whether the OpenGL context has been created yet. If not, -we need to wait before initializing certain resources." - (and *sketch* - (null (sketch-window *sketch*)))) - -(defun add-delayed-init-fun! (f) - "F should be a function with no arguments." - (vector-push-extend f (sketch-%delayed-init-funs *sketch*))) From 96bccdf8bde3e63ec0415bce1897384c7f80707b Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 18 Feb 2024 20:26:13 +0100 Subject: [PATCH 7/9] extract sdl2 backend --- sketch.asd | 3 ++- src/backend/sdl2backend.lisp | 31 +++++++++++++++++++++++++++++++ src/sketch.lisp | 22 ---------------------- 3 files changed, 33 insertions(+), 23 deletions(-) create mode 100644 src/backend/sdl2backend.lisp diff --git a/sketch.asd b/sketch.asd index c65b0fc..54bbc35 100644 --- a/sketch.asd +++ b/sketch.asd @@ -43,7 +43,8 @@ (:module "backend" :depends-on ("package") :serial t - :components ((:file "window"))) + :components ((:file "window") + (:file "sdl2backend"))) (:file "entities") ; depends on sketch (:file "figures") (:file "controllers") diff --git a/src/backend/sdl2backend.lisp b/src/backend/sdl2backend.lisp new file mode 100644 index 0000000..16d73a9 --- /dev/null +++ b/src/backend/sdl2backend.lisp @@ -0,0 +1,31 @@ +;;;; sdl2backend.lisp + +(in-package #:sketch) + +;;; ____ ____ _ ____ ____ _ ____ _ _______ _ _ ____ +;;; / ___|| _ \| | |___ \| __ ) / \ / ___| |/ / ____| \ | | _ \ +;;; \___ \| | | | | __) | _ \ / _ \| | | ' /| _| | \| | | | | +;;; ___) | |_| | |___ / __/| |_) / ___ \ |___| . \| |___| |\ | |_| | +;;; |____/|____/|_____|_____|____/_/ \_\____|_|\_\_____|_| \_|____/ + +(let ((initialized nil)) + (defun initialize-backend () + (unless initialized + (setf initialized t) + (kit.sdl2:init) + (sdl2-ttf:init) + (sdl2:in-main-thread () + (sdl2:gl-set-attr :multisamplebuffers 1) + (sdl2:gl-set-attr :multisamplesamples 4) + + (sdl2:gl-set-attr :context-major-version 3) + (sdl2:gl-set-attr :context-minor-version 3) + (sdl2:gl-set-attr :context-profile-mask 1))))) + +;;; Backwards compatibility with starting the backend on sketch creation + +(defmethod initialize-instance :around ((instance sketch) &key &allow-other-keys) + (initialize-backend) + (sdl2:in-main-thread () + (call-next-method)) + (kit.sdl2:start)) diff --git a/src/sketch.lisp b/src/sketch.lisp index 4786696..c7f66e5 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -59,28 +59,6 @@ (declare (ignore x y width height mode)) ())) - ;;; Initialization - -(defparameter *initialized* nil) - -(defun initialize-sketch () - (unless *initialized* - (setf *initialized* t) - (kit.sdl2:init) - (sdl2-ttf:init) - (sdl2:in-main-thread () - (sdl2:gl-set-attr :multisamplebuffers 1) - (sdl2:gl-set-attr :multisamplesamples 4) - - (sdl2:gl-set-attr :context-major-version 3) - (sdl2:gl-set-attr :context-minor-version 3) - (sdl2:gl-set-attr :context-profile-mask 1)))) - -(defmethod initialize-instance :around ((instance sketch) &key &allow-other-keys) - (initialize-sketch) - (sdl2:in-main-thread () - (call-next-method)) - (kit.sdl2:start)) (defmethod update-instance-for-redefined-class :after ((instance sketch) added-slots discarded-slots property-list &rest initargs) From 28150b35cbe3261e099034fbc0dabaee2e8e480c Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 18 Feb 2024 20:35:56 +0100 Subject: [PATCH 8/9] move window methods to window.lisp --- src/backend/window.lisp | 19 +++++++++++++++++++ src/sketch.lisp | 21 --------------------- 2 files changed, 19 insertions(+), 21 deletions(-) diff --git a/src/backend/window.lisp b/src/backend/window.lisp index c850c62..9b80b12 100644 --- a/src/backend/window.lisp +++ b/src/backend/window.lisp @@ -125,6 +125,12 @@ ;;; Rendering +(defmacro with-gl-draw (&body body) + `(progn + (start-draw) + ,@body + (end-draw))) + (defmethod kit.sdl2:render ((window window) &aux (sketch (window-sketch window))) (maybe-change-viewport sketch) (with-sketch (sketch) @@ -195,6 +201,19 @@ ;;; Close window +(defconstant +scancode-prefix-length+ (length "scancode-")) + +(defun without-sdl2-scancode-prefix (keysym) + (intern (subseq (symbol-name (sdl2:scancode keysym)) + +scancode-prefix-length+) + (find-package "KEYWORD"))) + +(defmethod kit.sdl2:keyboard-event :before ((instance sketch) state timestamp repeatp keysym) + (declare (ignorable timestamp repeatp)) + (alexandria:when-let (close-on (sketch-close-on instance)) + (when (and (eql state :keyup) (eq (without-sdl2-scancode-prefix keysym) close-on)) + (kit.sdl2:close-window instance)))) + ;; KIT.SDL2:CLOSE-WINDOW is tricky: it should always be called on both ;; the sketch and sketch's window; but it also can be first called on ;; both the window or the sketch. diff --git a/src/sketch.lisp b/src/sketch.lisp index c7f66e5..5e4d1f0 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -121,27 +121,6 @@ (with-identity-matrix ,@body))))) -(defmacro with-gl-draw (&body body) - `(progn - (start-draw) - ,@body - (end-draw))) - -;;; Default events - -(defconstant +scancode-prefix-length+ (length "scancode-")) - -(defun without-sdl2-scancode-prefix (keysym) - (intern (subseq (symbol-name (sdl2:scancode keysym)) - +scancode-prefix-length+) - (find-package "KEYWORD"))) - -(defmethod kit.sdl2:keyboard-event :before ((instance sketch) state timestamp repeatp keysym) - (declare (ignorable timestamp repeatp)) - (alexandria:when-let (close-on (sketch-close-on instance)) - (when (and (eql state :keyup) (eq (without-sdl2-scancode-prefix keysym) close-on)) - (kit.sdl2:close-window instance)))) - ;;; DEFSKETCH macro (defun define-sketch-defclass (name bindings) From 41ea8d7e6bf2dd4e9f59183a7f5de1137c3e6ee4 Mon Sep 17 00:00:00 2001 From: Danilo Vidovic Date: Sun, 18 Feb 2024 20:52:14 +0100 Subject: [PATCH 9/9] no gl or sdl2 in sketch.lisp --- src/backend/window.lisp | 18 +++++++++--------- src/sketch.lisp | 9 +++------ 2 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/backend/window.lisp b/src/backend/window.lisp index 9b80b12..17fe00e 100644 --- a/src/backend/window.lisp +++ b/src/backend/window.lisp @@ -131,21 +131,21 @@ ,@body (end-draw))) -(defmethod kit.sdl2:render ((window window) &aux (sketch (window-sketch window))) - (maybe-change-viewport sketch) - (with-sketch (sketch) +(defmethod kit.sdl2:render ((window window) &aux (*sketch* (window-sketch window))) + (maybe-change-viewport *sketch*) + (with-sketch (*sketch*) (with-gl-draw - (with-error-handling (sketch) - (unless (sketch-copy-pixels sketch) + (with-error-handling (*sketch*) + (unless (sketch-copy-pixels *sketch*) (background (gray 0.4))) (when (or (env-red-screen *env*) - (not (sketch-%setup-called sketch))) + (not (sketch-%setup-called *sketch*))) (setf (env-red-screen *env*) nil - (sketch-%setup-called sketch) t) + (sketch-%setup-called *sketch*) t) (with-stage :setup - (setup sketch))) + (setup *sketch*))) (with-stage :draw - (draw sketch)))))) + (draw *sketch*)))))) (defmethod kit.sdl2:render ((instance sketch)) (kit.sdl2:render (sketch-window instance))) diff --git a/src/sketch.lisp b/src/sketch.lisp index 5e4d1f0..a2b3bc2 100644 --- a/src/sketch.lisp +++ b/src/sketch.lisp @@ -135,12 +135,9 @@ (loop for b in bindings when (binding-channelp b) collect `(define-channel-observer - ; TODO: Should this really depend on kit.sdl2? - (let ((win (kit.sdl2:last-window))) - (when win - (setf (,(binding-accessor b) (window-sketch win)) - (in ,(binding-channel-name b) - ,(binding-initform b)))))))) + (setf (,(binding-accessor b) *sketch*) + (in ,(binding-channel-name b) + ,(binding-initform b)))))) (defun define-sketch-draw-method (name bindings body) `(defmethod draw ((*sketch* ,name) &key x y width height mode &allow-other-keys)