[corman-sdl-cvs] CVS update: corman-sdl/examples/rotating-cube_3.lisp
Luke J Crook
lcrook at common-lisp.net
Wed Apr 14 22:08:54 UTC 2004
Update of /project/corman-sdl/cvsroot/corman-sdl/examples
In directory common-lisp.net:/tmp/cvs-serv1208/examples
Modified Files:
rotating-cube_3.lisp
Log Message:
Date: Wed Apr 14 18:08:54 2004
Author: lcrook
Index: corman-sdl/examples/rotating-cube_3.lisp
diff -u corman-sdl/examples/rotating-cube_3.lisp:1.1 corman-sdl/examples/rotating-cube_3.lisp:1.2
--- corman-sdl/examples/rotating-cube_3.lisp:1.1 Tue Apr 13 13:09:40 2004
+++ corman-sdl/examples/rotating-cube_3.lisp Wed Apr 14 18:08:54 2004
@@ -14,6 +14,7 @@
;; 26 Feb, 2004
;; Version 0.2
+(require :mp)
(require 'sdl)
(require 'sdl-util)
(require 'opengl)
@@ -57,103 +58,88 @@
(defun create-object ()
- (let ((cube (list
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf))
- (ct:malloc (ct:sizeof 'vertex-arrayf)))))
+ (let ((cube '(
+ (-1.0 -1.0 1.0)
+ (1.0 -1.0 1.0)
+ (1.0 1.0 1.0)
+ (-1.0 1.0 1.0)
+ (-1.0 -1.0 -1.0)
+ (1.0 -1.0 -1.0)
+ (1.0 1.0 -1.0)
+ (-1.0 1.0 -1.0)))
+ (vertices nil)
+ (colors nil)
+ (polys nil))
;v0[0] = -1.0f;
;v0[1] = -1.0f;
;v0[2] = 1.0f;
- (setf (ct:cref vertex-arrayf (nth 0 cube) 0) -1.0)
- (setf (ct:cref vertex-arrayf (nth 0 cube) 1) -1.0)
- (setf (ct:cref vertex-arrayf (nth 0 cube) 2) 1.0)
-
- (setf (ct:cref vertex-arrayf (nth 1 cube) 0) 1.0)
- (setf (ct:cref vertex-arrayf (nth 1 cube) 1) -1.0)
- (setf (ct:cref vertex-arrayf (nth 1 cube) 2) 1.0)
-
- (setf (ct:cref vertex-arrayf (nth 2 cube) 0) 1.0)
- (setf (ct:cref vertex-arrayf (nth 2 cube) 1) 1.0)
- (setf (ct:cref vertex-arrayf (nth 2 cube) 2) 1.0)
-
- (setf (ct:cref vertex-arrayf (nth 3 cube) 0) -1.0)
- (setf (ct:cref vertex-arrayf (nth 3 cube) 1) 1.0)
- (setf (ct:cref vertex-arrayf (nth 3 cube) 2) 1.0)
-
- (setf (ct:cref vertex-arrayf (nth 4 cube) 0) -1.0)
- (setf (ct:cref vertex-arrayf (nth 4 cube) 1) -1.0)
- (setf (ct:cref vertex-arrayf (nth 4 cube) 2) -1.0)
-
- (setf (ct:cref vertex-arrayf (nth 5 cube) 0) 1.0)
- (setf (ct:cref vertex-arrayf (nth 5 cube) 1) -1.0)
- (setf (ct:cref vertex-arrayf (nth 5 cube) 2) -1.0)
-
- (setf (ct:cref vertex-arrayf (nth 6 cube) 0) 1.0)
- (setf (ct:cref vertex-arrayf (nth 6 cube) 1) 1.0)
- (setf (ct:cref vertex-arrayf (nth 6 cube) 2) -1.0)
-
- (setf (ct:cref vertex-arrayf (nth 7 cube) 0) -1.0)
- (setf (ct:cref vertex-arrayf (nth 7 cube) 1) 1.0)
- (setf (ct:cref vertex-arrayf (nth 7 cube) 2) -1.0)
- cube))
+
+ ;;Create the vertices
+ (setf vertices
+ (mapcar #'(lambda (vertex)
+ (let ((v-array (ct:malloc (ct:sizeof 'vertex-arrayf))))
+ (sdl:for i 0 2
+ (setf (ct:cref vertex-arrayf v-array i) (nth i vertex)))
+ v-array))
+ cube))
+
+
+ ;;Assign a color to each vertex
+ (setf colors (list
+ (get-color 'red)
+ (get-color 'green)
+ (get-color 'blue)
+ (get-color 'white)
+ (get-color 'yellow)
+ (get-color 'black)
+ (get-color 'orange)
+ (get-color 'purple)))
+
+ ;;Create the polygons
+ (setf polys '(
+ (0 1 2)
+ (0 2 3)
+ (1 5 6)
+ (1 6 2)
+ (5 4 7)
+ (5 7 6)
+ (4 0 3)
+ (4 3 7)
+ (3 2 6)
+ (3 6 7)
+ (1 0 4)
+ (1 4 5)))
+
+ `(
+ (vertices ,vertices)
+ (colors ,colors)
+ (polys ,polys))))
(defun create-palette ()
- (add-color 'red (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'white (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'green (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'blue (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'yellow (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'black (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'orange (ct:malloc (ct:sizeof 'colour-arrayu)))
- (add-color 'purple (ct:malloc (ct:sizeof 'colour-arrayu)))
-
+ (let ((palette '(
+ (red 255 0 0 255)
+ (green 0 255 0 255)
+ (blue 0 0 255 255)
+ (white 255 255 255 255)
+ (yellow 0 255 255 255)
+ (black 0 0 0 255)
+ (orange 255 255 0 255)
+ (purple 255 0 255 0))))
+
+ (mapcar #'(lambda (color)
+ (let (
+ (color-array (ct:malloc (ct:sizeof 'colour-arrayu)))
+ (col (first color))
+ (rgb (rest color)))
+
+ (add-color col color-array)
+ (sdl:for i 0 3
+ (setf (ct:cref colour-arrayu color-array i) (nth i rgb)))))
+ palette)))
-
- (setf (ct:cref colour-arrayu (get-color 'red) 0) 255)
- (setf (ct:cref colour-arrayu (get-color 'red) 1) 0)
- (setf (ct:cref colour-arrayu (get-color 'red) 2) 0)
- (setf (ct:cref colour-arrayu (get-color 'red) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'green) 0) 0)
- (setf (ct:cref colour-arrayu (get-color 'green) 1) 255)
- (setf (ct:cref colour-arrayu (get-color 'green) 2) 0)
- (setf (ct:cref colour-arrayu (get-color 'green) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'blue) 0) 0)
- (setf (ct:cref colour-arrayu (get-color 'blue) 1) 0)
- (setf (ct:cref colour-arrayu (get-color 'blue) 2) 255)
- (setf (ct:cref colour-arrayu (get-color 'blue) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'white) 0) 255)
- (setf (ct:cref colour-arrayu (get-color 'white) 1) 255)
- (setf (ct:cref colour-arrayu (get-color 'white) 2) 255)
- (setf (ct:cref colour-arrayu (get-color 'white) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'yellow) 0) 0)
- (setf (ct:cref colour-arrayu (get-color 'yellow) 1) 255)
- (setf (ct:cref colour-arrayu (get-color 'yellow) 2) 255)
- (setf (ct:cref colour-arrayu (get-color 'yellow) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'black) 0) 0)
- (setf (ct:cref colour-arrayu (get-color 'black) 1) 0)
- (setf (ct:cref colour-arrayu (get-color 'black) 2) 0)
- (setf (ct:cref colour-arrayu (get-color 'black) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'orange) 0) 255)
- (setf (ct:cref colour-arrayu (get-color 'orange) 1) 255)
- (setf (ct:cref colour-arrayu (get-color 'orange) 2) 0)
- (setf (ct:cref colour-arrayu (get-color 'orange) 3) 255)
-
- (setf (ct:cref colour-arrayu (get-color 'purple) 0) 255)
- (setf (ct:cref colour-arrayu (get-color 'purple) 1) 0)
- (setf (ct:cref colour-arrayu (get-color 'purple) 2) 255)
- (setf (ct:cref colour-arrayu (get-color 'purple) 3) 0))
+(defun assoc-data (key assoc-list)
+ (first (rest (assoc key assoc-list))))
(defun draw-screen (object)
(if (not (null *rotate*))
@@ -170,90 +156,17 @@
(setf *angle* 0.0))
(with-glBegin GL_TRIANGLES
- (glColor4ubv (get-color 'red))
- (glVertex3fv (nth 0 object))
- (glColor4ubv (get-color 'green))
- (glVertex3fv (nth 1 object))
- (glColor4ubv (get-color 'blue))
- (glVertex3fv (nth 2 object))
-
- (glColor4ubv (get-color 'red))
- (glVertex3fv (nth 0 object))
- (glColor4ubv (get-color 'blue))
- (glVertex3fv (nth 2 object))
- (glColor4ubv (get-color 'white))
- (glVertex3fv (nth 3 object))
-
- (glColor4ubv (get-color 'green))
- (glVertex3fv (nth 1 object))
- (glColor4ubv (get-color 'black))
- (glVertex3fv (nth 5 object))
- (glColor4ubv (get-color 'orange))
- (glVertex3fv (nth 6 object))
-
- (glColor4ubv (get-color 'green))
- (glVertex3fv (nth 1 object))
- (glColor4ubv (get-color 'orange))
- (glVertex3fv (nth 6 object))
- (glColor4ubv (get-color 'blue))
- (glVertex3fv (nth 2 object))
-
- (glColor4ubv (get-color 'black))
- (glVertex3fv (nth 5 object))
- (glColor4ubv (get-color 'yellow))
- (glVertex3fv (nth 4 object))
- (glColor4ubv (get-color 'purple))
- (glVertex3fv (nth 7 object))
-
- (glColor4ubv (get-color 'black))
- (glVertex3fv (nth 5 object))
- (glColor4ubv (get-color 'purple))
- (glVertex3fv (nth 7 object))
- (glColor4ubv (get-color 'orange))
- (glVertex3fv (nth 6 object))
-
- (glColor4ubv (get-color 'yellow))
- (glVertex3fv (nth 4 object))
- (glColor4ubv (get-color 'red))
- (glVertex3fv (nth 0 object))
- (glColor4ubv (get-color 'white))
- (glVertex3fv (nth 3 object))
-
- (glColor4ubv (get-color 'yellow))
- (glVertex3fv (nth 4 object))
- (glColor4ubv (get-color 'white))
- (glVertex3fv (nth 3 object))
- (glColor4ubv (get-color 'purple))
- (glVertex3fv (nth 7 object))
-
- (glColor4ubv (get-color 'white))
- (glVertex3fv (nth 3 object))
- (glColor4ubv (get-color 'blue))
- (glVertex3fv (nth 2 object))
- (glColor4ubv (get-color 'orange))
- (glVertex3fv (nth 6 object))
-
- (glColor4ubv (get-color 'white))
- (glVertex3fv (nth 3 object))
- (glColor4ubv (get-color 'orange))
- (glVertex3fv (nth 6 object))
- (glColor4ubv (get-color 'purple))
- (glVertex3fv (nth 7 object))
-
- (glColor4ubv (get-color 'green))
- (glVertex3fv (nth 1 object))
- (glColor4ubv (get-color 'red))
- (glVertex3fv (nth 0 object))
- (glColor4ubv (get-color 'yellow))
- (glVertex3fv (nth 4 object))
-
- (glColor4ubv (get-color 'green))
- (glVertex3fv (nth 1 object))
- (glColor4ubv (get-color 'yellow))
- (glVertex3fv (nth 4 object))
- (glColor4ubv (get-color 'black))
- (glVertex3fv (nth 5 object)))
+ (let (
+ (vertices (assoc-data 'vertices object))
+ (colors (assoc-data 'colors object))
+ (polys (assoc-data 'polys object)))
+ (mapcar #'(lambda (poly)
+ (sdl:for i 0 2
+ (glColor4ubv (nth (nth i poly) colors))
+ (glVertex3fv (nth (nth i poly) vertices))))
+ polys)))
+
(sdl:SDL_GL_SwapBuffers))
(defun setup-opengl (width height)
@@ -279,9 +192,9 @@
(defun rotating-cube ()
(let (
(width 640) (height 480) (video-flags (list sdl:SDL_SWSURFACE sdl:SDL_OPENGL))
- (cube (create-object)))
+ (cube nil))
- (sdl:with-sdl-init (sdl:SDL_INIT_VIDEO)
+ (sdl:with-init (sdl:SDL_INIT_VIDEO)
(unless (sdl:set-videomode width height :flags video-flags)
(fformat "FAILED: set-videomode, cannot set the video mode")
@@ -289,19 +202,24 @@
(setup-opengl width height)
(create-palette)
+ (setf cube (create-object))
- (sdl:with-sdl-events
+ (sdl:with-events
(:quit t)
(:keydown (state keysym)
- (when (eql (sdl:get-key keysym) sdl:SDLK_ESCAPE)
+ (when (sdl:is-key keysym sdl:SDLK_ESCAPE)
(sdl:push-quitevent))
- (when (eql (sdl:get-key keysym) sdl:SDLK_SPACE)
+ (when (sdl:is-key keysym sdl:SDLK_SPACE)
(setf *rotate* (not *rotate*))))
(:idle
(draw-screen cube))))
- (unless (sdl:sdl-init-success)
- (fformat "ERROR: sdl-init FAILED to initialize"))))
+ (unless (sdl:init-success)
+ (sdl:fformat "ERROR: sdl-init FAILED to initialize"))))
-;;; (th:create-thread #'rotating-cube)
+;;; Run the example using...
+;;; (setf cube (mp:process-run-function "rotating-cube" #'rotating-cube))
+;;; (mp:proc)
+
+;;; Build the exe using...
;;; (SAVE-APPLICATION "rotating-cube.exe" 'rotating-cube :static t)
More information about the Corman-sdl-cvs
mailing list