diff options
29 files changed, 176 insertions, 366 deletions
diff --git a/examples/01-click-and-drag-image.lisp b/examples/01-click-and-drag-image.lisp index 8793fae..e895d24 100644 --- a/examples/01-click-and-drag-image.lisp +++ b/examples/01-click-and-drag-image.lisp @@ -11,14 +11,14 @@ (ww::defhandler dragging-unit (ww::on-mousemotion (app x y) (let ((unit - (first (ww:container-units app)))) + (first (ww::application-scene app)))) (setf (ww:x unit) x (ww:y unit) y)))) (ww:defhandler start-drag (ww:on-mousedown (target) (ww::add-handler - (ww::unit-container target) + ww::*application* #'dragging-unit))) (ww:defhandler stop-drag @@ -33,7 +33,7 @@ (describe (ww::model-matrix bm)) (describe bm) (describe app) - (ww::add-unit app bm) + (ww::add-unit bm) (ww::add-handler bm #'start-drag) (ww::add-handler app #'stop-drag) (format t "CLICK AND DRAG THE GHOUL~%") diff --git a/examples/02-image-transforms-and-events.lisp b/examples/02-image-transforms-and-events.lisp index bb348a1..edc9000 100644 --- a/examples/02-image-transforms-and-events.lisp +++ b/examples/02-image-transforms-and-events.lisp @@ -125,8 +125,8 @@ (ww::add-handler bm2 #'look-away) (ww::add-handler bm2 #'wheelie) - (ww::add-unit app bm) - (ww::add-unit app bm2))) + (ww::add-unit bm) + (ww::add-unit bm2))) (defun start () diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp index bb348a1..edc9000 100644 --- a/examples/02-moving-bitmp.lisp +++ b/examples/02-moving-bitmp.lisp @@ -125,8 +125,8 @@ (ww::add-handler bm2 #'look-away) (ww::add-handler bm2 #'wheelie) - (ww::add-unit app bm) - (ww::add-unit app bm2))) + (ww::add-unit bm) + (ww::add-unit bm2))) (defun start () diff --git a/examples/03-font-render.lisp b/examples/03-font-render.lisp index c8188df..de3c487 100644 --- a/examples/03-font-render.lisp +++ b/examples/03-font-render.lisp @@ -68,12 +68,12 @@ (ww::add-handler hello #'change-text-color) (ww::add-handler hello #'twirl-on-click) (ww::refocus-on hello) - (ww::add-unit app hello) + (ww::add-unit hello) (ww::scale-by instructions 2.0) (setf (ww::x instructions) (* 0.5 (- 800 (ww::width instructions)))) - (ww::add-unit app instructions))) + (ww::add-unit instructions))) (defun start () diff --git a/examples/04-a-button.lisp b/examples/04-a-button.lisp index b96364e..82f5a2c 100644 --- a/examples/04-a-button.lisp +++ b/examples/04-a-button.lisp @@ -26,8 +26,8 @@ (ww::scale-by b 4.0) (ww::scale-by b2 3) ;; add to scene - (ww::add-unit app b2) - (ww::add-unit app b))) + (ww::add-unit b2) + (ww::add-unit b))) (defun start () (ww::start (make-instance diff --git a/examples/05-frameset-animation.lisp b/examples/05-frameset-animation.lisp index 12207f3..a359f77 100644 --- a/examples/05-frameset-animation.lisp +++ b/examples/05-frameset-animation.lisp @@ -27,7 +27,7 @@ (ww::add-handler fs #'toggle-on-click) - (ww::add-unit app fs))) + (ww::add-unit fs))) (defun start () diff --git a/examples/06-sprite.lisp b/examples/06-sprite.lisp index abb5043..256ee95 100644 --- a/examples/06-sprite.lisp +++ b/examples/06-sprite.lisp @@ -115,7 +115,7 @@ (ww::add-handler dude #'stand) (ww::add-handler dude #'speed-control) (ww::refocus-on dude) - (ww::add-unit app dude))) + (ww::add-unit dude))) (defun start () (ww::start (make-instance diff --git a/examples/07-renderarea.lisp b/examples/07-renderarea.lisp index 95a6e9d..5fc6f0e 100644 --- a/examples/07-renderarea.lisp +++ b/examples/07-renderarea.lisp @@ -33,27 +33,20 @@ (let ((cube (make-instance 'ww::image - :texture (ww::get-asset "GelatinousCube.png"))) - (cube-container - (make-instance - 'ww::container - :bottom 200 :top 400 - :left 200 :right 600))) + :texture (ww::get-asset "GelatinousCube.png")))) (setf (cube app) cube) (ww::add-handler app #'move-cube) (ww::add-handler cube #'clicked) - (setf (ww::x cube) 400 (ww::y cube) 300) (ww::scale-by cube 2.0) - (ww::add-unit cube-container cube) - (ww::add-unit app cube-container) - - (describe cube-container))) + (ww::add-unit cube) + (setf (ww::unit-region cube) + (make-instance 'ww::region :bottom 200 :top 400 :left 200 :right 600)))) (defun start () diff --git a/examples/08-pong.lisp b/examples/08-pong.lisp index f40e66d..574eacd 100644 --- a/examples/08-pong.lisp +++ b/examples/08-pong.lisp @@ -163,9 +163,9 @@ on which boundary VAL is outside of." (ball app) ball (game-over app) game-over) - (ww::add-unit app ball) - (ww::add-unit app paddle) - (ww::add-unit app game-over) + (ww::add-unit ball) + (ww::add-unit paddle) + (ww::add-unit game-over) (ww::add-handler app #'pong-mousemove) (ww::add-handler app #'pong-perframe)))) @@ -183,7 +183,7 @@ on which boundary VAL is outside of." :scale-x 3.0 :scale-y 3.0))) (setf (intro-text app) intro-text) - (ww:add-unit app intro-text)) + (ww:add-unit intro-text)) (ww:add-handler app #'press-to-start)) (defun start () diff --git a/examples/09-ghoulspree.lisp b/examples/09-ghoulspree.lisp index cf18e31..b3c0106 100644 --- a/examples/09-ghoulspree.lisp +++ b/examples/09-ghoulspree.lisp @@ -80,7 +80,7 @@ on which boundary VAL is outside of." ;; first handle collisions (when (collision-on-p app) (with-pairs - (g1 g2) (ww:container-units app) + (g1 g2) (ww::application-scene app) (when (ww:units-intersect-p g1 g2) (handle-collision g1 g2 1.0) ;; need a "bounce" @@ -93,7 +93,7 @@ on which boundary VAL is outside of." (gravity-on-p app)) (accelleration (/ 9.8 (ww:fps app)))) - (loop for ghoul in (ww:container-units app) + (loop for ghoul in (ww::application-scene app) do (advance-pos ghoul) when gravity do (apply-gravity-to ghoul accelleration) @@ -111,9 +111,9 @@ on which boundary VAL is outside of." (loop repeat (ghouls-per-click app) for rx = (random 800); (+ x (* (random-sign) (random-between 30 60))) for ry = (random 600); (+ y (* (random-sign) (random-between 30 60))) - do (ww:add-unit app (make-ghoul rx ry))) + do (ww:add-unit (make-ghoul rx ry))) (format t "~a ghouls on screen~%" - (length (ww:container-units app ))))) + (length (ww::application-scene app ))))) (ww:defhandler toggle-collision diff --git a/examples/10-canvas-sneks.lisp b/examples/10-canvas-sneks.lisp index a69b429..ef5d1d5 100644 --- a/examples/10-canvas-sneks.lisp +++ b/examples/10-canvas-sneks.lisp @@ -111,7 +111,7 @@ sneks. Adds the canvas to the app, and sets up the perframe handler." (loop repeat (population app) collect (random-snek 100 100))) (setf (ww:width (snek-pit app)) (ww::application-width app) (ww:height (snek-pit app)) (ww::application-width app)) - (ww::add-unit app (snek-pit app)) + (ww::add-unit (snek-pit app)) (ww:add-handler app #'sneks-a-go-go)) (defun start (&key (side 800) (population 50)) diff --git a/examples/11-canvas-geometry.lisp b/examples/11-canvas-geometry.lisp index c144c10..9f781a8 100644 --- a/examples/11-canvas-geometry.lisp +++ b/examples/11-canvas-geometry.lisp @@ -73,7 +73,7 @@ (ww:height canvas) (ww::application-height app)) ;; add it to the display tree - (ww:add-unit app canvas) + (ww:add-unit canvas) ;; handlers (ww::add-handler canvas #'clear-and-draw) diff --git a/examples/12-canvas-drawing-language.lisp b/examples/12-canvas-drawing-language.lisp index 0713d90..a727f7b 100644 --- a/examples/12-canvas-drawing-language.lisp +++ b/examples/12-canvas-drawing-language.lisp @@ -104,7 +104,7 @@ (ww:height canvas) (ww::application-height app)) ;; add it to the display tree - (ww:add-unit app canvas) + (ww:add-unit canvas) ;; handlers (ww:add-handler canvas #'clear-and-draw) diff --git a/src/application.lisp b/src/application.lisp index ef5e92f..ea37525 100644 --- a/src/application.lisp +++ b/src/application.lisp @@ -2,8 +2,7 @@ (in-package #:wheelwork) - -(defclass/std application (container interactive) +(defclass/std application (region interactive) ((title :with :ri :std "Wheelwork App") (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") (asset-classifiers @@ -28,7 +27,7 @@ :doc "determines whether the search for event handlers stops at the first visible unit under the xy position of the mouse or not. ") - (focus last-motion-target :with :a) + (scene focus last-motion-target :with :a) (fps :std 30 :doc "Frames Per Second") (frame-wait :r)) (:documentation "The application contains the information and data @@ -56,8 +55,6 @@ top (/ height scale) right (/ width scale)))) - - (defun fire-blur-event-on (thing) (when-let (blur-handlers (and thing (get-handlers-for thing 'blur))) (dolist (handler blur-handlers) @@ -97,7 +94,9 @@ (let ((listener (listener app))) (dolist (table +listener-table-slot-names+) (setf (slot-value listener table) (make-hash-table :synchronized t)))) - (call-next-method) + (dolist (unit (application-scene app)) + (drop-unit unit) + (cleanup unit)) (trivial-garbage:gc :full t)) (defun run-perframe (app) @@ -108,7 +107,7 @@ those objects are currently part of the scene tree." (loop for target being the hash-key of table for handlers = (slot-value (listener target) 'perframe) ;; only fire perframe when target is in scene - when (or (eq app target) (unit-container target)) + when (or (eq app target) (unit-in-scene-p target)) do (loop for handler in handlers do (funcall handler target time))))) (defmethod render ((app application)) @@ -118,6 +117,8 @@ 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 ) - (call-next-method) + (dolist (unit (application-scene app)) + (render unit)) (sdl2:gl-swap-window (application-window app)) (sleep (frame-wait app))) + diff --git a/src/core/affine.lisp b/src/core/affine.lisp deleted file mode 100644 index 671c184..0000000 --- a/src/core/affine.lisp +++ /dev/null @@ -1,92 +0,0 @@ -;;;; affine.lisp - -(in-package #:wheelwork) - -(defclass/std affine (unit) - ((cached-model cached-projected-matrix cached-application cached-rectangle :a) - (base-width base-height :r :std 1.0 :doc "Determined by content.") - (scale-x scale-y :std 1.0) - (rotation x y :std 0.0))) - -(defmethod (setf closer-mop:slot-value-using-class) :after - (newval class (affine affine) slot) - (case (closer-mop:slot-definition-name slot) - ((x y scale-x scale-y rotation) - (setf (cached-model affine) nil - (cached-projected-matrix affine) nil - (cached-rectangle affine) nil)))) - -(defun scale-by (affine amount) - (with-accessors ((sx scale-x) (sy scale-y)) affine - (setf sx (* amount sx) - sy (* amount sy)))) - -(defun set-width-preserve-aspect (affine new-width) - (scale-by affine (/ new-width (width affine)))) - -(defun set-height-preserve-aspect (affine new-height) - (scale-by affine (/ new-height (height affine) ))) - -(defmethod width ((affine affine)) - (with-slots (scale-x base-width) affine - (* scale-x base-width))) - -(defmethod height ((affine affine)) - (with-slots (scale-y base-height) affine - (* scale-y base-height))) - -(defmethod (setf width) (newval (affine affine)) - (with-slots (scale-x base-width) affine - (setf scale-x (coerce (/ newval base-width) 'single-float)))) - -(defmethod (setf height) (newval (affine affine)) - (with-slots (scale-y base-height) affine - (setf scale-y (coerce (/ newval base-height) 'single-float)))) - -(defmethod model-matrix :around ((u affine)) - (or (cached-model u) - (setf (cached-model u) - (call-next-method)))) - -(defmethod model-matrix ((u affine)) - (let ((m (mat:meye 4))) - (with-slots (x y base-width scale-x base-height scale-y rotation) u - (let ((uw (* base-width scale-x)) - (uh (* base-height scale-y))) - (mat:nmtranslate m (vec:vec x y 0.0)) - - (mat:nmtranslate m (vec:v* 0.5 (vec:vec uw uh 0.0))) - (mat:nmrotate m vec:+vz+ rotation) - (mat:nmtranslate m (vec:v* -0.5 (vec:vec uw uh 0.0))) - - (mat:nmscale m (vec:vec uw uh 1.0)))) - m)) - - -(defun projected-matrix (affine) - (or (cached-projected-matrix affine) - (setf (cached-projected-matrix affine) - (mat:marr (mat:m* (application-projection (app-of-unit affine)) - (model-matrix affine)))))) - -(defmethod get-rect ((affine-unit affine)) - (or (cached-rectangle affine-unit) - (setf (cached-rectangle affine-unit) - (with-accessors ((x x) (y y) (w width) (h height) (r rotation)) affine-unit - (let ((m - (mat:meye 4)) - (tr - (vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0))) - (mat:nmtranslate m tr) - (mat:nmrotate m vec:+vz+ r) - (mat:nmtranslate m (vec:v* -1.0 tr)) - - (list (mat:m* m (vec:vec x y 0.0 1.0)) - (mat:m* m (vec:vec x (+ y h) 0.0 1.0)) - (mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0)) - (mat:m* m (vec:vec (+ x w) y 0.0 1.0)) - (mat:m* m (vec:vec x y 0.0 1.0)))))))) - -(defun units-intersect-p (au1 au2) - "Returns T if the two units AU1 an AU2 intersect. Both must implement GET-RECT." - (paths-intersect-p (get-rect au1) (get-rect au2))) diff --git a/src/core/container.lisp b/src/core/container.lisp deleted file mode 100644 index a9e6caf..0000000 --- a/src/core/container.lisp +++ /dev/null @@ -1,81 +0,0 @@ -;;;; units/container.lisp - -(in-package #:wheelwork) - - -(defclass/std container (unit) - ((units :with :a) - (cached-rect :with) - (left right top bottom :with :std 0 :doc "container's box coordinates.")) - (:documentation "Just a list of units. Made into a class so that - transformation affine transformations methods can be specialzied on - whole groups of units")) - -(defmethod (setf closer-mop:slot-value-using-class) - (newval class (container container) slot) - (case (closer-mop:slot-definition-name slot) - ((left right top bottom) - (setf (container-cached-rect container) nil)))) - -(defmethod get-rect ((container container)) - (with-slots (cached-rect left right top bottom) container - (or cached-rect - (setf cached-rect - (list (vec:vec left bottom 0 1.0) - (vec:vec left top 0 1.0) - (vec:vec right top 0 1.0) - (vec:vec right bottom 0 1.0) - (vec:vec left bottom 0 1.0)))))) - - -(defun point-in-contanier-box-p (c x y) - "Returns T if the ponit X Y is inside the bounds of the container." - (and (<= (container-left c) x (container-right c)) - (<= (container-bottom c) y (container-top c)))) - -(defun visible-in-container-p (unit) - "Returns T if UNIT is VISIBLEP, if it is inside a CONTAINER, if any - of the corners of its bounding rectangle are inside that CONTAINER. - - UNIT must implement the affine protocol." - (when (unit-visiblep unit) - (when-let ((container - (unit-container unit))) - (loop for pt in (get-rect unit) - thereis (point-in-contanier-box-p container (vec:vx pt) (vec:vy pt)))))) - -(defmethod drop-unit ((unit unit)) - "Removes a unit from its container. Returns T if the unit actually was removed." - (when-let (container (unit-container unit)) - (setf - (container-units container) (delete unit (container-units container)) - (unit-container unit) nil) - t)) - -(defmethod add-unit ((container container) (unit unit)) - "Adds a unit to the end of a container (thus affecting render -order). Also removes the unit from its current container if -necessary." - (when (unit-container unit) - (drop-unit unit)) - (push unit (container-units container)) - (setf (unit-container unit) container) - unit) - -(defmethod cleanup ((container container)) - (dolist (u (container-units container)) - (cleanup u))) - -(defmethod render ((container container)) - (let ((current - (gl:get* :scissor-box)) - (scale - (application-scale - (app-of-unit container)))) - (with-slots (left right top bottom) container - (gl:scissor (* left scale) (* scale bottom) (* scale (- right left)) (* scale (- top bottom))) - (unwind-protect - (dolist (u (reverse (container-units container))) - (if (visible-in-container-p u) - (render u))) - (gl:scissor (aref current 0) (aref current 1) (aref current 2) (aref current 3)))))) diff --git a/src/core/unit.lisp b/src/core/unit.lisp index e93ba56..e56c01f 100644 --- a/src/core/unit.lisp +++ b/src/core/unit.lisp @@ -1,33 +1,107 @@ -;;;; units/unit.lisp +;;;; unit.lisp (in-package #:wheelwork) (defclass/std unit () - ((cached-application :a) - (container :with :a) - (visiblep :with :std t))) + ((cached-model cached-projected-matrix cached-rectangle :a) + (visiblep :with :std t) + (in-scene-p :with :a :std nil) + (region :with :std *application* + :doc "The screen region where the unit will be visible.") + (base-width base-height :r :std 1.0 :doc "Determined by content.") + (scale-x scale-y :std 1.0) + (rotation x y :std 0.0))) + +(defmethod render :around ((unit unit)) + (when (unit-visiblep unit) + (let ((sb + (gl:get* :scissor-box)) + (scale + (application-scale *application*))) + (with-slots (left right top bottom) (unit-region unit) + (gl:scissor (* left scale) (* bottom scale) (* scale (- right left)) (* scale (- top bottom))) + (call-next-method)) + (gl:scissor (aref sb 0) (aref sb 1) (aref sb 2) (aref sb 3))))) (defmethod (setf closer-mop:slot-value-using-class) :after (newval class (unit unit) slot) (case (closer-mop:slot-definition-name slot) - (container - (setf (cached-application unit) nil)))) + ((x y scale-x scale-y rotation) + (setf (cached-model unit) nil + (cached-projected-matrix unit) nil + (cached-rectangle unit) nil)))) +(defun scale-by (unit amount) + (with-accessors ((sx scale-x) (sy scale-y)) unit + (setf sx (* amount sx) + sy (* amount sy)))) -(defun app-of-unit (unit) - "Returns the APPLICATION instance, if any, of which this UNIT is a -part. NIL indicates that the unit has not been added to any container -in this application." - (or (cached-application unit) - (setf (cached-application unit) - (labels ((rec (u) - (etypecase u - (application u) - (unit (rec (unit-container u))) - (nil nil)))) - (rec unit))))) +(defun set-width-preserve-aspect (unit new-width) + (scale-by unit (/ new-width (width unit)))) +(defun set-height-preserve-aspect (unit new-height) + (scale-by unit (/ new-height (height unit) ))) -(defmethod render :around ((unit unit)) - (when (unit-visiblep unit) - (call-next-method))) +(defmethod width ((unit unit)) + (with-slots (scale-x base-width) unit + (* scale-x base-width))) + +(defmethod height ((unit unit)) + (with-slots (scale-y base-height) unit + (* scale-y base-height))) + +(defmethod (setf width) (newval (unit unit)) + (with-slots (scale-x base-width) unit + (setf scale-x (coerce (/ newval base-width) 'single-float)))) + +(defmethod (setf height) (newval (unit unit)) + (with-slots (scale-y base-height) unit + (setf scale-y (coerce (/ newval base-height) 'single-float)))) + +(defmethod model-matrix :around ((u unit)) + (or (cached-model u) + (setf (cached-model u) + (call-next-method)))) + +(defmethod model-matrix ((u unit)) + (let ((m (mat:meye 4))) + (with-slots (x y base-width scale-x base-height scale-y rotation) u + (let ((uw (* base-width scale-x)) + (uh (* base-height scale-y))) + (mat:nmtranslate m (vec:vec x y 0.0)) + + (mat:nmtranslate m (vec:v* 0.5 (vec:vec uw uh 0.0))) + (mat:nmrotate m vec:+vz+ rotation) + (mat:nmtranslate m (vec:v* -0.5 (vec:vec uw uh 0.0))) + + (mat:nmscale m (vec:vec uw uh 1.0)))) + m)) + + +(defun projected-matrix (unit) + (or (cached-projected-matrix unit) + (setf (cached-projected-matrix unit) + (mat:marr (mat:m* (application-projection *application*) + (model-matrix unit)))))) + +(defmethod get-rect ((unit unit)) + (or (cached-rectangle unit) + (setf (cached-rectangle unit) + (with-accessors ((x x) (y y) (w width) (h height) (r rotation)) unit + (let ((m + (mat:meye 4)) + (tr + (vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0))) + (mat:nmtranslate m tr) + (mat:nmrotate m vec:+vz+ r) + (mat:nmtranslate m (vec:v* -1.0 tr)) + + (list (mat:m* m (vec:vec x y 0.0 1.0)) + (mat:m* m (vec:vec x (+ y h) 0.0 1.0)) + (mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0)) + (mat:m* m (vec:vec (+ x w) y 0.0 1.0)) + (mat:m* m (vec:vec x y 0.0 1.0)))))))) + +(defun units-intersect-p (au1 au2) + "Returns T if the two units AU1 an AU2 intersect. Both must implement GET-RECT." + (paths-intersect-p (get-rect au1) (get-rect au2))) diff --git a/src/events/event-handler.lisp b/src/events/event-handler.lisp index a7f1b1b..9d48aea 100644 --- a/src/events/event-handler.lisp +++ b/src/events/event-handler.lisp @@ -299,68 +299,3 @@ fires when the FOCUS slot of the current APPLICATION instance is changed. (declare (ignorable ,(intern (symbol-name target)))) ,@body))) - -(defmacro on-before-dropped - ((&optional (target 'target)) &body body) - "Creates a handler for BEFORE-DROPPED events, which fire before a - unit is removed from its container. - - All variable arguments supplied to this handler form are - optional. You may supply your own variables to use in your BODY or - you may just refer to the defaults - they will be interned in the - appropriate package. - -" - `(make-instance - 'event-handler - :event-type 'wheelwork::before-dropped - :handler-function (lambda - (,(intern (symbol-name target))) - (declare - (ignorable ,(intern (symbol-name target)))) - ,@body))) - -(defmacro on-before-added - ((&optional (target 'target) (container 'container)) &body body) - "Creates a handler for BEFORE-ADDED events, which fire before a unit - TARGET is added to CONTAINER. - - All variable arguments supplied to this handler form are - optional. You may supply your own variables to use in your BODY or - you may just refer to the defaults - they will be interned in the - appropriate package. -" - `(make-instance - 'event-handler - :event-type 'wheelwork::before-added - :handler-function (lambda - (,(intern (symbol-name container)) - ,(intern (symbol-name target))) - (declare - (ignorable - ,(intern (symbol-name container)) - ,(intern (symbol-name target)))) - ,@body))) - - -(defmacro on-after-added - ((&optional (target 'target) (container 'container)) &body body) - "Creates a handler for AFTER-ADDED events, which fire after a unit - is added to a container. - - All variable arguments supplied to this handler form are - optional. You may supply your own variables to use in your BODY or - you may just refer to the defaults - they will be interned in the - appropriate package. -" - `(make-instance - 'event-handler - :event-type 'wheelwork::after-added - :handler-function (lambda - (,(intern (symbol-name container)) - ,(intern (symbol-name target))) - (declare - (ignorable - ,(intern (symbol-name container)) - ,(intern (symbol-name target)))) - ,@body))) diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp index 7f24d89..aef8ebb 100644 --- a/src/interactive/canvas.lisp +++ b/src/interactive/canvas.lisp @@ -151,7 +151,7 @@ e.g., drawing a line in a particular color." (gl:bind-buffer :array-buffer 0) (gl:bind-vertex-array 0)) -(defclass/std canvas (affine interactive pixels) +(defclass/std canvas (unit interactive pixels) ((fbo :with :r :doc "framebuffer object for use in off-screen-rendering of this canvas to a texture") (texture :with :a :doc "texture instance"))) diff --git a/src/interactive/frameset.lisp b/src/interactive/frameset.lisp index 3ffbc18..25812f0 100644 --- a/src/interactive/frameset.lisp +++ b/src/interactive/frameset.lisp @@ -37,7 +37,7 @@ count (length sequence)) (loop for frame across frames when frame - do (setf (unit-container frame) fs)))) + do (setf (unit-in-scene-p frame) fs)))) (defun current-frame-unit (fs) "Returns the unit be currently displaayed as the animation's frame." diff --git a/src/interactive/image.lisp b/src/interactive/image.lisp index 7c84df3..0089f57 100644 --- a/src/interactive/image.lisp +++ b/src/interactive/image.lisp @@ -21,7 +21,7 @@ count and destroys shader-program if necessary." (gl:delete-program *image-shader-program*) (setf *image-shader-program* nil)))) -(defclass/std image (affine interactive) +(defclass/std image (unit interactive) ((texture :ri :std (error "A image requires a texture.")))) (defmethod initialize-instance :after ((image image) &key) diff --git a/src/interactive/interactive.lisp b/src/interactive/interactive.lisp index 83910c7..6152c3e 100644 --- a/src/interactive/interactive.lisp +++ b/src/interactive/interactive.lisp @@ -42,18 +42,3 @@ ON-* Macros." (remhash interactive (listener-table-for (listener interactive) event-type)))))) -(defmethod drop-unit :before ((unit interactive)) - (when (unit-container unit) - (when-let (handlers (get-handlers-for unit 'before-dropped)) - (dolist (handler handlers) - (funcall handler unit))))) - -(defmethod add-unit :before ((container container) (unit interactive)) - (when-let (handlers (get-handlers-for unit 'before-added)) - (dolist (handler handlers) - (funcall handler container unit)))) - -(defmethod add-unit :after ((container container) (unit interactive)) - (when-let (handlers (get-handlers-for unit 'after-added)) - (dolist (handler handlers) - (funcall handler container unit)))) diff --git a/src/interactive/sprite.lisp b/src/interactive/sprite.lisp index 22c6be4..68f8a8d 100644 --- a/src/interactive/sprite.lisp +++ b/src/interactive/sprite.lisp @@ -14,7 +14,7 @@ (defmethod initialize-instance :after ((sprite sprite) &key) (with-slots (framesets frameset-key) sprite (loop for (name fs . more) on framesets by #'cddr - do (setf (unit-container fs) sprite)) + do (setf (unit-in-scene-p fs) sprite)) (unless frameset-key (setf frameset-key (first framesets))))) diff --git a/src/interactive/text.lisp b/src/interactive/text.lisp index a7c0582..dd99653 100644 --- a/src/interactive/text.lisp +++ b/src/interactive/text.lisp @@ -2,7 +2,7 @@ (in-package #:wheelwork) -(defclass/std text (affine interactive) +(defclass/std text (unit interactive) ((font :with :ri :std (error "A font is required") :type font) (content :with :ri :std "") (color :with :std #(1.0 1.0 1.0 1.0)) diff --git a/src/package.lisp b/src/package.lisp index 8b9f07a..a93c8fc 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -42,12 +42,6 @@ ;; Display Tree Managmennt #:add-unit - #:container - #:container-bottom - #:container-left - #:container-right - #:container-top - #:container-units #:drop-unit ;; Event Handler API @@ -82,8 +76,8 @@ #:perframe ;; Generic and APIs - #:unit-container #:unit-visbilep + #:unit-in-scene- ;; Specific Unit Classes and APIs #:image diff --git a/src/protocol.lisp b/src/protocol.lisp index 002aad6..2bccb86 100644 --- a/src/protocol.lisp +++ b/src/protocol.lisp @@ -17,12 +17,6 @@ resources. Called after shutodown.") (:method ((any t)) nil)) -(defgeneric drop-unit (unit) - (:documentation "Removes a unit from a container.")) -(defgeneric add-unit (container unit) - (:documentation "Adds a unit to a container, removing it from its - current container first, if necessary.")) - (defgeneric render (thing) (:documentation "Renders thing for visual display.")) diff --git a/src/region.lisp b/src/region.lisp new file mode 100644 index 0000000..2355db6 --- /dev/null +++ b/src/region.lisp @@ -0,0 +1,6 @@ +;;;; region.lisp + +(in-package :wheelwork) + +(defclass/std region () + ((left bottom top right :with :std 0))) diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp index db49e03..4a20553 100644 --- a/src/wheelwork.lisp +++ b/src/wheelwork.lisp @@ -5,6 +5,17 @@ (defvar *application* nil "current application") +(defun add-unit (unit) + (assert *application*) + (push unit (application-scene *application*)) + (setf (unit-in-scene-p unit) t)) + +(defun drop-unit (unit) + (assert *application*) + (setf (application-scene *application*) + (delete unit (application-scene *application*))) + (setf (unit-in-scene-p unit) nil)) + (defun start (app &key (x :centered) (y :centered)) (sdl2:with-init (:everything) (sdl2:gl-set-attr :context-major-version 3) @@ -67,6 +78,12 @@ TARGET is FOCUSABLEP" (sdl2:scancode sdl-keysym) (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) + +(defun region-contains-point-p (region pt) + (with-slots (left right bottom top) region + (and (<= left (vec:vx pt) right) + (<= bottom (vec:vy pt) top)))) + (defun unit-contains-point-p (unit pt) (path-encloses-point-p (get-rect unit) pt)) @@ -79,40 +96,26 @@ position. The list always contains the app itself as the last element." (list app))) +(defun unit-visibly-contains-p (unit pt) + (and (unit-visiblep unit) + (region-contains-point-p (unit-region unit) pt) + (unit-contains-point-p unit pt))) + (defun unit-under (app x y) "Finds the visible unit that contains the point x y, returns it as a single elemtn list, or nil if none found" (let ((xy (vec:vec x y 0.0 1.0))) - (labels - ((finder (thing) - (when (unit-visiblep thing) - (etypecase thing - (container - (when (unit-contains-point-p thing xy) - (find-if #'finder (container-units thing) :from-end t))) - (unit - (when (unit-contains-point-p thing xy) - (return-from unit-under (list thing)))))))) - (finder app)))) + (loop for u in (application-scene app) + when (unit-visibly-contains-p u xy) + return (list u)))) (defun all-units-under (app x y) "Finds all units under the point x y" (let ((xy - (vec:vec x y 0.0 1.0)) - (units - nil)) - (labels - ((finder (thing) - (when (unit-visiblep thing) - (etypecase thing - (container - (when (unit-contains-point-p thing xy) - (mapc #'finder (container-units thing)))) - (unit - (when (unit-contains-point-p thing xy) - (push thing units))))))) - (finder app)) - units)) + (vec:vec x y 0.0 1.0))) + (loop for u in (application-scene app) + when (unit-visibly-contains-p u xy) + collect u))) (defvar *event-still-bubbling-p* nil "Controls whether an event is bubbling") diff --git a/wheelwork.asd b/wheelwork.asd index 8d12b84..6d578a1 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -4,7 +4,7 @@ :description "A sprite system for games and GUIs" :author "colin <colin@cicadas.surf>" :license "GPL-3.0" - :version "0.0.1" + :version "0.0.2" :serial t :depends-on (#:cl-opengl #:sdl2 @@ -20,6 +20,7 @@ (:file "protocol") (:file "utils") (:file "grid-geometry") + (:file "region") (:module "gl" :components ((:file "util") (:file "texture") @@ -29,9 +30,7 @@ (:file "png") (:file "font"))) (:module "core" - :components ((:file "unit") - (:file "container") - (:file "affine"))) + :components ((:file "unit"))) (:module "events" :components ((:file "event-handler") (:file "listener"))) @@ -39,7 +38,6 @@ :components ((:file "interactive") (:file "image") (:file "text") - (:file "frameset") (:file "sprite") (:file "canvas"))) |