1 files changed, 71 insertions, 24 deletions

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