blob: f33bb9f676ab5c097815d7f108d52b8469c3ec30 (
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)
(def:class application (region interactive)
(title :prefix :ro :type string :initform "Wheelwork App")
((asset-root "Directory underwhich assets are stored.")
:ro :type pathname :initform #P"./")
((asset-classifiers "ALIST of (FILE-EXTENSION CLASS-NAME) pairs.")
:initform '(("png" png) ("ttf" font)))
((assets "Map of asset names to asset instances")
:prefix :noarg :initform (make-hash-table :test 'equal))
((scale "Scale factor applied to all rendering and to all event targeting.")
:prefix :type float :initform 1.0)
((width "pixel width")
(height "pixel height")
:prefix :type fixnum :initform 800)
((projection "Scene projection matrix. Orthographic by default.")
:prefix :noarg)
((window "SDL2 application window.")
:prefix :noarg)
((refocus-on-mousedown-p "Clicking a visbile unit will set focus to that unit.")
:type boolean :initform t)
(mouse-button-events-bubble-p
mouse-motion-events-bubble-p
:type boolean :initform nil
:documentation "If T, handler search doesn't stop at first visble event target.")
((scene "Vector of objects to be displayed")
:prefix :noarg :type (vector unit))
((focus "Unit with current focus.")
(last-motion-target "Unit that last receved a mouse motion event.")
:prefix :noarg :type (or null unit) :initform nil)
((fps "Frames per second")
:type fixnum :initform 30)
((frame-wait "Pause between frames, in seconds")
:type number :ro :noarg))
(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 scene ) app
(setf listener (make-instance 'listener)
left 0
bottom 0
top (/ height scale)
right (/ width scale)
scene (make-array 0 :adjustable t :fill-pointer t :initial-element nil))))
(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))
(fire-focus-event-on new-value))))))
(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))
(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))
(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))))
(loop for unit across (application-scene app)
do
(drop-unit unit)
(cleanup unit))
(pre-exit-hooks))
(defun run-perframe (app)
"Runs all of the handlers objects listening for perframe events if they are in the scene."
(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 )
(with-slots (scene) app
(when (plusp (length scene))
(loop for unit across scene do (render unit))))
(sdl2:gl-swap-window (application-window app))
(sleep (frame-wait app)))
|
