/[corman-sdl]/corman-sdl/examples/rotating-cube_3.lisp
ViewVC logotype

Contents of /corman-sdl/examples/rotating-cube_3.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Apr 17 00:02:09 2004 UTC (10 years ago) by lcrook
Branch: MAIN
CVS Tags: lush_v1, HEAD
Branch point for: lush
Changes since 1.2: +43 -37 lines
*** empty log message ***
1 ;;; A rotating cube example.
2 ;;; Taken from the SDL example at http://sdldoc.csn.ul.ie/guidevideoopengl.php
3 ;;; Author: Luke J Crook, luke@balooga.com
4 ;;;
5 ;;; Operation:
6 ;;; - Press any key (except Escape) to pause/restart rotation.
7 ;;; - Press Escape to exit.
8 ;;; - Left-click and use the mouse to rotate the cube around the x/y axises.
9 ;;;
10 ;;; Issues:
11 ;;; - Rotation is not scaled to time but is based on frame-rate. Therefore the rotation is crazy-fast on decent
12 ;;; hardware.
13 ;;
14 ;; 16 Feb, 2004
15
16 (require :mp)
17 (require 'sdl)
18 (require 'sdl-util)
19 (require 'opengl)
20 (require 'opengl_)
21 (in-package :win)
22
23 (ct:defctype vertex-arrayf (:single-float 3))
24 (ct:defctype colour-arrayu (GLubyte 4))
25
26 (defparameter *angle* 0)
27 (defparameter *rotate* t)
28 (defparameter *rotatex* 0.0)
29 (defparameter *rotatey* 0.0)
30 (defparameter *rotatez* 0.0)
31
32 ; Many thanks, Chris Double
33 (defmacro with-glBegin (type &body body)
34 `(progn
35 (glBegin ,type)
36 (unwind-protect
37 (progn ,@body)
38 (glEnd))))
39
40 (defun opengl-set-attribute (attribute)
41 (apply #'sdl:SDL_GL_SetAttribute attribute))
42
43 (defun opengl-set-attributes (attributes)
44 (mapcar #'opengl-set-attribute attributes))
45
46 ;; Create a hash table to store the color palette for each vertices
47 (let ((hash-table (make-hash-table #|:test 'equal|#)))
48 (defun get-palette-table ()
49 hash-table))
50
51 (defun add-color (id color)
52 (if (or
53 (null color)
54 (not (ct:cpointerp color)))
55 nil
56 (setf (gethash id (get-palette-table)) color)))
57
58 (defun get-color (id)
59 (gethash id (get-palette-table)))
60
61
62 (defun create-palette ()
63 (let ((palette '(
64 (red 255 0 0 255)
65 (green 0 255 0 255)
66 (blue 0 0 255 255)
67 (white 255 255 255 255)
68 (yellow 0 255 255 255)
69 (black 0 0 0 255)
70 (orange 255 255 0 255)
71 (purple 255 0 255 0))))
72
73 (mapcar #'(lambda (color)
74 (let (
75 (color-array (ct:malloc (ct:sizeof 'colour-arrayu)))
76 (col (first color))
77 (rgb (rest color)))
78
79 (add-color col color-array)
80 (sdl:for i 0 3
81 (setf (ct:cref colour-arrayu color-array i) (nth i rgb)))))
82 palette)))
83
84 (defun create-object ()
85 (let ((cube '(
86 (-1.0 -1.0 1.0)
87 (1.0 -1.0 1.0)
88 (1.0 1.0 1.0)
89 (-1.0 1.0 1.0)
90 (-1.0 -1.0 -1.0)
91 (1.0 -1.0 -1.0)
92 (1.0 1.0 -1.0)
93 (-1.0 1.0 -1.0)))
94 (vertices nil)
95 (colors nil)
96 (polys nil))
97
98 ;;Create the vertices
99 (setf vertices
100 (mapcar #'(lambda (vertex)
101 (let ((v-array (ct:malloc (ct:sizeof 'vertex-arrayf))))
102 (sdl:for i 0 2
103 (setf (ct:cref vertex-arrayf v-array i) (nth i vertex)))
104 v-array))
105 cube))
106
107 ;;Assign a color to each vertex. Assignment is based on position in the list,
108 ;;so the first color in the colors list is assigned to the first vertex in the vertices list.
109 (setf colors (list
110 (get-color 'red)
111 (get-color 'green)
112 (get-color 'blue)
113 (get-color 'white)
114 (get-color 'yellow)
115 (get-color 'black)
116 (get-color 'orange)
117 (get-color 'purple)))
118
119 ;;Create the polygons
120 (setf polys '(
121 (0 1 2)
122 (0 2 3)
123 (1 5 6)
124 (1 6 2)
125 (5 4 7)
126 (5 7 6)
127 (4 0 3)
128 (4 3 7)
129 (3 2 6)
130 (3 6 7)
131 (1 0 4)
132 (1 4 5)))
133
134 ;Return an 'object' with the vertices, color assignment and list of polygons
135 `(
136 (vertices ,vertices)
137 (colors ,colors)
138 (polys ,polys))))
139
140 (defun assoc-data (key assoc-list)
141 (first (rest (assoc key assoc-list))))
142
143 (defun draw-screen (object)
144 (if (not (null *rotate*))
145 (setf *angle* (+ *angle* 1)))
146
147 (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
148 (glMatrixMode GL_MODELVIEW)
149 (glLoadIdentity)
150
151 (glTranslatef 0.0 0.0 -5.0)
152 (glRotatef (+ (coerce *angle* 'single-float) (coerce *rotatex* 'single-float)) 0.0 1.0 0.0)
153 (glRotatef (coerce *rotatey* 'single-float) 1.0 0.0 0.0)
154 (glRotatef (coerce *rotatez* 'single-float) 0.0 0.0 1.0)
155
156 (if (> *angle* 360.0)
157 (setf *angle* 0.0))
158
159 (with-glBegin GL_TRIANGLES
160
161 (let (
162 (vertices (assoc-data 'vertices object))
163 (colors (assoc-data 'colors object))
164 (polys (assoc-data 'polys object)))
165 (mapcar #'(lambda (poly)
166 (sdl:for i 0 2
167 (glColor4ubv (nth (nth i poly) colors))
168 (glVertex3fv (nth (nth i poly) vertices))))
169 polys)))
170
171 (sdl:SDL_GL_SwapBuffers))
172
173 (defun setup-opengl (width height)
174 (let ((ratio (coerce (/ width height) 'double-float)))
175 (opengl-set-attributes
176 (list
177 (list sdl:SDL_GL_RED_SIZE 5)
178 (list sdl:SDL_GL_GREEN_SIZE 5)
179 (list sdl:SDL_GL_BLUE_SIZE 5)
180 (list sdl:SDL_GL_DEPTH_SIZE 16)
181 (list sdl:SDL_GL_DOUBLEBUFFER 1)))
182
183 (glShadeModel GL_SMOOTH)
184 (glCullFace GL_BACK)
185 (glFrontFace GL_CCW)
186 (glEnable GL_CULL_FACE)
187 (glClearColor 0.0 0.0 0.0 0.0)
188 (glViewport 0 0 width height)
189 (glMatrixMode GL_PROJECTION)
190 (glLoadIdentity)
191 (gluPerspective 60.0d0 ratio 1.0d0 1024.0d0)))
192
193 (defun rotating-cube ()
194 (let (
195 (width 640) (height 480) (video-flags (list sdl:SDL_SWSURFACE sdl:SDL_OPENGL))
196 (cube nil))
197
198 (sdl:with-init (sdl:SDL_INIT_VIDEO)
199
200 (unless (sdl:set-videomode width height :flags video-flags)
201 (fformat "FAILED: set-videomode, cannot set the video mode")
202 (return))
203
204 (setup-opengl width height)
205 (create-palette)
206 (setf cube (create-object))
207
208 (sdl:with-events
209 (:quit t)
210 (:keydown (state keysym)
211 (when (sdl:is-key keysym sdl:SDLK_ESCAPE)
212 (sdl:push-quitevent))
213 (when (sdl:is-key keysym sdl:SDLK_SPACE)
214 (setf *rotate* (not *rotate*))))
215 (:mousemotion (state x y xrel yrel)
216 (cond
217 ((eql state 1)
218 (setf *rotatex* (+ *rotatex* xrel))
219 (setf *rotatey* (+ *rotatey* yrel )))))
220 (:idle
221 (draw-screen cube))))
222
223 (unless (sdl:init-success)
224 (sdl:fformat "ERROR: sdl-init FAILED to initialize"))))
225
226 ;;; Run the example using...
227 ;;; (setf cube (mp:process-run-function "rotating-cube" #'rotating-cube))
228 ;;; (mp:proc)
229
230 ;;; Build the exe using...
231 ;;; (SAVE-APPLICATION "rotating-cube.exe" 'rotating-cube :static t)

  ViewVC Help
Powered by ViewVC 1.1.5