-
-
Notifications
You must be signed in to change notification settings - Fork 43
/
prefab.lisp
128 lines (103 loc) · 4.61 KB
/
prefab.lisp
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
(in-package #:org.shirakumo.fraf.trial)
(defvar *prefab-translation-functions*
(make-hash-table :test 'eql))
(defmacro define-prefab-translator (name (instancevar assetvar &rest args) &body body)
`(setf (gethash ',name *prefab-translation-functions*)
(lambda (,instancevar ,assetvar ,@args)
(declare (ignorable ,instancevar ,assetvar))
,@body)))
(defun expand-prefab-expression (type instancevar assetvar args)
(apply (or (gethash type *prefab-translation-functions*)
(error "The prefab translation form ~a is unknown." type))
instancevar assetvar args))
(defgeneric prefab-asset (prefab))
(defgeneric instantiate-prefab (prefab asset))
(defclass prefab ()
((instantiated :initform NIL)))
(defmethod observe-load-state :before ((prefab prefab) (asset model-file) (state (eql :loaded)) (area staging-area))
(instantiate-prefab prefab asset))
(defmethod stage :before ((prefab prefab) (area staging-area))
(register-load-observer area prefab (prefab-asset prefab))
(stage (prefab-asset prefab) area))
(defmethod instantiate-prefab ((prefab symbol) asset)
(instantiate-prefab (make-instance prefab) asset))
(defmethod instantiate-prefab ((prefab class) asset)
(instantiate-prefab (make-instance prefab) asset))
(defmethod instantiate-prefab ((prefab prefab) (asset (eql T)))
(instantiate-prefab prefab (prefab-asset prefab)))
(defmethod instantiate-prefab :around ((prefab prefab) (asset asset))
(unless (slot-value prefab 'instantiated)
(call-next-method)
(setf (slot-value prefab 'instantiated) T)))
(defmethod reload ((prefab prefab))
(deallocate (prefab-asset prefab))
(clear prefab)
(commit prefab (loader +main+) :unload NIL))
(defmacro define-prefab-instantiation (class asset &body changes)
(let ((assetvar (gensym "ASSET")))
`(progn
,@(when asset
`((defmethod prefab-asset ((,class ,class))
(asset ,@(loop for part in asset collect `',part)))))
(defmethod instantiate-prefab ((,class ,class) (,assetvar model-file))
,@(loop for (type . args) in (or changes '((reparent)))
collect (expand-prefab-expression type class assetvar args))
,class))))
(defmacro do-nodes% ((node instance id) &body body)
(etypecase id
((member NIL T)
`(let ((,node ,instance))
,@body))
((or string symbol real)
`(let ((,node (node ,id ,instance)))
,@body))
(cons
`(do-scene-graph (,node ,instance)
(when (funcall ,id ,node)
,@body)))))
(define-prefab-translator enter (instance asset &optional node children-only)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar (find-scene T ,asset) ,node)
,(if children-only
`(sequences:dosequence (,nodevar ,nodevar)
(enter (clone ,nodevar) ,instance))
`(enter (clone ,nodevar) ,instance)))))
(define-prefab-translator leave (instance asset &optional node)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(leave ,nodevar T))))
(define-prefab-translator scaling (instance asset scale &optional node)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(setf (scaling ,nodevar) ,scale))))
(define-prefab-translator location (instance asset location &optional node)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(setf (location ,nodevar) ,location))))
(define-prefab-translator orientation (instance asset quat &optional node)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(setf (orientation ,nodevar) ,quat))))
(define-prefab-translator physics-primitives (instance asset node)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(setf (physics-primitives ,instance) (physics-primitives ,nodevar))
(setf (mass ,instance) (mass ,nodevar))
(typecase ,nodevar
(animated-entity
(change-class ,nodevar 'basic-animated-entity))
(T
(change-class ,nodevar 'basic-entity))))))
(define-prefab-translator change-class (instance asset node class)
(let ((nodevar (gensym "NODE")))
`(do-nodes% (,nodevar ,instance ,node)
(change-class ,nodevar ',class))))
(define-prefab-translator play (instance asset animation)
`(play ,animation ,instance))
(define-prefab-translator <- (instance asset &optional node)
`(<- ,instance ,(if node
`(node ,node ,asset)
`(elt (find-scene T ,asset) 0))))
(define-prefab-translator eval (instance asset args &rest body)
`((lambda ,args ,@body)
,instance ,asset))