-
Notifications
You must be signed in to change notification settings - Fork 1
/
utilities.lisp
executable file
·151 lines (133 loc) · 5.99 KB
/
utilities.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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
(in-package :krma)
(eval-when (:compile-toplevel :load-toplevel)
(when *muffle-compilation-notes*
#+sbcl(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))))
(eval-when (:compile-toplevel :load-toplevel)
(when krma::*debug*
(declaim (optimize (safety 3) (debug 3))))
(unless krma::*debug*
(declaim (optimize (safety 0) (speed 3) (debug 0)))
(declaim (inline d2r) (ftype (function (real) double-float) d2r))
(declaim (inline canonicalize-color) (ftype (function (T) (unsigned-byte 32)) canonicalize-color))))
(cffi:defcfun ("memcpy" memcpy) :pointer
(dst :pointer)
(src :pointer)
(count size-t))
(defun d2r (d)
(declare (type real d))
(* d #.(/ pi 180)))
(defun lookat-rh (eye target up) ;; sanity check, 3d-matrices:mlookat produces same
(let* ((zaxis (vunit (v- eye target)))
(xaxis (vunit (vc up zaxis)))
(yaxis (vc zaxis xaxis))
(orientation
(mat4 (vx xaxis) (vy xaxis) (vz xaxis) 0
(vx yaxis) (vy yaxis) (vz yaxis) 0
(vx zaxis) (vy zaxis) (vz zaxis) 0
0 0 0 1))
(translation
(mat4 1 0 0 (- (vx eye))
0 1 0 (- (vy eye))
0 0 1 (- (vz eye))
0 0 0 1)))
(m* orientation translation)))
(defun lookat-lh (eye target up)
(let* ((zaxis (vunit (v- target eye)))
(xaxis (vunit (vc up zaxis)))
(yaxis (vc zaxis xaxis))
(orientation
(mat4 (vx xaxis) (vy xaxis) (vz xaxis) 0
(vx yaxis) (vy yaxis) (vz yaxis) 0
(vx zaxis) (vy zaxis) (vz zaxis) 0
0 0 0 1))
(translation
(mat4 1 0 0 (- (vx eye))
0 1 0 (- (vy eye))
0 0 1 (- (vz eye))
0 0 0 1)))
(m* orientation translation)))
(defun lookat-lh-2 (eye target up)
"https://learn.microsoft.com/en-us/previous-versions/windows/desktop/bb281710(v=vs.85)"
(let* ((zaxis (vunit (v- target eye)))
(xaxis (vunit (vc up zaxis)))
(yaxis (vc zaxis xaxis)))
(mat4 (vx xaxis) (vy xaxis) (vz xaxis) 0
(vx yaxis) (vy yaxis) (vz yaxis) 0
(vx zaxis) (vy zaxis) (vz zaxis) 0
(- (v. xaxis eye)) (- (v. yaxis eye)) (- (v. zaxis eye)) 1)))
(defun mperspective-vulkan (fovy aspect-ratio near far)
(declare (type real fovy aspect-ratio near far))
"https://github.com/PacktPublishing/Vulkan-Cookbook/blob/master/Library/Source%20Files/10%20Helper%20Recipes/04%20Preparing%20a%20perspective%20projection%20matrix.cpp"
;; switched from column major to row major
(setq far (coerce far '#.*read-default-float-format*))
(setq near (coerce near '#.*read-default-float-format*))
(setq aspect-ratio (coerce aspect-ratio '#.*read-default-float-format*))
(let* ((zero 0.0)
(f (/ 1.0 (coerce (tan (cl:the double-float (* 0.5 (d2r fovy)))) '#.*read-default-float-format*))) ;; focal length
(near-far (- near far))
(A (/ far near-far))
(B (/ (* near far) near-far))
(x (/ f aspect-ratio))
(y (- f)))
(mat4 x zero zero zero
zero y zero zero
zero zero A B
zero zero -1.0 zero)))
(defun mortho-vulkan (left right bottom top near far)
"https://github.com/PacktPublishing/Vulkan-Cookbook/blob/master/Library/Source%20Files/10%20Helper%20Recipes/05%20Preparing%20an%20orthographic%20projection%20matrix.cpp"
(let ((f2 2)
(f0 0)
(f1 1)
(r right)
(l left)
(b bottom)
(u top)
(n near)
(f far))
(mat4 (/ f2 (- r l)) f0 f0 (- (/ (+ r l) (- r l)))
f0 (/ f2 (- b u)) f0 (- (/ (+ b u) (- b u)))
f0 f0 (/ f1 (- n f)) (/ n (- n f))
f0 f0 f0 f1)))
(defun canonicalize-color (color)
(etypecase color
((unsigned-byte 32) color)
(vec3
(let ((r (cl:the (integer 0 #xff) (round (* #xff (vx color)))))
(g (cl:the (integer 0 #xff) (round (* #xff (vy color)))))
(b (cl:the (integer 0 #xff) (round (* #xff (vz color))))))
(cl:the (unsigned-byte 32) (logior (ash r 24) (ash g 16) (ash b 8) #xff))))
(vec4
(let ((r (cl:the (integer 0 #xff) (round (* #xff (vx color)))))
(g (cl:the (integer 0 #xff) (round (* #xff (vy color)))))
(b (cl:the (integer 0 #xff) (round (* #xff (vz color)))))
(a (cl:the (integer 0 #xff) (round (* #xff (vw color))))))
(cl:the (unsigned-byte 32) (logior (ash r 24) (ash g 16) (ash b 8) a))))
(vector
(let ((length (length color)))
(if (= length 3)
(let ((r (cl:the (integer 0 #xff) (round (* #xff (aref color 0)))))
(g (cl:the (integer 0 #xff) (round (* #xff (aref color 1)))))
(b (cl:the (integer 0 #xff) (round (* #xff (aref color 2))))))
(cl:the (unsigned-byte 32) (logior (ash r 24) (ash g 16) (ash b 8) #xff)))
(if (> length 3)
(let ((r (cl:the (integer 0 #xff) (round (* #xff (aref color 0)))))
(g (cl:the (integer 0 #xff) (round (* #xff (aref color 1)))))
(b (cl:the (integer 0 #xff) (round (* #xff (aref color 2)))))
(a (cl:the (integer 0 #xff) (round (* #xff (aref color 3))))))
(cl:the (unsigned-byte 32) (logior (ash r 24) (ash g 16) (ash b 8) a)))
(progn
(warn "~S is not a color" color)
#xffffffff)))))))
(defun color-p (item)
(or (typep item '(unsigned-byte 32))
(typep item 'vec4)
(typep item 'vec3)
(and (typep item 'vector)
(or (= (length item) 4)
(= (length item) 3)))))
(deftype color ()
`(satisfies color-p))
(defun gen-rm-handle ()
"Generate retained-mode primitive handle."
#+SBCL(sb-ext:atomic-incf (car (retained-mode-handle-count-cons (default-display))))
#-sbcl(incf (car (retained-mode-handle-count-cons (default-display)))))