1 files changed, 113 insertions, 0 deletions
diff --git a/gui/button.lisp b/gui/button.lisp
new file mode 100644
index 0000000..7c94663
--- /dev/null
+++ b/gui/button.lisp
@@ -0,0 +1,113 @@
+;;;; 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")
+   (bg :with)
+   (on-press on-release :with :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 (setf closer-mop:slot-value-using-class) :before
+    (newval class (button button) slot)
+  (let ((slot-name
+          (closer-mop:slot-definition-name slot))) 
+    (case slot-name 
+      ((up down bg)
+       (when (slot-boundp button slot-name) 
+         (error "Swapping Button Faces Not Presently Supported"))))))
+
+(defmethod initialize-instance :after ((button button) &key)
+  (add-handler button #'button-pressed)
+  (add-handler button #'button-released)
+  (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 bg) button
+    (when bg (cleanup bg))
+    (cleanup up)
+    (cleanup down)))
+
+(defmethod render ((button button))
+  (with-slots (up down bg) button
+    (when bg   (render bg))
+    (if (unit-visiblep up)
+        (render up)
+        (render down))))
+
+(macrolet
+    ((def-accessors (&rest accessor-names)
+       (let ((defs 
+               (loop for accessor-name in accessor-names
+                     collect 
+                     `(defmethod ,accessor-name ((button button))
+                        (,accessor-name (button-up button)))
+
+                     collect
+                     `(defmethod (setf ,accessor-name) (newval (button button))
+                        (setf (,accessor-name (button-up button)) newval
+                              (,accessor-name (button-down button)) newval)
+                        (when (button-bg button)
+                          (setf (,accessor-name (button-bg button)) newval))))))
+         `(progn ,@defs))))
+
+  (def-accessors x y scale-x scale-y width height rotation))
+
+(defmethod get-rect ((button button))
+  (get-rect (button-up button)))
+
+(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 'image :texture (get-asset up))
+   :down (make-instance 'image :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))))