aboutsummaryrefslogtreecommitdiffhomepage
path: root/gui/button.lisp
blob: 7c946639edcab2f2880042e41fdb05aeaf846f12 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
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))))