[add] button unit and [example]; [modify] scale-by is now defun

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"))