alloy/component.lisp at master · Shirakumo/alloy · GitHub

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
(in-package #:org.shirakumo.alloy)

(defclass component (observable layout-element focus-element renderable)
  ((data :initarg :data :initform (arg! :data) :accessor data)
   (tooltip :initarg :tooltip :initform NIL :accessor tooltip)
   (%tooltip :initform NIL :accessor %tooltip)))

(defmethod print-object ((element component) stream)
  (print-unreadable-object (element stream :type T :identity T)
    (format stream " ~a~@[ focus ~a~]" (bounds element) (focus element))))

(defmethod handle ((event pointer-down) (component component))
  (unless (and (slot-boundp component 'focus-parent)
               (contained-p (location event) component))
    (call-next-method)))

(defmethod handle ((event pointer-up) (component component))
  (if (and (slot-boundp component 'focus-parent)
           (contained-p (location event) component)
           (eql :left (kind event)))
      (activate component)
      (call-next-method)))

(defmethod set-layout-tree :after ((none null) (component component))
  (when (%tooltip component)
    (leave (%tooltip component) T)
    (setf (%tooltip component) NIL)))

(defmethod handle ((event pointer-move) (component component))
  (cond ((and (slot-boundp component 'focus-parent)
              (contained-p (location event) component))
         (when (eql NIL (focus component))
           (setf (focus (focus-parent component)) :strong)
           (setf (focus component) :weak))
         (when (tooltip component)
           (unless (%tooltip component)
             (setf (%tooltip component) (make-instance 'tooltip :component component))
             (enter (%tooltip component) (ui component)))
           (let ((size (suggest-size (size 20 20) (%tooltip component)))
                 (margin 15))
             (update (%tooltip component) (ui component)
                     :x (max (min (+ (pxx (location event)) margin)
                                  (- (pxw (ui component)) (pxw size)))
                             0)
                     :y (max (min (- (pxy (location event)) (pxh size) margin)
                                  (- (pxh (ui component)) (pxh size)))
                             0)
                     :w (w size)
                     :h (h size)))))
        (T
         (when (%tooltip component)
           (leave (%tooltip component) T)
           (setf (%tooltip component) NIL))
         (call-next-method))))

(defmethod maybe-render ((renderer renderer) (component component)))

(defmethod (setf data) :after (value (component component))
  (mark-for-render component))

(defmethod (setf focus) :after (value (component component))
  (when (and value (layout-tree component))
    (ensure-visible component T))
  (mark-for-render component))

(defmethod (setf bounds) :after (value (component component))
  (mark-for-render component))

(make-observable '(setf focus) '(focus observable))
(make-observable '(setf bounds) '(bounds observable))
;(make-observable 'handle '(event observable))
(make-observable 'activate '(observable))
(make-observable 'exit '(observable))

(defgeneric component-class-for-object (data))
(defgeneric represent-with (component-type data &rest initargs))
(defgeneric represent-for (component data &rest initargs))

(defmacro represent (place type &rest initargs)
  `(represent-with ,type
                   ,(expand-place-data place)
                   ,@initargs))

(defmethod represent-with ((type (eql T)) (data data) &rest initargs)
  (let ((class (component-class-for-object (value data))))
    (apply #'represent-with class data initargs)))

(defmethod represent-with ((class class) data &rest initargs)
  (apply #'make-instance class :data data initargs))

(defmethod represent-with ((name symbol) data &rest initargs)
  (apply #'represent-with (find-class name) data initargs))

(defmethod leave ((component component) (parent (eql T)))
  (when (slot-boundp component 'layout-parent)
    (leave component (layout-parent component)))
  (when (slot-boundp component 'focus-parent)
    (leave component (focus-parent component))))