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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
;****************************************************************
;* class V I E W I N G & P R O J E C T I O N
;; Copyright (1988) Toshihiro MATSUI
;;
;* VIEWING defines the viewing-coordinates whose origin is at
;* "viewpoint" and looking to (w-axis is oriented to) "target".
;* PROJECTION performs projective mapping.
;* cascoords <-- viewing <-- projection <-+- parallel-viewing
;* +- perspective-viewing
;* +- viewing2d
;* May/1996 merging with draw in OpenGL
;;
;****************************************************************
(in-package "GEOMETRY")
;; nothing to export except classes
(eval-when (compile) (load "geoclasses.l"))
(defmethod viewing
(:update ()
;; worldcoords has been already computed here
;; make inverse in viewcoords
(send-super :update)
(transpose (coordinates-rot worldcoords) (coordinates-rot viewcoords))
(when (= (length pos) 3)
(m* #2f((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 -1.0))
(coordinates-rot viewcoords)
(coordinates-rot viewcoords)))
(scale -1.0
(transform (coordinates-rot viewcoords) (coordinates-pos worldcoords))
(coordinates-pos viewcoords))
viewcoords )
(:changed ()
(send-super :changed)
(send self :worldcoords))
)
(defmethod viewing
(:viewpoint () (send self :worldpos))
(:view-direction () (matrix-row (coordinates-rot viewcoords) 2))
(:view-up () (matrix-row (coordinates-rot viewcoords) 1))
(:view-right () (matrix-row (coordinates-rot viewcoords) 0))
(:sendviewcoords ()
(error ":sendviewcoords -- subclass'es responsibility") )
(:look (from &optional (to #f(0 0 0)))
; Make viewing coordinates whose origin is at 'from' and -z-axis
; is pointing to 'to', and x-axis is parallel to world's xy-plane.
(setq to (v- from to))
(send-super :init)
; (setf (aref rot 2 2) -1.0)
(send self :rotate
(- (atan
(elt to 2)
(sqrt (+ (* (elt to 0) (elt to 0))
(* (elt to 1) (elt to 1)))) ))
:x :world)
(send self :rotate (- (+ (atan (elt to 0) (elt to 1)) pi)) :y :world)
(send self :rotate (- (/ (- pi) 2)) :x :world)
(send-super :locate from :world)
self)
(:makeviewcoords (ax ay az p)
(send-super :reset-coords)
; (setf (aref rot 2 2) -1.0)
(send self :rotate pi/2 :x :world)
(send self :rotate pi/2 :z :world)
(send self :rotate ax :x :world)
(send self :rotate ay :y :world)
(send self :rotate az :z :world)
(send self :locate p :world))
(:init (&rest viewargs
&key (dimension 3)
(target nil)
(view-direction nil)
(view-up (float-vector 0.0 0.0 1.0))
(view-right nil)
&allow-other-keys)
(send-super* :init viewargs)
(setf viewcoords (coords :dimension dimension))
(when (or target view-direction)
(if (null view-direction)
(setq view-direction (v- target pos)))
(setq view-direction (normalize-vector view-direction))
(unless view-right
(setq view-right (v* view-direction view-up)))
(setq view-right (normalize-vector view-right))
(setq view-up (normalize-vector (v* view-right view-direction)))
(setq view-direction (scale -1.0 view-direction))
(setf (array-entity rot)
(concatenate float-vector view-right view-up view-direction))
(transpose rot rot) )
(send self :worldcoords)
self)
)
;;;
(defmethod projection
(:projection () projection-matrix)
(:newprojection (pmat) (setq projection-matrix pmat))
(:project (vec) (transform projection-matrix vec))
(:project3 (vec3)
(transform projection-matrix
;; (replace (float-vector 0 0 0 1) vec3)
(homogenize vec3)))
(:view (point)
(send self :project3 (send viewcoords :transform-vector point)))
(:screen (&optional (sx nil) (sy sx))
(when sx (setq screenx sx screeny sy) (send self :make-projection))
(list screenx screeny))
(:hither (&optional (h nil))
(when h (setq hither (float h))
(send self :make-projection))
hither)
(:yon (&optional (y nil))
(when y (setq yon (float y))
(send self :make-projection))
yon)
(:aspect (&optional (rate nil))
(when rate (setq screeny (* screenx rate))
(send self :make-projection))
(/ screeny screenx))
(:viewreference () (float-vector 0 0 (/ (+ hither yon) 2.0)))
(:make-projection (&rest args)
(error ":make-projection subclass's responsibility"))
(:init (&rest viewing-params
&key ((:hither h) 100.0)
((:yon y) 10000.0)
(aspect 1.0)
(screen 100.0)
(screen-x screen)
(screen-y (* aspect screen-x))
&allow-other-keys)
(setf hither (float h)
yon (float y)
screenx (float screen-x)
screeny (float screen-y))
(send-super* :init viewing-params)
(send self :make-projection)
self))
;;;;
(defmethod viewing2d
(:project (vec) (transform projection-matrix vec))
(:project2 (vec3)
(homogenize (transform projection-matrix vec3)))
(:view (point)
(send self :project2 (send viewcoords :transform-vector point)))
(:make-projection ()
(setq projection-matrix (make-matrix 2 2))
(setf (aref projection-matrix 0 0) (/ 2.0 screenx)
(aref projection-matrix 1 1) (/ 2.0 screeny))
projection-matrix)
(:init (&rest initargs
&key (screen 1.0)
(screen-x screen)
(screen-y screen-x)
&allow-other-keys)
(send-super* :init :dimension 2 initargs)
(setq screenx screen-x
screeny screen-y)
(send self :make-projection)
self))
;;;
(defmethod parallel-viewing
(:make-projection ()
(setf projection-matrix (make-matrix 4 4))
(setf (aref projection-matrix 0 0) (/ 1.0 screenx) )
(setf (aref projection-matrix 1 1) (/ 1.0 screeny))
(setf (aref projection-matrix 2 2) (/ 1.0 (- yon hither)))
#|
(setf (aref projection-matrix 0 3) 0.50)
(setf (aref projection-matrix 1 3) 0.50)
|#
(setf (aref projection-matrix 2 3) (- (/ hither (- yon hither))))
(setf (aref projection-matrix 3 3) 1.0)
self)
)
;;;
(defmethod perspective-viewing
(:ray (u v) ; u,v are normalized: -1<u<1, -1<v<1
"returns direction vector pointing (u,v) in NDC from the viewpoint"
(declare (float u v))
(normalize-vector
(send self :rotate-vector
(float-vector (* screenx u) (* screeny v) (- viewdistance)))))
(:view-plane (&optional (offset 0.0))
"+offset makes the viewplane closer to the viewpoint,
-offset takes further distance."
(make-plane :normal (send self :view-direction)
:point (send self :transform-vector
(float-vector 0.0 0.0
(- offset viewdistance)))) )
(:make-projection ()
(let*
((f (/ (* (- (* 2.0 hither) viewdistance) viewdistance) hither))
(b (/ (* (- (* 2.0 yon) viewdistance) viewdistance) yon))
(depth (- b f))
(p1 nil)
(p2 nil))
(setq p1 (unit-matrix 4))
(setf (aref p1 2 2) 2.0)
(setf (aref p1 3 2) (/ 1.0 viewdistance))
(setf (aref p1 2 3) (- viewdistance))
(setf (aref p1 3 3) 0.0)
;
(setq p2 (make-matrix 4 4))
(setf (aref p2 0 0) (/ 1.0 screenx))
(setf (aref p2 1 1) (/ 1.0 screeny))
(setf (aref p2 2 2) (/ 1.0 depth))
(setf (aref p2 2 3) (/ (- f) depth))
(setf (aref p2 3 3) 1.0)
; (format t ":make-projection~% p1=~S~%p2=~S~%" p1 p2)
(m* p2 p1 projection-matrix)))
(:viewdistance (&optional (vd nil))
(when vd
(setq viewdistance (float vd))
(send self :make-projection))
viewdistance)
(:view-angle (&optional ang)
(if ang
(let ((aspect (/ screeny screenx))
(diag (* viewdistance (tan (/ ang 2.0))))
sx)
(setq sx %(sqrt(diag * diag / (1.0 + aspect * aspect))))
(send self :screen sx (* sx aspect))
(send self :make-projection)
ang)
(* 2 (atan %(sqrt(screenx * screenx + screeny * screeny))
viewdistance) ) ))
(:fovy ()
(* 2 (atan screeny viewdistance) ))
(:zoom (&optional (s nil))
(when s
(setq screenx (/ screenx s) screeny (/ screeny s))
(send self :make-projection))
(send self :view-angle))
(:lookaround (alfa beta)
(let* ((v (float-vector 0 0 (/ (+ yon hither) 2.0))))
(send self :locate (v- v) :local)
(send self :rotate alfa :z :world)
(send self :rotate beta :x :local)
(send self :locate v :local ))
)
(:look-body (&rest bodies)
(setq bodies (flatten bodies))
(let* ((box (bounding-box-union bodies))
v1 v2 ang)
(send box :grow 0.1)
(send self :look (send self :viewpoint) (send box :center))
(setq box (instance bounding-box :init
(mapcar #'(lambda (x) (send viewcoords :transform-vector x))
(send box :corners))
))
(setq v1 (normalize-vector (send box :minpoint))
v2 (normalize-vector (send box :maxpoint)))
(setq ang (acos (v. v1 v2)))
(send self :hither
(* 0.5 (aref (send box :extream-point #f(0 0 -1)) 2)))
(send self :yon
(* 2.0 (aref (send box :extream-point #f(0 0 1)) 2)))
(send self :view-angle ang)
self))
(:look-body2 (&rest bodies)
(setq bodies (flatten bodies))
(let* ((box (send (bounding-box-union bodies) :grow 0.1))
(diagonal (distance (box . maxpoint) (box . minpoint)))
(view-reference (send box :center))
(view-dist (distance (send self :viewpoint) view-reference))
v1 v2 ang)
(send self :look (send self :viewpoint) view-reference)
(setq ang (* 2.0 (atan (/ diagonal 2.0) view-dist )) )
(print (list diagonal view-dist ang))
(send self :hither
(* 0.5 (aref (send box :extream-point #f(0 0 -1)) 2)))
(send self :yon
(* 2.0 (aref (send box :extream-point #f(0 0 1)) 2)))
(send self :view-angle ang)
self))
(:prin1 (strm &optional msg)
(send-super :prin1 strm
(format nil "~fdeg" (lisp::rad2deg (send self :view-angle)))
msg) )
(:init (&rest params
&key ((:viewdistance vd))
&allow-other-keys)
(if vd
(setq viewdistance (float vd))
(unless viewdistance (setq viewdistance 100.0)))
(unless projection-matrix (setq projection-matrix (unit-matrix 4)))
(send-super* :init params)
self))
;; UTYO local
(defmethod perspective-viewing
(:view-orient (&optional (v (float-vector 0 0))) ;;;mer
(declare (float-vector v))
(transform (transpose (viewcoords . rot))
(normalize-vector
(float-vector (/ (* (aref v 0) screenx)
viewdistance)
(/ (* (aref v 1) screeny)
viewdistance)
1))))
(:view-line (&optional (v #f(0 0)))
(instance 3dline :init
(send self :view-orient v)
(send self :viewpoint)))
)
#| stereo viewing is not well-defined yet
(defmethod stereo-viewing
(:rightview () rightview)
(:leftview () leftview)
(:viewpoint (&optional (vp nil))
(cond (vp (send self :init nil vp offset target)))
viewpoint)
(:offset (&optional (off nil))
(cond (off (send self :init nil viewpoint off target)))
offset)
(:target (&optional (tgt nil))
(cond (tgt (send self :init nil viewpoint offset tgt)))
target)
(:nomethod (&rest mesg)
(list (resend rightview mesg) (resend leftview mesg)))
(:init (cls vp off tgt)
(setq viewpoint vp
offset off
target tgt)
(let ((viewline (v- target viewpoint)) (theta 0) (dx 0) (dy 0)
(rvp nil) (lvp nil)
(vpx (elt viewpoint 0))
(vpy (elt viewpoint 1))
(vpz (elt viewpoint 2)))
(setq theta (atan (- (elt viewline 0)) (elt viewline 1)))
(setq dx (* offset (cos theta)))
(setq dy (* offset (sin theta)))
(setq rvp (float-vector (+ vpx dx) (+ vpy dy) vpz))
(setq lvp (float-vector (- vpx dx) (- vpy dy) vpz))
(cond (cls
(setq rightview (instantiate cls))
(send rightview :init rvp target)
(setq leftview (instantiate cls ))
(send leftview :init lvp target))
(t (send rightview :look rvp target)
(send leftview :look lvp target)))
self)))
|#
(provide :viewing "@(#)$Id: viewing.l,v 1.1.1.1 2003/11/20 07:46:30 eus Exp $")
|
