April 2004 - corman-sdl-cvs@lists.common-lisp.net

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 21 Apr '04

21 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv32166/engine Modified Files: Tag: lush engine.lisp Log Message: Date: Wed Apr 21 02:09:36 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.5 corman-sdl/engine/engine.lisp:1.5.2.1 --- corman-sdl/engine/engine.lisp:1.5 Tue Apr 20 05:28:13 2004 +++ corman-sdl/engine/engine.lisp Wed Apr 21 02:09:36 2004 @@ -1,11 +1,5 @@ -;;; A bouncing ball example. -;;; Blits rectangles of random size to random positions on the screen -;;; Original work: "The Simple Direct Media Layer", Ernest S. Pazera -;;; ( http://www.gamedev.net/reference/programming/features/sdl2/page5.asp) -;;; Conversion by Luke J Crook, luke(a)balooga.com -;;; 12 June, 2003 -;;; Version 0.1 - +;;;;; Copyright (c) 2003-2004, Luke J Crook +;;;;; All rights reserved. (require 'sdl) (require 'sdl-util) (in-package :win)

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 21 Apr '04

21 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv32202/engine Modified Files: engine.lisp Log Message: Date: Wed Apr 21 02:00:13 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.6 corman-sdl/engine/engine.lisp:1.7 --- corman-sdl/engine/engine.lisp:1.6 Wed Apr 21 01:58:13 2004 +++ corman-sdl/engine/engine.lisp Wed Apr 21 02:00:13 2004 @@ -1,3 +1,11 @@ +;;; A bouncing ball example. +;;; Blits rectangles of random size to random positions on the screen +;;; Original work: "The Simple Direct Media Layer", Ernest S. Pazera +;;; ( http://www.gamedev.net/reference/programming/features/sdl2/page5.asp) +;;; Conversion by Luke J Crook, luke(a)balooga.com +;;; 12 June, 2003 +;;; Version 0.1 + (require 'sdl) (require 'sdl-util) (in-package :win)

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 21 Apr '04

21 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv19832/engine Modified Files: engine.lisp Log Message: Date: Wed Apr 21 01:58:13 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.5 corman-sdl/engine/engine.lisp:1.6 --- corman-sdl/engine/engine.lisp:1.5 Tue Apr 20 05:28:13 2004 +++ corman-sdl/engine/engine.lisp Wed Apr 21 01:58:13 2004 @@ -1,11 +1,3 @@ -;;; A bouncing ball example. -;;; Blits rectangles of random size to random positions on the screen -;;; Original work: "The Simple Direct Media Layer", Ernest S. Pazera -;;; ( http://www.gamedev.net/reference/programming/features/sdl2/page5.asp) -;;; Conversion by Luke J Crook, luke(a)balooga.com -;;; 12 June, 2003 -;;; Version 0.1 - (require 'sdl) (require 'sdl-util) (in-package :win)

1 0

[corman-sdl-cvs] CVS update: corman-sdl/ffi/sdl-util.lisp
by Luke J Crook 21 Apr '04

21 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/ffi In directory common-lisp.net:/tmp/cvs-serv28576/ffi Modified Files: sdl-util.lisp Log Message: Date: Tue Apr 20 21:23:07 2004 Author: lcrook Index: corman-sdl/ffi/sdl-util.lisp diff -u corman-sdl/ffi/sdl-util.lisp:1.1 corman-sdl/ffi/sdl-util.lisp:1.2 --- corman-sdl/ffi/sdl-util.lisp:1.1 Tue Apr 13 13:09:40 2004 +++ corman-sdl/ffi/sdl-util.lisp Tue Apr 20 21:23:07 2004 @@ -11,7 +11,7 @@ (in-package :sdl) (export '(for while aif fformat to-radian to-degree calculate-timescale get-timescale display flip with-locksurface - DisplayFormat set-flags init-sdl set-videomode destruct-sdl geterror with-events with-init loadbmp + DisplayFormat set-flags init-sdl set-videomode new-screen destruct-sdl geterror with-events with-init loadbmp get-key new-event new-rect push-quitevent getvideoinfo listmodes videomodeok add-surface get-surface calculate-timescale init-success pixelformat fill-display clear-display blit-to-display blit-to-surface fill-surface update-display set-colorkey clear-colorkey is-key moveby-rectangle moveto-rectangle @@ -133,6 +133,14 @@ (if (ct:cpointer-null surface) (set-display nil) (set-display surface)))) + +(defun new-screen (width height &key (bpp 0) (flags sdl:SDL_SWSURFACE)) + "A synonym for set-videomode. + Sets the videomode. + Returns a new SDL_Surface if successful. + Returns NIL if failed. + Use the function (DISPLAY) to retrieve the SDL_Surface returned by NEW SCREEN." + (set-videomode width height :bpp bpp :flags flags)) (defun destruct-sdl () "Shuts down SDL using SDL_Quit"

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 20 Apr '04

20 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv25748/engine Modified Files: engine.lisp Log Message: Date: Tue Apr 20 05:28:13 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.4 corman-sdl/engine/engine.lisp:1.5 --- corman-sdl/engine/engine.lisp:1.4 Mon Apr 19 21:07:55 2004 +++ corman-sdl/engine/engine.lisp Tue Apr 20 05:28:13 2004 @@ -104,7 +104,15 @@ -(defvar objects nil) +(let ((bitplanes nil)) + (defun bitplanes () + bitplanes) + (defun first-bitplane () + (if (null (dl-prev bitplanes)) + bitplanes + (setf bitplanes (dl-prev bitplanes)))) + (defun set-bitplane (bitplane) + (setf bitplanes bitplane))) (defclass sprite () ( @@ -140,11 +148,10 @@ (defun find-bitplane (zorder bitplanes) (let ((bp bitplanes) (quit nil)) - (sdl:fformat "bp == ~A, zorder == ~A~%" bp zorder) (loop (when (equal quit t) (return (values bp 'n))) (if (> zorder (get-zorder bp)) ; if test > current - (when (null (dl-next bp)) + (if (null (dl-next bp)) (setf quit t) ; end of list when next is null (setf bp (dl-next bp))) ; next node (if (equal zorder (get-zorder bp)) @@ -153,21 +160,23 @@ (defun return-bitplane (zorder bitplanes) (when (null bitplanes) - (setf objects (dl-list (new-bitplane zorder))) - (setf bitplanes objects)) + (set-bitplane (dl-list (new-bitplane zorder))) + (setf bitplanes (bitplanes))) (multiple-value-bind (bitplane pos) (find-bitplane zorder bitplanes) (cond ((equal pos 'c) (values (dl-data bitplane))) ((equal pos 'p) - (values (dl-data (dl-insert (new-bitplane zorder) bitplane)))) + (setf bitplane (dl-insert (new-bitplane zorder) bitplane)) + (first-bitplane) + (values (dl-data bitplane))) ((equal pos 'n) (values (dl-data (dl-append (new-bitplane zorder) bitplane))))))) (defun add-object (spr) (addto-bitplane - (return-bitplane (sprite-zorder spr) objects) + (return-bitplane (sprite-zorder spr) (bitplanes)) spr))

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 20 Apr '04

20 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv28960/engine Modified Files: engine.lisp Log Message: Date: Mon Apr 19 21:07:56 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.3 corman-sdl/engine/engine.lisp:1.4 --- corman-sdl/engine/engine.lisp:1.3 Mon Apr 19 04:20:15 2004 +++ corman-sdl/engine/engine.lisp Mon Apr 19 21:07:55 2004 @@ -113,7 +113,6 @@ (y :accessor sprite-y :initform 0 :initarg :y) (zorder :accessor sprite-zorder :initform 0 :initarg :zorder))) - (defun addto-bitplane (bitplane obj) (cond ((null (bitplane-end bitplane)) @@ -133,46 +132,43 @@ (make-bitplane :zorder zorder)) (defun get-zorder (obj) - (if (bitplane-p obj) - (bitplane-zorder obj) - (if (dl-p obj) + (cond + ((bitplane-p obj) + (bitplane-zorder obj)) + ((dl-p obj) (bitplane-zorder (dl-data obj))))) -(defun find-bitplane (bitplane zorder) - (let ((bp bitplane) (quit nil)) +(defun find-bitplane (zorder bitplanes) + (let ((bp bitplanes) (quit nil)) + (sdl:fformat "bp == ~A, zorder == ~A~%" bp zorder) (loop - (when (equal quit t) (return (values bp nil))) - (cond - ((equal zorder (get-zorder bp)) - (return (values bp t))) - ((< zorder (get-zorder bp)) - (if (null (dl-next bp)) - (setf quit t) - (setf bp (dl-next bp)))) - (t - (return (values bp nil))) - (t - (if (null (dl-next bp)) - (setf quit t) - (setf bp (dl-next bp)))))))) - -(defun return-zlevel (objects zorder) - "Returns the zlevel with the specified zorder. - zlevel may already exist or may be created it does not already exist" - (when (null objects) - (setf objects (dl-list (new-zlevel zorder)))) - (let ((obj nil) (found nil)) - (multiple-value-bind (obj found) - (find-zlevel objects zorder) - (cond - (found - obj) - ((null found) - (dl-append (new-zlevel zorder) obj)))) - (values obj))) + (when (equal quit t) (return (values bp 'n))) + (if (> zorder (get-zorder bp)) ; if test > current + (when (null (dl-next bp)) + (setf quit t) ; end of list when next is null + (setf bp (dl-next bp))) ; next node + (if (equal zorder (get-zorder bp)) + (return (values bp 'c)) ; test == curent, return + (return (values bp 'p))))))) ; test < current, return + +(defun return-bitplane (zorder bitplanes) + (when (null bitplanes) + (setf objects (dl-list (new-bitplane zorder))) + (setf bitplanes objects)) + (multiple-value-bind (bitplane pos) (find-bitplane zorder bitplanes) + (cond + ((equal pos 'c) + (values (dl-data bitplane))) + ((equal pos 'p) + (values (dl-data (dl-insert (new-bitplane zorder) bitplane)))) + ((equal pos 'n) + (values (dl-data (dl-append (new-bitplane zorder) bitplane))))))) + (defun add-object (spr) - (addto-level (dl-data (return-zlevel objects (sprite-zorder spr))) spr)) + (addto-bitplane + (return-bitplane (sprite-zorder spr) objects) + spr))

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 19 Apr '04

19 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv32714/engine Modified Files: engine.lisp Log Message: Date: Mon Apr 19 04:20:15 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.2 corman-sdl/engine/engine.lisp:1.3 --- corman-sdl/engine/engine.lisp:1.2 Wed Apr 14 21:54:18 2004 +++ corman-sdl/engine/engine.lisp Mon Apr 19 04:20:15 2004 @@ -90,7 +90,13 @@ (return obj) (setf obj (dl-next obj)))))) -(defstruct (zlevel) + + + + + + +(defstruct (bitplane) zorder start end) @@ -108,47 +114,47 @@ (zorder :accessor sprite-zorder :initform 0 :initarg :zorder))) -(defun addto-level (zlevel obj) - (cond - ((null (zlevel-end zlevel)) - (setf (zlevel-end zlevel) (dl-list obj)) - (setf (zlevel-start zlevel) (zlevel-end zlevel))) - (t - (setf (zlevel-end zlevel) (dl-append obj (zlevel-end zlevel)))))) - -(defun add-level (object level) +(defun addto-bitplane (bitplane obj) (cond - ((null (zlevel-end level)) - (setf (zlevel-end level) (dl-list object)) - (setf (zlevel-start level) (zlevel-end level))) + ((null (bitplane-end bitplane)) + (setf (bitplane-end bitplane) (dl-list obj)) + (setf (bitplane-start bitplane) (bitplane-end bitplane))) (t - (setf (zlevel-end level) (dl-append object (zlevel-end level)))))) + (setf (bitplane-end bitplane) (dl-append obj (bitplane-end bitplane)))))) -(defun remove-from-level (zlevel obj) +(defun removefrom-bitplane (bitplane obj) (when (null (dl-next obj)) - (setf (zlevel-end zlevel) (dl-prev obj))) + (setf (bitplane-end bitplane) (dl-prev obj))) (when (null (dl-prev obj)) - (setf (zlevel-start zlevel) (dl-next obj))) + (setf (bitplane-start bitplane) (dl-next obj))) (dl-remove obj)) -(defun new-zlevel (zorder) - (make-zlevel :zorder zorder)) +(defun new-bitplane (zorder) + (make-bitplane :zorder zorder)) -(defun find-zlevel (level zorder) - (if (null level) - (values nil nil) - (let ((obj level) (quit nil)) - (loop - (when (equal quit t) (values obj nil)) - (cond - ((equal zorder (zlevel-zorder (dl-data obj))) - (return (values obj t))) - ((> zorder (zlevel-zorder (dl-data obj))) - (return (values obj nil))) - (t - (if (null (dl-next obj)) - (setf quit t) - (setf obj (dl-next obj))))))))) +(defun get-zorder (obj) + (if (bitplane-p obj) + (bitplane-zorder obj) + (if (dl-p obj) + (bitplane-zorder (dl-data obj))))) + +(defun find-bitplane (bitplane zorder) + (let ((bp bitplane) (quit nil)) + (loop + (when (equal quit t) (return (values bp nil))) + (cond + ((equal zorder (get-zorder bp)) + (return (values bp t))) + ((< zorder (get-zorder bp)) + (if (null (dl-next bp)) + (setf quit t) + (setf bp (dl-next bp)))) + (t + (return (values bp nil))) + (t + (if (null (dl-next bp)) + (setf quit t) + (setf bp (dl-next bp)))))))) (defun return-zlevel (objects zorder) "Returns the zlevel with the specified zorder.

1 0

[corman-sdl-cvs] CVS update: corman-sdl/examples/rotating-cube_3.lisp
by Luke J Crook 17 Apr '04

17 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/examples In directory common-lisp.net:/tmp/cvs-serv21416/examples Modified Files: rotating-cube_3.lisp Log Message: Date: Fri Apr 16 20:02:09 2004 Author: lcrook Index: corman-sdl/examples/rotating-cube_3.lisp diff -u corman-sdl/examples/rotating-cube_3.lisp:1.2 corman-sdl/examples/rotating-cube_3.lisp:1.3 --- corman-sdl/examples/rotating-cube_3.lisp:1.2 Wed Apr 14 18:08:54 2004 +++ corman-sdl/examples/rotating-cube_3.lisp Fri Apr 16 20:02:09 2004 @@ -1,18 +1,17 @@ ;;; A rotating cube example. -;;; Taken from the SDL example http://sdldoc.csn.ul.ie/guidevideoopengl.php +;;; Taken from the SDL example at http://sdldoc.csn.ul.ie/guidevideoopengl.php ;;; Author: Luke J Crook, luke(a)balooga.com ;;; ;;; Operation: -;;; - Click any mouse button to pause/restart rotation. +;;; - Press any key (except Escape) to pause/restart rotation. +;;; - Press Escape to exit. +;;; - Left-click and use the mouse to rotate the cube around the x/y axises. ;;; ;;; Issues: ;;; - Rotation is not scaled to time but is based on frame-rate. Therefore the rotation is crazy-fast on decent ;;; hardware. -;;; - Tends to crash the CCL IDE after being run a few times, so SAVE YOUR WORK. Author is not responsible for -;; any damage to hardware, loss of data, weight gain, hair loss etc. Use at your own risk. ;; -;; 26 Feb, 2004 -;; Version 0.2 +;; 16 Feb, 2004 (require :mp) (require 'sdl) @@ -26,6 +25,9 @@ (defparameter *angle* 0) (defparameter *rotate* t) +(defparameter *rotatex* 0.0) +(defparameter *rotatey* 0.0) +(defparameter *rotatez* 0.0) ; Many thanks, Chris Double (defmacro with-glBegin (type &body body) @@ -57,6 +59,28 @@ (gethash id (get-palette-table))) +(defun create-palette () + (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))) + (defun create-object () (let ((cube '( (-1.0 -1.0 1.0) @@ -71,10 +95,6 @@ (colors nil) (polys nil)) - ;v0[0] = -1.0f; - ;v0[1] = -1.0f; - ;v0[2] = 1.0f; - ;;Create the vertices (setf vertices (mapcar #'(lambda (vertex) @@ -83,9 +103,9 @@ (setf (ct:cref vertex-arrayf v-array i) (nth i vertex))) v-array)) cube)) - - - ;;Assign a color to each vertex + + ;;Assign a color to each vertex. Assignment is based on position in the list, + ;;so the first color in the colors list is assigned to the first vertex in the vertices list. (setf colors (list (get-color 'red) (get-color 'green) @@ -111,33 +131,12 @@ (1 0 4) (1 4 5))) + ;Return an 'object' with the vertices, color assignment and list of polygons `( (vertices ,vertices) (colors ,colors) (polys ,polys)))) -(defun create-palette () - (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))) - (defun assoc-data (key assoc-list) (first (rest (assoc key assoc-list)))) @@ -150,8 +149,10 @@ (glLoadIdentity) (glTranslatef 0.0 0.0 -5.0) - (glRotatef (coerce *angle* 'single-float) 0.0 1.0 0.0) - + (glRotatef (+ (coerce *angle* 'single-float) (coerce *rotatex* 'single-float)) 0.0 1.0 0.0) + (glRotatef (coerce *rotatey* 'single-float) 1.0 0.0 0.0) + (glRotatef (coerce *rotatez* 'single-float) 0.0 0.0 1.0) + (if (> *angle* 360.0) (setf *angle* 0.0)) @@ -211,6 +212,11 @@ (sdl:push-quitevent)) (when (sdl:is-key keysym sdl:SDLK_SPACE) (setf *rotate* (not *rotate*)))) + (:mousemotion (state x y xrel yrel) + (cond + ((eql state 1) + (setf *rotatex* (+ *rotatex* xrel)) + (setf *rotatey* (+ *rotatey* yrel ))))) (:idle (draw-screen cube))))

1 0

[corman-sdl-cvs] CVS update: corman-sdl/engine/engine.lisp
by Luke J Crook 15 Apr '04

15 Apr '04

Update of /project/corman-sdl/cvsroot/corman-sdl/engine In directory common-lisp.net:/tmp/cvs-serv20122/engine Modified Files: engine.lisp Log Message: Date: Wed Apr 14 21:54:18 2004 Author: lcrook Index: corman-sdl/engine/engine.lisp diff -u corman-sdl/engine/engine.lisp:1.1 corman-sdl/engine/engine.lisp:1.2 --- corman-sdl/engine/engine.lisp:1.1 Tue Apr 13 13:09:39 2004 +++ corman-sdl/engine/engine.lisp Wed Apr 14 21:54:18 2004 @@ -15,6 +15,8 @@ ;;;;; Link list functions (defstruct (dl (:print-function print-dl)) + "Linked list node + dl-prev, dl-data, dl-next" prev data next) (defun print-dl (dl stream depth) @@ -27,6 +29,7 @@ lst)) (defun dl-insert (x lst) + "Insert the item into the list before the node" (let ((elt (make-dl :data x :next lst))) (when (dl-p lst) (if (dl-prev lst) @@ -36,6 +39,7 @@ elt)) (defun dl-append (x lst) + "Insert the item into the list after the node" (let ((elt (make-dl :data x :prev lst))) (when (dl-p lst) (if (dl-next lst) @@ -45,10 +49,12 @@ elt)) (defun dl-list (&rest args) + "Create a linked list from the arguments provided as input" (reduce #'dl-insert args :from-end t :initial-value nil)) (defun dl-remove (lst) + "Remove the node from the linked list" (if (dl-prev lst) (setf (dl-next (dl-prev lst)) (dl-next lst))) (if (dl-next lst) @@ -56,16 +62,27 @@ (dl-next lst)) (defun dl-nextnode (lst) + "Return the next node in the list + Returns two values, + The next node in the list when dl-next is not nil + A value indicating if the next node is returned, or nill if the last node in the list" (if (null (dl-next lst)) (values lst nil) (values (dl-next lst) t))) (defun dl-prevnode (lst) + "Return the previous node in the list + Returns two values, + The previous node in the list if dl-prev is not nil + A value indicating if the previous node is returned, or nill if the first node in the list" (if (null (dl-prev lst)) (values lst nil) (values (dl-prev lst) t))) (defun dl-find (dl func) + "Find the first node in the list where the test function returns true + Searches front to back, starting at dl, which may not necessarily be the + front of the list" (let ((obj dl)) (loop (when (null obj) (return nil)) @@ -99,13 +116,13 @@ (t (setf (zlevel-end zlevel) (dl-append obj (zlevel-end zlevel)))))) -(defun add-level (objects level) +(defun add-level (object level) (cond - ((null (zlevel-end zlevel)) - (setf (zlevel-end zlevel) (dl-list obj)) - (setf (zlevel-start zlevel) (zlevel-end zlevel))) + ((null (zlevel-end level)) + (setf (zlevel-end level) (dl-list object)) + (setf (zlevel-start level) (zlevel-end level))) (t - (setf (zlevel-end zlevel) (dl-append obj (zlevel-end zlevel)))))) + (setf (zlevel-end level) (dl-append object (zlevel-end level)))))) (defun remove-from-level (zlevel obj) (when (null (dl-next obj)) @@ -117,173 +134,55 @@ (defun new-zlevel (zorder) (make-zlevel :zorder zorder)) -(defun new-find-zlevel (zorder) - #'(lambda (dl) - (cond - ((equal (sprite-id (dl-data dl)) zorder) - dl - nil))) - -(defun find-zlevel (levels zorder) - (if (null levels) +(defun find-zlevel (level zorder) + (if (null level) (values nil nil) - (let ((obj objects)) + (let ((obj level) (quit nil)) (loop - (when (null obj) (return)) + (when (equal quit t) (values obj nil)) (cond ((equal zorder (zlevel-zorder (dl-data obj))) (return (values obj t))) ((> zorder (zlevel-zorder (dl-data obj))) (return (values obj nil))) (t - (setf obj (dl-next obj)))))))) - - - - -(defun add-zlevel (objects zlevel) - - - - + (if (null (dl-next obj)) + (setf quit t) + (setf obj (dl-next obj))))))))) + +(defun return-zlevel (objects zorder) + "Returns the zlevel with the specified zorder. + zlevel may already exist or may be created it does not already exist" + (when (null objects) + (setf objects (dl-list (new-zlevel zorder)))) + (let ((obj nil) (found nil)) + (multiple-value-bind (obj found) + (find-zlevel objects zorder) + (cond + (found + obj) + ((null found) + (dl-append (new-zlevel zorder) obj)))) + (values obj))) (defun add-object (spr) - (when (null objects) - (setf objects (new-zlevel (sprite-id spr)))) - (let ((obj (dl-find objects (new-find-zlevel (sprite-id spr))))) - (if obj - ( - + (addto-level (dl-data (return-zlevel objects (sprite-zorder spr))) spr)) + + -(defun add-to (obj l) - (nconc l (list obj))) -(defstruct node - (prev nil) - (next nil) - data) - -(defun insert (data zorder llist) - (if (null llist) - (make-node :data (cons zorder (add-to data nil))) - (if (eql (first (node-data llist)) zorder) - (add-to data (node-data llist)) - (if (> (first (node-data llist)) zorder) - (let ((node (make-node - :data (cons zorder (add-to data (node-data llist))) - :next llist - :prev (node-prev llist)))) - (setf (node-prev llist) node)) - (if (null (node-next llist)) - (let ((node (make-node - :data (cons zorder (add-to data (node-data llist))) - :prev llist))) - (setf (node-next llist) node)) - (insert data zorder (node-next llist))))))) - - -(setf a-list '(1 2 3 4 5)) -(setf b-list '(a b c d e)) -(setf (cdr a-list) b-list) -(setf a-list nil) - -(cdr (car b-list)) - - - -#|(defun insert-into (lst node &optional (func #'<)) - (if (null lst) - (cons node nil) - (if (funcall func (first lst) node) - (progn - (setf (cdr lst) (insert-into (rest lst) node func)) - lst) - (cons node lst)))) -|# - -#|(defun insert (lst node zorder &optional (func #'<)) - (if (null lst) - (cons (list zorder node) nil) - (cond - ((funcall func (first (first lst)) zorder) - (setf (cdr lst) (insert (cdr lst) node zorder func)) - lst) - ((= (first (first lst)) zorder) - (setf (cdr (first lst)) (insert-into (cdr (first lst)) node func)) - lst) - (t - (cons (list zorder node) lst))))) - -(defun get-zorder (lst) - (if (null lst) - nil - (first (first lst)))) - -(defun insert (lst node zorder &optional (func #'<)) - (if (null lst) - (cons (list zorder node) nil) - (cond - ((funcall func (get-zorder lst) zorder) - (setf (cdr lst) (insert (cdr lst) node zorder func)) - lst) - ((= (get-zorder lst) zorder) - (setf (cdr (first lst)) (insert-into (cdr (first lst)) node func)) - lst) - (t - (cons (list zorder node) lst))))) -|# -(defun add-to (lst nodes) - (cond - ((and (null lst) (listp nodes)) - nodes) - ((null lst) - (cons nodes nil)) - (t - (let ((l (last lst))) - (if (listp nodes) - (setf (cdr l) nodes) - (setf (cdr l) (cons nodes nil))))))) - - - ((listp nodes) - (setf lst nodes)) - (t - (cons (last lst) nodes)))) -(defun insert (lst zorder nodes) - (if (null lst) - (cons (list - zorder - (add-to nil nodes)) - nil) - (cond - ((< (get-zorder lst) zorder) - (setf (cdr lst) (insert (cdr lst) zorder nodes)) - lst) - ((= (get-zorder lst) zorder) - (setf (cdr (first lst)) (add-to (cdr (first lst)) nodes)) - lst) - (t - (cons (list zorder (add-to nil nodes)) lst))))) -;(1 a b c d) -(setf b-list '(2 e f g h)) -(last b-list) -(setf a-list nil) -(setf a-list (insert a-list 1 '(200 300 100 400 500))) -(setf a-list (insert a-list 1 2)) -(setf a-list (insert-into a-list 0 #'<)) -(untrace insert-into) + -a-list (defclass engine () @@ -294,57 +193,6 @@ -(defclass sprites () - ( - (sprite-list :accessor sprites))) - -(defun get-zorder (slist) - (if (null slist) - nil - (if (listp slist) - (first slist)))) - -(defun add-to (sprites sprite) - (nconc sprites (list sprite))) - -(defun insert-at (slist s z) - (cond - ((null slist) - (list (cons z (add-to nil s)))) - ((listp (first slist)) - (insert-at (first slist) s z)) - ((eql (first slist) z) - (add-to slist s)) - ((< (first slist) z) - (add-to (rest slist) s)))) - - -(defmethod add-sprite ((sp-list sprites) (s sprite)) - (let ((sprite-list (sprites sp-list))) - (cond - ((if (eql (z-order s) (z-order sprites)))) - ((null sprite-list) - (setf sprite-list - (cons - (z-order s) sprite-list) - s)))))) - - -(defmethod add-sprite ((sprites sp-list) (s sprite)) - ( - - - -(defmethod set-videosurface ((e engine) s) - (when (and - (not (null s)) - (ct:cpointerp s)) - (setf (engine-surface e) s))) - - - -(defmethod add-sprite ((e engine) (s sprite)) - )

1 0

[corman-sdl-cvs] CVS update: corman-sdl/examples/rotating-cube_3.lisp
by Luke J Crook 14 Apr '04

14 Apr '04

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)

1 0