/[gamelib]/source/coords.lisp
ViewVC logotype

Contents of /source/coords.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Oct 10 06:19:33 2006 UTC (7 years, 6 months ago) by imattsson
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +1 -6 lines
Added 3D camera (with movement and turning).
1 (in-package #:net.hexapodia.games-3d)
2
3 (defvar *camera* nil)
4
5 (defclass coord ()
6 ((x :accessor x :initarg :x :type double-float)
7 (y :accessor y :initarg :y :type double-float)
8 (z :accessor z :initarg :z :type double-float)))
9
10 ;;; We only need a camera that can yaw (no pitch or roll needed)
11 (defclass camera (coord)
12 ((angle :accessor angle :initarg :angle :type double-float)
13 (focal :accessor focal :initarg :focal)
14 ))
15
16 (defclass 3d-camera (coord)
17 ((transform :reader transform :initarg :transform)))
18
19 (defun coord (x y z)
20 (make-instance 'coord :x (coerce x 'double-float)
21 :y (coerce y 'double-float)
22 :z (coerce z 'double-float)))
23
24
25 (defmethod x ((ar array))
26 (aref ar 0))
27 (defmethod y ((ar array))
28 (aref ar 1))
29 (defmethod z ((ar array))
30 (aref ar 2))
31
32
33 (defmethod (setf x) (new (ar array))
34 (setf (aref ar 0) new))
35 (defmethod (setf y) (new (ar array))
36 (setf (aref ar 1) new))
37 (defmethod (setf z) (new (ar array))
38 (setf (aref ar 2) new))
39
40
41 (defun build-transform (transform)
42 (let ((ar (make-array '(3 3)
43 :element-type 'double-float
44 :initial-contents (or transform
45 '((1.0d0 0.0d0 0.0d0)
46 (0.0d0 1.0d0 0.0d0)
47 (0.0d0 0.0d0 1.0d0))))))
48 (rotatef (aref ar 0 1) (aref ar 1 0))
49 (rotatef (aref ar 0 2) (aref ar 2 0))
50 (rotatef (aref ar 1 2) (aref ar 2 1))
51 ar))
52
53 (defun 3d-camera (x y z &optional transform)
54 "Make a 3D camera at coordinate <X Y Z>, using the camera coordinate system
55 defined by the TRANSFORM sequence < Xbase Ybase Zbase > (the individual base
56 vectors can be expressed as arbritary sequences and they can be in an
57 arbritary sequence, they will be transformed by 3d-camera into something
58 sensible)."
59 (make-instance '3d-camera
60 :x (coerce x 'double-float)
61 :y (coerce y 'double-float)
62 :z (coerce z 'double-float)
63 :transform (build-transform transform)))
64
65
66 (defgeneric world-to-camera (world-coord camera &optional result))
67 (defgeneric camera-to-screen (camera-coord camera &optional clip))
68 (defgeneric world-to-screen (world-coord camera &optional clip))
69
70 (defun base-transform (coord base &optional result)
71 (let ((result (or result (make-instance 'coord)))
72 (coord (vector (the-x coord) (the-y coord) (the-z coord))))
73 (setf (the-x result)
74 (loop for n from 0 below 3
75 sum (* (aref coord n)
76 (aref base n 0))))
77 (setf (the-y result)
78 (loop for n from 0 below 3
79 sum (* (aref coord n)
80 (aref base n 1))))
81 (setf (the-z result)
82 (loop for n from 0 below 3
83 sum (* (aref coord n)
84 (aref base n 2))))
85
86 result))
87
88 (defun invert-transform (transform)
89 (let ((xbase (vector 1.0d0 0.0d0 0.0d0))
90 (ybase (vector 0.0d0 1.0d0 0.0d0))
91 (zbase (vector 0.0d0 0.0d0 1.0d0)))
92 (setf xbase (base-transform (vector 1.0d0 0.0d0 0.0d0) transform xbase))
93 (setf ybase (base-transform (vector 0.0d0 1.0d0 0.0d0) transform ybase))
94 (setf zbase (base-transform (vector 0.0d0 0.0d0 1.0d0) transform zbase))
95 (build-transform (list xbase ybase zbase))))
96
97 (defmethod world-to-camera (w c &optional result)
98 (let ((x-tmp (- (the-x w) (the-x c)))
99 (y-tmp (- (the-y w) (the-y c)))
100 (z-tmp (- (the-z w) (the-z c)))
101 (r1 (the-angle c))
102 (r2 (+ (/ pi 2.0d0)
103 (the-angle c)))
104 (result (or result (make-instance 'coord))))
105 (declare (double-float x-tmp y-tmp z-tmp r1 r2))
106 (setf (x result) (+ (* (cos r1) x-tmp)
107 (* (cos r2) y-tmp)))
108 (setf (y result) (+ (* (sin r1) x-tmp)
109 (* (sin r2) y-tmp)))
110 (setf (z result) z-tmp)
111 result))
112
113 (defmethod world-to-camera (w (c 3d-camera) &optional result)
114 (let ((x-tmp (- (the-x w) (the-x c)))
115 (y-tmp (- (the-y w) (the-y c)))
116 (z-tmp (- (the-z w) (the-z c)))
117 (transform (transform c))
118 (result (or result (make-instance 'coord))))
119 (declare (double-float x-tmp y-tmp z-tmp)
120 ((array double-float (3 3)) transform))
121 (base-transform (vector x-tmp y-tmp z-tmp) transform result)))
122
123 (defmethod camera-to-screen (coord cam &optional clip)
124 (let ((div (/ (the-y coord) (focal cam)))
125 (screen-half (truncate +screen-side+ 2)))
126 (declare ((signed-byte 16) screen-half)
127 (double-float div))
128 (let ((sx (if (zerop div) (the-x coord) (/ (the-x coord) div)))
129 (sy (if (zerop div) (the-z coord) (/ (the-z coord) div))))
130 (cond ((and clip
131 (<= -1.0d0 sx 1.0d0)
132 (<= -1.0d0 sy 1.0d0))
133 (list (round (+ screen-half (* screen-half sx)))
134 (round (+ screen-half (* (- screen-half) sy)))))
135 ((not clip)
136 (list (round (+ screen-half (* screen-half sx)))
137 (round (+ screen-half (* (- screen-half) sy)))))
138 (t nil)))))
139
140 (defmethod camera-to-screen (coord (cam 3d-camera) &optional clip)
141 (declare (ignore cam))
142 (let ((screen-half (truncate +screen-side+ 2))
143 (sx (if (zerop (the-y coord))
144 (the-x coord)
145 (/ (the-x coord) (the-y coord))))
146 (sy (if (zerop (the-y coord))
147 (the-z coord)
148 (/ (the-z coord) (the-y coord)))))
149 (declare ((signed-byte 16) screen-half))
150 (cond ((and clip
151 (<= -1.0d0 sx 1.0d0)
152 (<= -1.0d0 sy 1.0d0))
153 (list (round (+ screen-half (* screen-half sx)))
154 (round (+ screen-half (* (- screen-half) sy)))))
155 ((not clip)
156 (list (round (+ screen-half (* screen-half sx)))
157 (round (+ screen-half (* (- screen-half) sy)))))
158 (t nil))))
159
160 (defmethod world-to-screen (w c &optional clip)
161 (let ((screen-half (/ +screen-side+ 2))
162 (x-tmp (- (the-x w) (the-x c)))
163 (y-tmp (- (the-y w) (the-y c)))
164 (z-tmp (- (the-z w) (the-z c)))
165 (r1 (the-angle c))
166 (r2 (+ (/ pi 2.0d0)
167 (the-angle c)))
168 )
169 (let ((cam-x (+ (* (cos r1) x-tmp)
170 (* (cos r2) y-tmp)))
171 (div (/ (+ (* (sin r1) x-tmp)
172 (* (sin r2) y-tmp))
173 (focal c)))
174 (cam-z z-tmp))
175 (let ((sx (if (zerop div) cam-x (/ cam-x div)))
176 (sy (if (zerop div) cam-z (/ cam-z div))))
177 (cond ((and clip
178 (<= -1.0d0 sx 1.0d0)
179 (<= -1.0d0 sy 1.0d0))
180 (list (round (+ screen-half (* screen-half sx)))
181 (round (+ screen-half (* (- screen-half) sy)))))
182 ((not clip)
183 (list (round (+ screen-half (* screen-half sx)))
184 (round (+ screen-half (* (- screen-half) sy)))))
185 (t nil))))))
186
187 (defmethod world-to-screen (world (cam 3d-camera) &optional clip)
188 (let ((x-tmp (- (the-x world) (the-x cam)))
189 (y-tmp (- (the-y world) (the-y cam)))
190 (z-tmp (- (the-z world) (the-z cam))))
191 (let ((coord (base-transform (vector x-tmp y-tmp z-tmp) (transform cam))))
192 (let ((screen-half (truncate +screen-side+ 2))
193 (sx (if (zerop (the-y coord))
194 (the-x coord)
195 (/ (the-x coord) (the-y coord))))
196 (sy (if (zerop (the-y coord))
197 (the-z coord)
198 (/ (the-z coord) (the-y coord)))))
199 (declare ((signed-byte 16) screen-half))
200 (cond ((and clip
201 (<= -1.0d0 sx 1.0d0)
202 (<= -1.0d0 sy 1.0d0))
203 (list (round (+ screen-half (* screen-half sx)))
204 (round (+ screen-half (* (- screen-half) sy)))))
205 ((not clip)
206 (list (round (+ screen-half (* screen-half sx)))
207 (round (+ screen-half (* (- screen-half) sy)))))
208 (t nil))))))
209
210
211
212 (declaim (ftype (function (coord coord) double-float) distance))
213 (defun distance (c1 c2)
214 (let ((dx (- (the-x c2) (the-x c1)))
215 (dy (- (the-y c2) (the-y c1)))
216 (dz (- (the-z c2) (the-z c1))))
217 (declare (double-float dx dy dz))
218 (sqrt (+ (square dx) (square dy) (square dz)))))

  ViewVC Help
Powered by ViewVC 1.1.5