blob: 4073a15c51bb16b766253d6803e5efa0a3fc7e26 (
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
114
115
116
117
118
119
120
121
122
123
124
125
|
;;;; application
(in-package #:wheelwork)
(defclass/std application (region interactive)
((title :with :ri :std "Wheelwork App")
(asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
(asset-classifiers
:std '(("png" png) ("ttf" font))
:doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.")
(assets :with :a :std (make-hash-table :test 'equal)
:doc "maps asset names to asset instances.")
(scale :with :std 1.0
:doc "Scale factor applied before all
rendering. Affects sizes of all object as well as the
coordinates of mouse events.")
(width height :with :std 800 :doc "Window dimensions in real pixels.")
(projection :with :a :doc "The projection matrix for the scene. Orthographic by default.")
(window :with :a)
(refocus-on-mousedown-p
:std t
:doc "When T, clicking on a visible object will set the
application focus to that object.")
(mouse-button-events-bubble-p
mouse-motion-events-bubble-p
:std nil
:doc "determines whether the search for event handlers stops at
the first visible unit under the xy position of the mouse or
not. ")
(scene focus last-motion-target :with :a)
(fps :std 30 :doc "Frames Per Second")
(frame-wait :r))
(:documentation "The application contains the information and data
structures necessary for creating a window, adding display units to
it, handling events, and loading resources. You should sublcass
this and write your own BOOT method."))
(defun can-set-projection-p (app)
(and (slot-boundp app 'width)
(slot-boundp app 'height)
(slot-boundp app 'scale)))
(defun set-projection (app)
(when (can-set-projection-p app)
(with-slots (projection scale width height) app
;; set projection matrix
(setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0)))))
(defmethod initialize-instance :after ((app application) &key)
(set-projection app)
(with-slots (listener left right top bottom scale width height) app
(setf listener (make-instance 'listener)
left 0
bottom 0
top (/ height scale)
right (/ width scale))))
(defun fire-blur-event-on (thing)
(when-let (blur-handlers (and thing (get-handlers-for thing 'blur)))
(dolist (handler blur-handlers)
(funcall handler thing))))
(defun fire-focus-event-on (thing)
(when-let (focus-handlers (and thing (get-handlers-for thing 'focus)))
(dolist (handler focus-handlers)
(funcall handler thing))))
(defmethod (setf closer-mop:slot-value-using-class ) :before
(new-value class (app application) slot)
(case (closer-mop:slot-definition-name slot)
(focus
(when (slot-boundp app 'focus)
(unless (eq new-value (slot-value app 'focus))
(fire-blur-event-on (slot-value app 'focus)))))))
(defmethod (setf closer-mop:slot-value-using-class) :after
(new-value class (app application) slot)
(case (closer-mop:slot-definition-name slot)
((scale width height)
(set-projection app))
(focus
(fire-focus-event-on new-value))
(fps
(setf (slot-value app 'frame-wait) (/ 1.0 new-value)))))
(defparameter +listener-table-slot-names+
'(keydown-table keyup-table mousedown-table mouseup-table mousemotion-table
focus-table blur-table perframe-table after-added-table before-added-table
before-dropped-table))
(defmethod cleanup ((app application))
(loop for asset being the hash-value of (application-assets app)
do (cleanup asset))
;; drop all current handlers
(let ((listener (listener app)))
(dolist (table +listener-table-slot-names+)
(setf (slot-value listener table) (make-hash-table :synchronized t))))
(dolist (unit (application-scene app))
(drop-unit unit)
(cleanup unit))
(trivial-garbage:gc :full t))
(defun run-perframe (app)
"Runs all of the handlers objects listening for perframe events, if
those objects are currently part of the scene tree."
(let ((table (perframe-table (listener app)))
(time (sdl2:get-ticks)))
(loop for target being the hash-key of table
for handlers = (slot-value (listener target) 'perframe)
;; only fire perframe when target is in scene
when (or (eq app target) (unit-in-scene-p target))
do (loop for handler in handlers do (funcall handler target time)))))
(defmethod render ((app application))
(run-perframe app)
(gl:clear-color 0.0 0.0 0.0 1.0)
;(gl:clear :depth-buffer-bit :color-buffer-bit)
(gl:clear :color-buffer-bit)
(gl:enable :blend)
(gl:blend-func :src-alpha :one-minus-src-alpha )
(dolist (unit (application-scene app))
(render unit))
(sdl2:gl-swap-window (application-window app))
(sleep (frame-wait app)))
|
