blob: 23b328a0cdd9500cc62fde8402853277e213577d (
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
132
133
134
135
136
137
138
139
140
|
;;;; wheelwork.lisp
(in-package #:wheelwork)
(defvar *application* nil
"current application")
(defclass/std application ()
((title :with :std "Wheelwork App")
(asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
(asset-classifiers
:std '(("png" texture))
: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 :a :std 1.0)
(width height :with :std 800)
(projection :with :a :doc "The projection matrix for the scene. Orthographic by default.")
(window :with :a)
(display-root :doc "A list of objects to display, the root of a tree")
(refocus-on-mousedown-p :std t)
(focus last-motion-target :with :a)
(frame-wait :std (/ 1000 30) :doc "Frames Per Second" :a)))
(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)q
(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))
(defmethod (setf closer-mop:slot-value-using-class) :after
(new-value class (app application) slot)
(when (member (closer-mop:slot-definition-name slot)
'(scale width height))
(set-projection app)))
(defgeneric boot (app)
(:documentation "Specialized for each subclass of
APPLICATION. Responsble for setting the app up once the system
resoruces are avaialble.")
(:method ((app application)) nil))
(defgeneric cleanup (thing)
(:documentation "Clean up applications, textures, and so on.")
(:method ((any t)) nil))
(defun start (app &key (x :centered) (y :centered))
(sdl2:with-init (:everything)
(sdl2:with-window (window
:flags '(:shown :opengl)
:title (application-title app)
:w (application-width app)
:h (application-height app)
:x x :y y)
(setf (application-window app) window)
(sdl2:with-gl-context (ctx window)
(sdl2:gl-make-current window ctx)
(gl:viewport 0 0 (application-width app) (application-height app))
(let ((*application* app))
(boot app)
(eventloop app)
(cleanup app))))))
(defun eventloop (app)
(sdl2:with-event-loop (:method :poll)
(:quit () t)))
;; (defun get-focus (&optional (app *application*))
;; (or (application-focus app)
;; (display-root app)))
;; (defun get-projection (&optional (app *application*))
;; (application-projection app))
;; (defun application-width (&optional (app *application*))
;; (multiple-value-bind (w h) (sdl2:get-window-size (application-window app))
;; (declare (ignore h))
;; w))
;; (defun application-height (&optional (app *application*))
;; (multiple-value-bind (w h) (sdl2:get-window-size (application-window app))
;; (declare (ignore w))
;; h))
;; (defun asset-class-for (asset-id &optional (app *application*))
;; "Given an asset-id (see GET-ASSET), retrieve the symbol name of a
;; the class that will be used to instantiate the asset object. That
;; class should be a subclass of ASSET. Additional clases can be added
;; to the application's ASSET-CLASSIFIERS association list."
;; (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal)))
;; (defun get-asset (asset-id &optional (app *application*))
;; "ASSET-ID is a pathname namestring relative to the application's
;; ASSET-ROOT. GET-ASSET retrieves an already-available asset from the
;; application's ASSETS table, or, if not available, loads the asset from
;; disk."
;; (or (gethash asset-id (application-assets app))
;; (setf (gethash asset-id (application-assets app))
;; (initialize
;; (make-instance (asset-class-for asset-id)
;; :path (uiop:merge-pathnames* asset-id (asset-root app)))))))
;; (defclass/std event-handler ()
;; ((event-type handler-function :ri)))
;; (defclass/std listener ()
;; ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe
;; :r :with :type event-handler)
;; (keydown-table
;; keyup-table
;; mousedown-table
;; mouseup-table
;; mousemove-table
;; mousewheel-table
;; focus-table
;; blur-table
;; perframe-table
;; :static
;; :std (make-hash-table)
;; :doc "Keyed by DISPLAY-UNIT instance, holds an EVENT-HANDLER if handler is defined for unit."))
;; (:documentation "Event handlers per object. The static hash tables
;; are keyed by UNIT and hold Event-Handler instances."))
;; (defclass/std display-unit ()
;; ((x y width height rotation :a :with :std 0.0 :type float :doc "Geometric properties")
;; (cached-model cached-real-model container listener :a :doc "Internal use.")
;; (focusablep :doc "T indicates it cannot be made the object of focus.")
;; (opacity :std 1.0 :doc "0.0 indicates it will not be rendred.")))
|
