From 0b743b90752bacf31923171af9af0e5ff1f08095 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Wed, 27 Jul 2022 09:18:13 -0500 Subject: [add] alpha support to image class --- examples/02-image-transforms-and-events.lisp | 3 +- examples/02-moving-bitmp.lisp | 143 --------------------------- src/application.lisp | 2 +- src/interactive/image.lisp | 23 ++--- 4 files changed, 13 insertions(+), 158 deletions(-) delete mode 100644 examples/02-moving-bitmp.lisp diff --git a/examples/02-image-transforms-and-events.lisp b/examples/02-image-transforms-and-events.lisp index edc9000..9e4710f 100644 --- a/examples/02-image-transforms-and-events.lisp +++ b/examples/02-image-transforms-and-events.lisp @@ -106,7 +106,8 @@ :texture (ww::get-asset "Fezghoul.png"))) (bm2 (make-instance 'ww::image - :texture (ww::get-asset "GelatinousCube.png")))) + :texture (ww::get-asset "GelatinousCube.png") + :alpha 0.5))) (ww::add-handler app #'wheelie) diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp deleted file mode 100644 index edc9000..0000000 --- a/examples/02-moving-bitmp.lisp +++ /dev/null @@ -1,143 +0,0 @@ -;;; 01-image-transforms-and-events.lisp - -(defpackage #:ww.examples/2 - (:use #:cl) - (:export #:start)) - -(in-package :ww.examples/2) - -(defclass image-transforms-etc (ww::application ) ()) - -(defvar *shared-anim-table* (make-hash-table :synchronized t)) - -(ww::defhandler move-thing - (ww::on-keydown () - "Move the target around, grow and shrink it. Print out its - position no matter what happens." - (case scancode - (:scancode-left (decf (ww::x target) 4)) - (:scancode-right (incf (ww::x target) 4)) - (:scancode-down (decf (ww::y target) 4)) - (:scancode-up (incf (ww::y target) 4)) - (:scancode-w (incf (ww::width target) 20)) - (:scancode-r (incf (ww::rotation target) (/ pi 3))) - (:scancode-l (decf (ww::rotation target) (/ pi 3))) - (:scancode-equals - (when (or (member :lshift modifiers) (member :rshift modifiers)) - (ww::scale-by target 1.10))) - (:scancode-minus - (ww::scale-by target 0.9))) - (format t "ghoul pos: ~a,~a~%" - (ww::x target) (ww::y target)))) - -(ww::defhandler animate-move-thing - (ww::on-keydown () - "If the target is not already involved in an animation, add a - perframe handler to the target that animates it to a new position." - (when (member scancode '(:scancode-left :scancode-right :scancode-down :scancode-up)) - (unless (gethash target *shared-anim-table*) - (setf (gethash target *shared-anim-table*) t) - (let* ((tx (ww::x target)) - (ty (ww::y target)) - (destx tx) - (desty ty) - (dx 0) - (dy 0)) - (case scancode - (:scancode-down (setf dy -1 desty (- ty (ww::height target)))) - (:scancode-up (setf dy 1 desty (+ ty (ww::height target)))) - (:scancode-left (setf dx -1 destx (- tx (ww::width target)))) - (:scancode-right (setf dx 1 destx (+ tx (ww::width target))))) - (ww::add-handler - target - (ww::on-perframe () - (with-accessors ((cx ww::x) (cy ww::y)) target - (if (and (= cx destx) (= cy desty)) - (progn - (remhash target *shared-anim-table*) - (ww::remove-handler target 'ww::perframe)) - (setf cx (+ cx dx) - cy (+ cy dy))))))))))) - - -(ww::defhandler thing-clicked - (ww::on-mousedown () - (format t "~a was clicked at ~a,~a!~%" target x y))) - -(ww::defhandler flip-on-click - (ww::on-mousedown () - (incf (ww::rotation target) (ww::radians 180) ))) - -(ww::defhandler twirl-on-click - (ww::on-mousedown () - (unless (gethash target *shared-anim-table*) - (let ((rot 0)) - (setf (gethash target *shared-anim-table*) t) - (ww::add-handler - target - (ww::on-perframe () - (if (< rot (* 8 pi)) - (setf rot (+ 0.3 rot) - (ww::rotation target) rot) - (progn - (setf (ww::rotation target) 0.0) - (ww::remove-handler target 'ww::perframe) - (remhash target *shared-anim-table*))))))))) - -(ww::defhandler mouse-over - (ww::on-mousemotion () - (print (list target x y xrel yrel state)))) - -(ww::defhandler look-at-me - (ww::on-focus () - (format t "~a got focus~%" target))) - -(ww::defhandler look-away - (ww::on-blur () - (format t "~a lost focus~%" target))) - -(ww::defhandler wheelie - (ww::on-mousewheel () - (print (list :mousewheel horiz vert dir)))) - -(defmethod ww::boot ((app image-transforms-etc)) - (let ((bm - (make-instance 'ww::image - :texture (ww::get-asset "Fezghoul.png"))) - (bm2 - (make-instance 'ww::image - :texture (ww::get-asset "GelatinousCube.png")))) - - (ww::add-handler app #'wheelie) - - ;; first - (ww::refocus-on bm) - (ww::add-handler bm #'animate-move-thing ) - (ww::add-handler bm #'thing-clicked) - (ww::add-handler bm #'mouse-over) - - ;;second - (setf (ww::x bm2) 90 - (ww::y bm2) 90) - (ww::add-handler bm2 #'move-thing) - (ww::add-handler bm2 #'twirl-on-click ) - (ww::add-handler bm2 #'look-at-me) - (ww::add-handler bm2 #'look-away) - (ww::add-handler bm2 #'wheelie) - - (ww::add-unit bm) - (ww::add-unit bm2))) - - -(defun start () - (ww::start (make-instance 'image-transforms-etc - :scale 2.0 - :fps 60 - :width 800 - :height 600 - :asset-root (merge-pathnames - "examples/" - (asdf:system-source-directory :wheelwork))))) - - - diff --git a/src/application.lisp b/src/application.lisp index 6869a56..3b531c9 100644 --- a/src/application.lisp +++ b/src/application.lisp @@ -116,7 +116,7 @@ those objects are currently part of the scene tree." (gl:clear :color-buffer-bit) (gl:enable :blend) (gl:blend-func :src-alpha :one-minus-src-alpha ) - (dolist (unit (application-scene app)) + (dolist (unit (reverse (application-scene app))) (render unit)) (sdl2:gl-swap-window (application-window app)) (sleep (frame-wait app))) diff --git a/src/interactive/image.lisp b/src/interactive/image.lisp index 1b3a817..644c06e 100644 --- a/src/interactive/image.lisp +++ b/src/interactive/image.lisp @@ -6,18 +6,9 @@ "Cached for later cleanup.") (defvar *image-vao* nil) -(defvar *image-count* 0 - "Used by finalizers to determin if the shader should be destroyed.") - -(defun image-finalizer () - "executed after a image has been reclaimed by gc. decrements image -count and destroys shader-program if necessary." - (decf *image-count*) - (unless (plusp *image-count*) - )) - (defclass/std image (unit interactive) - ((texture :ri :std (error "A image requires a texture.")))) + ((texture :ri :std (error "A image requires a texture.")) + (alpha :std 1.0))) (defun make-shared-image-gpu-objects () (unless *image-shader-program* @@ -31,8 +22,10 @@ count and destroys shader-program if necessary." vert))) ;color '(:fragment ((tc :vec2)) - ((tex :sampler-2d)) + ((tex :sampler-2d) + (alpha :float)) ((let ((frag (vari:texture tex tc))) + (setf (aref frag 3) (vari:clamp 0 (* alpha (aref frag 3)) 1)) (if (< (aref frag 3) 0.01) (vari:discard) frag)))))) @@ -77,7 +70,7 @@ count and destroys shader-program if necessary." (make-shared-image-gpu-objects))) (defmethod render ((image image)) - (with-slots (texture) image + (with-slots (texture alpha) image (gl:active-texture 0) (gl:bind-texture :texture-2d (texture-id texture)) (gl:use-program *image-shader-program*) @@ -85,6 +78,10 @@ count and destroys shader-program if necessary." *image-shader-program* (gl:get-uniform-location *image-shader-program* "TRANSFORM") (projected-matrix image)) + (gl:program-uniformf + *image-shader-program* + (gl:get-uniform-location *image-shader-program* "ALPHA") + alpha) (gl:bind-vertex-array *image-vao*) (gl:draw-arrays :triangles 0 6) (gl:bind-vertex-array 0))) -- cgit v1.2.3