aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-06-30 10:32:18 -0500
committerColin Okay <colin@cicadas.surf>2022-06-30 10:32:18 -0500
commit2c1cb6075ea5cf3544491a89a544d2dfc6071567 (patch)
tree5e9a2dc188277964cfbd1c99db297fda64b99127
parent749a5a306deacd5c481ecc4c53b7f03178c3e335 (diff)
[add] text button example; button file to asd file
-rw-r--r--examples/04-a-button.lisp23
-rw-r--r--src/interactive/button.lisp95
-rw-r--r--wheelwork.asd3
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")))