diff options
| -rw-r--r-- | examples/04-a-button.lisp | 33 | ||||
| -rw-r--r-- | src/core/affine.lisp | 8 | ||||
| -rw-r--r-- | src/interactive/button.lisp | 109 | ||||
| -rw-r--r-- | src/protocol.lisp | 3 |
4 files changed, 146 insertions, 7 deletions
diff --git a/examples/04-a-button.lisp b/examples/04-a-button.lisp new file mode 100644 index 0000000..85d2e83 --- /dev/null +++ b/examples/04-a-button.lisp @@ -0,0 +1,33 @@ +;;;; examples/04-a-button.lisp + +(defpackage #:ww.example/4 + (:use #:cl) + (:export #:start)) + +(in-package #:ww.example/4) + +(defclass app-with-buttons (ww::application) ()) + +(defmethod ww::boot ((app app-with-buttons)) + (let ((b + (ww::make-texture-button + "Fezghoul.png" "GelatinousCube.png" + :pressed (lambda (button) (format t "Button ~a was clicked!~%" button)) + :released (lambda (button) (format t "Button ~a was relased!~%" button ))))) + (setf (ww::x b) 100 + (ww::y b) 100) + + (ww::scale-by b 4.0) + + (ww::add-unit app b))) + +(defun start () + (ww::start (make-instance + 'app-with-buttons + :fps 30 + :width 800 + :height 600 + :title "Wheelwork Example: A Button" + :asset-root (merge-pathnames + "examples/" + (asdf:system-source-directory :wheelwork))))) diff --git a/src/core/affine.lisp b/src/core/affine.lisp index 4585a81..7c87d16 100644 --- a/src/core/affine.lisp +++ b/src/core/affine.lisp @@ -17,10 +17,10 @@ -(defmethod scale-by ((affine affine) amount) - (with-slots (scale-x scale-y) affine - (setf scale-x (* amount scale-x) - scale-y (* amount scale-y)))) +(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)))) diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp new file mode 100644 index 0000000..56d2267 --- /dev/null +++ b/src/interactive/button.lisp @@ -0,0 +1,109 @@ +;;;; button.lisp + +(in-package #:wheelwork) + +(defclass/std button (unit interactive) + ((up down :with + :std (error "UP and DOWN lots are required") + :doc "Any affine renderable unit") + () + (on-press on-release :doc "Function accepting the button.")) + (:documentation "A basic button class. The UP and DOWN slots should + be filled with renderable objects having the same size.")) + +(defhandler button-released + (on-mouseup () + (with-slots (up down on-release) target + (setf (unit-visiblep up) t + (unit-visiblep down) nil) + (when on-release + (funcall on-release target))))) + +(defhandler button-pressed + (on-mousedown () + (with-slots (up down on-press) target + (setf (unit-visiblep up) nil + (unit-visiblep down) t) + (when on-press + (funcall on-press target))))) + +(defmethod initialize-instance :after ((button button) &key) + (add-handler button #'button-pressed) + (add-handler button #'button-released) + (with-slots (up down) button + (setf (unit-visiblep down) nil + (unit-visiblep up) t + (unit-container up) button + (unit-container down) button))) + +(defmethod cleanup ((button button)) + (with-slots (up down) button + (cleanup up) + (cleanup down))) + +(defmethod render ((button button)) + (with-slots (up down) button + (if (unit-visiblep up) + (render up) + (render down)))) + +(defmethod x ((button button)) + (x (button-up button))) + +(defmethod (setf x) (newval (button button)) + (setf (x (button-up button)) newval + (x (button-down button)) newval)) + +(defmethod y ((button button)) + (y (button-up button))) + +(defmethod (setf y) (newval (button button)) + (setf (y (button-up button)) newval + (y (button-down button)) newval)) + +(defmethod scale-x ((thing button)) + (scale-x (button-up thing))) + +(defmethod (setf scale-x) (newval (thing button)) + (setf (scale-x (button-up thing)) newval + (scale-x (button-down thing)) newval)) + +(defmethod scale-y ((thing button)) + (scale-y (button-up thing))) + +(defmethod (setf scale-y) (newval (thing button)) + (setf (scale-y (button-up thing)) newval + (scale-y (button-down thing)) newval)) + +(defmethod rotation ((thing button)) + (rotation (button-up thing))) + +(defmethod (setf rotation) (newval (thing button)) + (setf (rotation (button-up thing)) newval + (rotation (button-down thing)) newval)) + + +(defmethod width ((thing button)) + (width (button-up thing))) + +(defmethod (setf width) (newval (thing button)) + (setf (width (button-up thing)) newval + (width (button-down thing)) newval)) + +(defmethod height ((thing button)) + (height (button-up thing))) + +(defmethod (setf height) (newval (thing button)) + (setf (height (button-up thing)) newval + (height (button-down thing)) newval)) + + + +(defun make-texture-button (up down &key pressed released) + "UP and DOWN should be strings naming assets to use as the up and + down images for the button." + (make-instance + 'button + :on-press pressed :on-release released + :up (make-instance 'bitmap :texture (get-asset up)) + :down (make-instance 'bitmap :texture (get-asset down)))) diff --git a/src/protocol.lisp b/src/protocol.lisp index bd436e6..58120cd 100644 --- a/src/protocol.lisp +++ b/src/protocol.lisp @@ -34,9 +34,6 @@ (:documentation "Ensures that the asset is loaded into memory and ready for use. Returns the asset.")) -(defgeneric scale-by (thing amount) - (:documentation "Scale horizontal and vertical dimensions of THING by AMOUNT")) - (defgeneric width (thing) (:documentation "Returns the effective width, in screen coordinates, of the object in question")) |