blob: 5d8135e67ef34c31fd287a5c45ea472814f6d97c (
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
|
;;;; application
(in-package #:wheelwork)
(defvar *application* nil
"current application")
(defclass/std application (container interactive)
((title :with :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)
(width height :with :std 800)
(projection :with :a :doc "The projection matrix for the scene. Orthographic by default.")
(window :with :a)
(refocus-on-mousedown-p :std t)
(focus last-motion-target :with :a)
(fps :with :std 30 :doc "Frames Per Second")
(frame-wait :r)))
(defun fps (&optional (app *application*))
(application-fps app))
(defun (setf fps) (new-val &optional (app *application*))
(setf (application-fps app) new-val))
(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)
(setf (listener app) (make-instance 'listener)))
(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 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))))
(call-next-method))
(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 (get-universal-time)))
(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-container 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 (thing (container-units app))
(render thing))
(sdl2:gl-swap-window (application-window app))
(sleep (frame-wait app)))
|
