From 2c1cb6075ea5cf3544491a89a544d2dfc6071567 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Thu, 30 Jun 2022 10:32:18 -0500 Subject: [add] text button example; button file to asd file --- examples/04-a-button.lisp | 23 +++++++---- src/interactive/button.lisp | 95 +++++++++++++++++++++++++++++++++------------ wheelwork.asd | 3 +- 3 files changed, 89 insertions(+), 32 deletions(-) diff --git a/examples/04-a-button.lisp b/examples/04-a-button.lisp index 85d2e83..be2ec24 100644 --- a/examples/04-a-button.lisp +++ b/examples/04-a-button.lisp @@ -9,16 +9,25 @@ (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 ))))) + (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)))) + (font + (ww::get-asset "Ticketing.ttf")) + (b2 + (ww::make-text-button font "Press Me" "Relase Me"))) (setf (ww::x b) 100 - (ww::y b) 100) + (ww::y b) 100 + (ww::x b2) 400 + (ww::y b2) 100) + (ww::scale-by b 4.0) - + (ww::scale-by b2 3) + + (ww::add-unit app b2) (ww::add-unit app b))) (defun start () diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp index 56d2267..1c546ba 100644 --- a/src/interactive/button.lisp +++ b/src/interactive/button.lisp @@ -6,7 +6,7 @@ ((up down :with :std (error "UP and DOWN lots are required") :doc "Any affine renderable unit") - () + (bg :with) (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.")) @@ -30,19 +30,24 @@ (defmethod initialize-instance :after ((button button) &key) (add-handler button #'button-pressed) (add-handler button #'button-released) - (with-slots (up down) button + (with-slots (up down bg) button + (when bg + (setf (unit-container bg) button + (unit-visiblep bg) t)) (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 + (with-slots (up down bg) button + (when bg (cleanup bg)) (cleanup up) (cleanup down))) (defmethod render ((button button)) - (with-slots (up down) button + (with-slots (up down bg) button + (when bg (render bg)) (if (unit-visiblep up) (render up) (render down)))) @@ -51,51 +56,72 @@ (x (button-up button))) (defmethod (setf x) (newval (button button)) - (setf (x (button-up button)) newval - (x (button-down button)) newval)) + (with-slots (up down bg) button + (when bg + (setf (x bg) newval)) + (setf (x up) newval + (x down) 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)) + (with-slots (up down bg) button + (when bg + (setf (y bg) newval)) + (setf (y up) newval + (y down) 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 (setf scale-x) (newval (button button)) + (with-slots (up down bg) button + (when bg + (setf (scale-x bg) newval)) + (setf (scale-x up) newval + (scale-x down) 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 (setf scale-y) (newval (button button)) + (with-slots (up down bg) button + (when bg + (setf (scale-y bg) newval)) + (setf (scale-y up) newval + (scale-y down) 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 (setf rotation) (newval (button button)) + (with-slots (up down bg) button + (when bg + (setf (rotation bg) newval)) + (setf (rotation up) newval + (rotation down) 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 (setf width) (newval (button button)) + (with-slots (up down bg) button + (when bg + (setf (width bg) newval)) + (setf (width up) newval + (width down) 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)) +(defmethod (setf height) (newval (button button)) + (with-slots (up down bg) button + (when bg + (setf (height bg) newval)) + (setf (height up) newval + (height down) newval))) @@ -107,3 +133,24 @@ :on-press pressed :on-release released :up (make-instance 'bitmap :texture (get-asset up)) :down (make-instance 'bitmap :texture (get-asset down)))) + +(defun make-text-button + (font up down + &key + pressed released + down-font + (up-color #(1.0 1.0 1.0 1.0)) + (down-color #(1.0 1.0 1.0 1.0))) + (make-instance + 'button + :on-release released :on-press pressed + :up (make-instance + 'text + :content up + :color up-color + :font font) + :down (make-instance + 'text + :content down + :color down-color + :font (or down-font font)))) diff --git a/wheelwork.asd b/wheelwork.asd index 47873c5..3d37472 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -39,6 +39,7 @@ (:module "interactive" :components ((:file "interactive") (:file "bitmap") - (:file "text"))) + (:file "text") + (:file "button"))) (:file "application") (:file "wheelwork"))) -- cgit v1.2.3