-
-
Notifications
You must be signed in to change notification settings - Fork 12
/
clip-view.lisp
108 lines (96 loc) · 4.68 KB
/
clip-view.lisp
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
(in-package #:org.shirakumo.alloy)
(defclass clip-view (layout single-container observable)
((offset :initarg :offset :initform (px-point 0 0) :accessor offset)
(stretch :initarg :stretch :initform T :accessor stretch)
(limit :initarg :limit :initform NIL :accessor limit)))
(defmethod suggest-size (size (layout clip-view))
(if (inner layout)
(case (limit layout)
((NIL) size)
(:x (size (w (suggest-size size (inner layout))) (h size)))
(:y (size (w size) (h (suggest-size size (inner layout)))))
(T (suggest-size size (inner layout))))
size))
(defmethod notice-size ((element layout-element) (layout clip-view))
(refit layout))
(defun clamp-offset (offset layout)
(flet ((clamp (l x u)
(min (max l x) u)))
(let ((inner (inner layout)))
(if inner
(px-point (clamp (min 0 (- (pxw (bounds layout)) (pxw (bounds inner)))) (pxx offset) 0)
(clamp (min 0 (- (pxh (bounds layout)) (pxh (bounds inner)))) (pxy offset) 0))
offset))))
(defmethod (setf offset) :around ((offset point) (layout clip-view))
(let ((clamped (clamp-offset offset layout)))
(unless (and (/= (pxx clamped) (pxx (offset layout)))
(/= (pxy clamped) (pxy (offset layout))))
(prog1 (call-next-method clamped layout)
(notify-observers 'value layout clamped layout)))))
(defmethod clipped-p ((layout clip-view))
(with-unit-parent layout
(case (limit layout)
(:x (< (pxh (bounds layout)) (pxh (bounds (inner layout)))))
(:y (< (pxw (bounds layout)) (pxw (bounds (inner layout)))))
(T (or (< (pxh (bounds layout)) (pxh (bounds (inner layout))))
(< (pxw (bounds layout)) (pxw (bounds (inner layout)))))))))
(defmethod refit ((layout clip-view))
(when (inner layout)
(with-unit-parent layout
(let* ((bounds (bounds layout))
(ideal (suggest-size bounds (inner layout))))
(setf (bounds (inner layout)) (px-extent 0 0
(cond ((null (stretch layout)) (w ideal))
((eq :x (limit layout)) (w bounds))
(T (max (pxw ideal) (pxw bounds))))
(cond ((null (stretch layout)) (h ideal))
((eq :y (limit layout)) (h bounds))
(T (max (pxh ideal) (pxh bounds)))))))
;; Ensure we clamp the offset into valid bounds.
(setf (offset layout) (offset layout)))))
(defmethod (setf bounds) :after (bounds (layout clip-view))
(refit layout))
(defmethod compute-global-position ((element clip-view))
(with-unit-parent element
(let ((x 0f0) (y 0f0))
(loop for current = element then parent
for parent = (layout-parent current)
do (incf x (pxx (bounds current)))
(incf y (pxy (bounds current)))
(when (typep current 'clip-view)
(incf x (pxx (offset current)))
(incf y (pxy (offset current))))
until (eql current parent))
(values (- x (pxx (offset element)))
(- y (pxy (offset element)))))))
(defmethod handle ((event scroll) (layout clip-view))
(restart-case (call-next-method)
(decline ()
(let ((off (offset layout))
(dx (case (limit layout)
(:x 0.0)
(:y (if (= 0.0 (dx event)) (dy event) (dx event)))
(T (dx event))))
(dy (case (limit layout)
(:x (if (= 0.0 (dy event)) (dx event) (- (dy event))))
(:y 0.0)
(T (- (dy event))))))
(setf (offset layout) (px-point (+ (* (pxw layout) 0.1 dx) (pxx off))
(+ (* (pxh layout) 0.1 dy) (pxy off))))))))
(defmethod render ((renderer renderer) (layout clip-view))
(when (inner layout)
(constrain-visibility layout renderer)
(translate renderer (offset layout))
(render renderer (inner layout))))
(defmethod ensure-visible ((element layout-element) (layout clip-view))
(let* ((view (bounds layout))
(element (bounds element))
(vyb (- (pxy (offset layout))))
(vyt (- (pxh view) (pxy (offset layout)))))
;; FIXME: This does **not** work correctly for nested layouts.
;; KLUDGE: terrible kludge for Y only for now.
(cond ((< (pxy element) vyb)
(setf (offset layout) (px-point 0.0 (- (pxy element)))))
((< vyt (+ (pxy element) (pxh element)))
(setf (offset layout) (px-point 0.0 (- (pxh view) (pxy element) (pxh element)))))))
(call-next-method))