blob: 8c86fada9e94658a59bb6529577c90d4c0305007 (
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
126
127
128
129
130
131
|
;;;; 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))
;; run cleanup on assets
(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))))
;; then cleanup units
(loop :for unit :across (application-scene app) :do
(drop-unit unit)
(cleanup unit))
;; finally run the exit hooks
(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)))
|
