-
-
Notifications
You must be signed in to change notification settings - Fork 13
/
Copy pathui.lisp
132 lines (107 loc) · 4.4 KB
/
ui.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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
(in-package #:org.shirakumo.alloy)
;;; Provided by the backend
(defgeneric clipboard (ui))
(defgeneric (setf clipboard) (content ui))
;; Standard cursors: :ARROW :TEXT :HAND :CROSSHAIR :RESIZE :DISALLOWED
(defgeneric cursor (ui))
(defgeneric (setf cursor) (cursor ui))
(defgeneric key-text (key ui))
(defclass ui ()
((layout-tree :initarg :layout-tree :reader layout-tree)
(focus-tree :initarg :focus-tree :reader focus-tree)
;; 38dpcm corresponds to Windows' default 96dpi
(dots-per-cm :initform 38 :reader dots-per-cm)
(target-resolution :initarg :target-resolution :initform (px-size 1920 1080) :accessor target-resolution)
(resolution-scale :initform 1.0 :accessor resolution-scale)
(base-scale :initform 1.0 :accessor base-scale))
(:default-initargs
:layout-tree (make-instance 'layout-tree)
:focus-tree (make-instance 'focus-tree)))
(defmethod shared-initialize :after ((ui ui) slots &key base-scale)
(unless (slot-boundp (layout-tree ui) 'ui)
(setf (slot-value (layout-tree ui) 'ui) ui))
(when base-scale (setf (slot-value ui 'base-scale) (float base-scale 0f0))))
(defmethod w ((ui ui)) (w (layout-tree ui)))
(defmethod h ((ui ui)) (h (layout-tree ui)))
(defmethod clear ((ui ui))
(clear (layout-tree ui))
(clear (focus-tree ui)))
(defmethod focused ((ui ui))
(focused (focus-tree ui)))
(defmethod handle ((event direct-event) (ui ui))
(or (handle event (focus-tree ui))
(decline)))
(defmethod handle ((event layout-event) (ui ui))
(or (handle event (focus-tree ui))
(handle event (layout-tree ui))
(progn
(setf (cursor ui) :arrow)
(decline))))
(defmethod render ((renderer renderer) (ui ui))
(with-unit-parent ui
(render renderer (layout-tree ui))))
(defmethod maybe-render ((renderer renderer) (ui ui))
(with-unit-parent ui
(maybe-render renderer (layout-tree ui))))
(defmethod activate ((ui ui))
(mark-for-render (root (layout-tree ui))))
(defmethod bounds ((ui ui))
(bounds (root (layout-tree ui))))
(defmethod suggest-size (size (ui ui))
(suggest-size size (layout-tree ui)))
(defmethod register ((ui ui) renderer)
(register (layout-tree ui) renderer))
(defmethod deregister ((ui ui) renderer)
(deregister (layout-tree ui) renderer))
(defmethod (setf base-scale) (value (ui ui))
(setf (slot-value ui 'base-scale) (float value 0f0))
(handle (make-instance 'scale-changed) ui))
(defmethod (setf resolution-scale) (value (ui ui))
(setf (slot-value ui 'resolution-scale) (float value 0f0))
(handle (make-instance 'scale-changed) ui))
(defmethod (setf base-scale) :after (value (ui ui))
(suggest-size (bounds ui) ui))
(defmethod refresh ((ui ui))
(refresh (layout-tree ui)))
(defclass smooth-scaling-ui (ui)
())
(defmethod suggest-size (size (ui smooth-scaling-ui))
(let* ((target (target-resolution ui))
(wr (/ (pxw size) (pxw target)))
(hr (/ (pxh size) (pxh target))))
(setf (resolution-scale ui) (min wr hr)))
(call-next-method))
(defclass fixed-scaling-ui (ui)
((scales :initform '((T T 1.0)) :initarg :scales :accessor scales)))
(defmethod suggest-size (size (ui fixed-scaling-ui))
(setf (resolution-scale ui)
(loop for (w h scale) in (scales ui)
do (when (and (or (eql T w) (<= w (pxw size)))
(or (eql T h) (<= h (pxh size))))
(return scale))
finally (return 1.0)))
(call-next-method))
(defclass lock-step-scaling-ui (ui)
((scale-step :initform 0.5 :initarg :scale-step :accessor scale-step)
(scale-direction :initform :down :initarg :scale-direction :accessor scale-direction)))
(defmethod suggest-size (size (ui lock-step-scaling-ui))
(let ((target (target-resolution ui))
(step (scale-step ui)))
(flet ((factor (ratio)
(ecase (scale-direction ui)
(:down
(if (< step ratio)
(* step (floor ratio step))
(/ step (ceiling step ratio))))
(:closest
(if (< step ratio)
(* step (round ratio step))
(/ step (round step ratio))))
(:up
(if (< step ratio)
(* step (ceiling ratio step))
(/ step (floor step ratio)))))))
(let ((wr (factor (/ (pxw size) (pxw target))))
(hr (factor (/ (pxh size) (pxh target)))))
(setf (resolution-scale ui) (min wr hr)))))
(call-next-method))