--- /dev/null
+;;; Gacela, a GNU Guile extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Default values for Gacela
+(define *width-screen* 640)
+(define *height-screen* 480)
+(define *bpp-screen* 32)
+(define *frames-per-second* 20)
+
+;;; SDL Initialization Subsystem
+(let (initialized)
+
+ (define (init-sdl)
+ (cond ((null initialized) (set! initialized (SDL_Init SDL_INIT_EVERYTHING)))
+ (#t initialized)))
+
+ (define (quit-sdl)
+ (set! initialized (SDL_Quit))))
+
+
+;;; Video Subsystem
+(let (screen flags (current-width *width-screen*) (current-height *height-screen*) current-bpp)
+
+ (defun init-video-mode (&key (width current-width) (height current-height) (bpp *bpp-screen*))
+ (cond ((null screen)
+ (init-sdl)
+ (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
+ (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
+ (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
+ (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL)))
+ (setq screen (SDL_SetVideoMode width height bpp flags))
+ (init-GL)
+ (resize-screen-GL width height)
+ (setq current-width width current-height height current-bpp bpp))
+ (t t)))
+
+ (defun resize-screen (width height &optional (bpp current-bpp))
+ (cond (screen (setq screen (SDL_SetVideoMode width height bpp flags))
+ (resize-screen-GL width height)))
+ (setq current-width width current-height height))
+
+ (defun apply-mode-change ()
+ (resize-screen-GL current-width current-height))
+
+ (defun quit-video-mode ()
+ (setq screen nil)))
+
+(defun set-2d-mode ()
+ (cond ((not (3d-mode?))
+ (init-video-mode)
+ (glDisable GL_DEPTH_TEST)
+ (apply-mode-change))))
+
+(defun set-3d-mode ()
+ (cond ((3d-mode?)
+ (init-video-mode)
+ (glClearDepth 1)
+ (glEnable GL_DEPTH_TEST)
+ (glDepthFunc GL_LEQUAL)
+ (apply-mode-change))))
+
+(defun 3d-mode? ()
+ (eq (getf (get-game-properties) :mode) '3d))
+
+(defun init-GL ()
+ (glShadeModel GL_SMOOTH)
+ (glClearColor 0 0 0 0)
+; (glClearDepth 1)
+; (glDepthFunc GL_LEQUAL)
+; (glEnable GL_BLEND)
+; (glBlendFunc GL_SRC_ALPHA GL_ONE)
+ (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
+ t)
+
+(defun init-lighting ()
+ (init-video-mode)
+ (glEnable GL_LIGHTING))
+
+(defun resize-screen-GL (width height)
+ (glViewPort 0 0 width height)
+ (glMatrixMode GL_PROJECTION)
+ (glLoadIdentity)
+ (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height))))
+ (gluPerspective 45 ratio 0.1 100))) ;0.1
+ (t (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h)))
+ (glOrtho -w w -h h 0 1))))
+ (glMatrixMode GL_MODELVIEW)
+ (glLoadIdentity)
+ t))
+
+(let ((current-color '(1 1 1 1)))
+ (defun get-current-color ()
+ current-color)
+
+ (defun set-current-color (red green blue &optional (alpha 1))
+ (setq current-color (list red green blue alpha))
+ (glColor4f red green blue alpha)))
+
+(defun load-image (image-file &key (transparent-color nil))
+ (init-video-mode)
+ (let ((loaded-image (IMG_Load image-file)))
+ (cond ((= loaded-image 0) nil)
+ (t (let ((optimized-image (SDL_DisplayFormat loaded-image)))
+ (SDL_FreeSurface loaded-image)
+ (cond ((= optimized-image 0) nil)
+ ((null transparent-color) optimized-image)
+ (t (SDL_SetColorKey optimized-image
+ SDL_SRCCOLORKEY
+ (SDL_MapRGB (surface-format optimized-image)
+ (car transparent-color)
+ (cadr transparent-color)
+ (caddr transparent-color)))
+ optimized-image)))))))
+
+
+;;; Audio Subsystem
+(let ((audio nil))
+
+ (defun init-audio ()
+ (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096))))
+ (t audio)))
+
+ (defun quit-audio ()
+ (setq audio (Mix_CloseAudio))))
+
+
+;;; Resources Manager
+(defstruct resource plist constructor destructor time)
+
+(defun make-resource-texture (&key filename min-filter mag-filter)
+ `(:type texture :filename ,filename :min-filter ,min-filter :mag-filter ,mag-filter))
+
+(defun make-resource-font (&key filename encoding)
+ `(:type font :filename ,filename :enconding ,encoding))
+
+(defun make-resource-sound (&key filename)
+ `(:type sound :filename ,filename))
+
+(defun make-resource-music (&key filename)
+ `(:type music :filename ,filename))
+
+(defmacro get-rtime (key)
+ `(resource-time (gethash ,key resources-table)))
+
+(defmacro get-rplist (key)
+ `(resource-plist (gethash ,key resources-table)))
+
+(defmacro get-rconstructor (key)
+ `(resource-constructor (gethash ,key resources-table)))
+
+(defmacro get-rdestructor (key)
+ `(resource-destructor (gethash ,key resources-table)))
+
+(let ((resources-table (make-hash-table :test 'equal))
+ (expiration-time 50000))
+
+ (defun set-expiration-time (new-time)
+ (setq expiration-time new-time))
+
+ (defun set-resource (key plist constructor destructor &key static)
+ (expire-resources)
+ (setf (gethash key resources-table)
+ (make-resource :plist plist
+ :constructor constructor
+ :destructor destructor
+ :time (if static t (SDL_GetTicks)))))
+
+ (defun get-resource (key)
+ (cond ((null (gethash key resources-table)) nil)
+ (t (let ((time (get-rtime key)))
+ (cond ((null time) (funcall (get-rconstructor key)))
+ ((numberp time) (setf (get-rtime key) (SDL_GetTicks))))
+ (get-rplist key)))))
+
+ (defun free-resource (key)
+ (funcall (get-rdestructor key))
+ (setf (get-rtime key) nil))
+
+ (defun expire-resource (key &optional (now (SDL_GetTicks)))
+ (let ((time (get-rtime key)))
+ (cond ((and (numberp time) (> (- now time) expiration-time)) (free-resource key)))))
+
+ (defun expire-resources ()
+ (maphash (lambda (key res) (expire-resource key)) resources-table))
+
+ (defun free-all-resources ()
+ (maphash (lambda (key res) (free-resource key)) resources-table)))
+
+
+;;; Connection with Gacela Clients
+(let (server-socket clients)
+ (defun start-server (port)
+ (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-connections)))))
+
+ (defun check-connections ()
+ (cond ((and server-socket (listen server-socket)) (setq clients (cons (si::accept server-socket) clients)))))
+
+ (defun eval-from-clients ()
+ (labels ((eval-clients (cli-socks)
+ (cond (cli-socks
+ (let ((cli (car cli-socks)))
+ (cond ((si::listen cli)
+ (secure-block cli (eval (read cli)))
+ (si::close cli)
+ (eval-clients (cdr cli-socks)))
+ (t
+ (cons cli (eval-clients (cdr cli-socks))))))))))
+ (setq clients (eval-clients clients))))
+
+ (defun stop-server ()
+ (cond (server-socket (si::close server-socket) (setq server-socket nil)))
+ (cond (clients
+ (labels ((close-clients (cli-socks)
+ (si::close (car cli-socks))
+ (close-clients (cdr cli-socks))))
+ (close-clients clients))
+ (setq clients nil)))))
+
+
+;;; GaCeLa Functions
+(let (time (time-per-frame (/ 1000.0 *frames-per-second*)))
+ (defun set-frames-per-second (fps)
+ (setq time-per-frame (/ 1000.0 fps)))
+
+ (defun init-frame-time ()
+ (setq time (SDL_GetTicks)))
+
+ (defun delay-frame ()
+ (let ((frame-time (- (SDL_GetTicks) time)))
+ (cond ((< frame-time time-per-frame)
+ (SDL_Delay (- time-per-frame frame-time)))))))
+
+
+(let ((ptitle "") (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode '2d))
+ (defun set-game-properties (&key title width height bpp fps mode)
+ (init-video-mode)
+ (when title (progn (setq ptitle title) (SDL_WM_SetCaption title "")))
+ (when (or width height bpp)
+ (progn
+ (when width (setq pwidth width))
+ (when height (setq pheight height))
+ (when bpp (setq pbpp bpp))
+ (resize-screen pwidth pheight pbpp)))
+ (when fps (progn (setq pfps fps) (set-frames-per-second fps)))
+ (when mode (progn (setq pmode mode) (if (eq mode '3d) (set-3d-mode) (set-2d-mode))))
+ (get-game-properties))
+
+ (defun get-game-properties ()
+ (list :title ptitle :width pwidth :height pheight :bpp pbpp :fps pfps :mode pmode)))
+
+
+(defmacro run-game (&body code)
+ `(let ((game-function (lambda () ,@code)))
+ (init-video-mode)
+ (set-game-code game-function)
+ (cond ((not (game-running?))
+ (game-loop)))))
+
+(let (running game-code)
+ (defun game-loop ()
+ (setq running t)
+ (do () ((quit?))
+ (init-frame-time)
+ (check-connections)
+ (eval-from-clients)
+ (process-events)
+ (cond ((not (quit?))
+ (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+ (to-origin)
+ (refresh-active-objects)
+ (when (functionp game-code) (funcall game-code))
+ (render-objects)
+ (SDL_GL_SwapBuffers)
+ (delay-frame))))
+ (setq running nil))
+
+ (defun game-running? ()
+ running)
+
+ (defun set-game-code (game-function)
+ (setq game-code game-function)))
+
+(defun quit-game ()
+ (free-all-resources)
+ (quit-audio)
+ (quit-video-mode)
+; (quit-all-mobs)
+ (kill-all-objects)
+; (clear-events)
+; (quit-events)
+ (quit-sdl))
return SCM_UNSPECIFIED;
}
+SCM
+gacela_glClear (SCM mask)
+{
+ glClear (scm_to_int (mask));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glClearColor (SCM red, SCM green, SCM blue, SCM alpha)
+{
+ glClearColor (scm_to_double (red), scm_to_double (green), scm_to_double (blue), scm_to_double (alpha));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glClearDepth (SCM depth)
+{
+ glClearDepth (scm_to_double (depth));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glColor3f (SCM red, SCM green, SCM blue)
+{
+ glColor3f (scm_to_double (red), scm_to_double (green), scm_to_double (blue));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glColor4f (SCM red, SCM green, SCM blue, SCM alpha)
+{
+ glColor4f (scm_to_double (red), scm_to_double (green), scm_to_double (blue), scm_to_double (alpha));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glDepthFunc (SCM func)
+{
+ glDepthFunc (scm_to_int (func));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glEnable (SCM cap)
+{
+ glEnable (scm_to_int (cap));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glDisable (SCM cap)
+{
+ glDisable (scm_to_int (cap));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glEnd (void)
+{
+ glEnd ();
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glHint (SCM target, SCM mode)
+{
+ glHint (scm_to_int (target), scm_to_int (mode));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glLoadIdentity (void)
+{
+ glLoadIdentity ();
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glMatrixMode (SCM mode)
+{
+ glMatrixMode (scm_to_int (mode));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glRotatef (SCM angle, SCM x, SCM y, SCM z)
+{
+ glRotatef (scm_to_double (angle), scm_to_double (x), scm_to_double (y), scm_to_double (z));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glShadeModel (SCM mode)
+{
+ glShadeModel (scm_to_int (mode));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glTranslatef (SCM x, SCM y, SCM z)
+{
+ glTranslatef (scm_to_double (x), scm_to_double (y), scm_to_double (z));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glVertex2f (SCM x, SCM y)
+{
+ glVertex2f (scm_to_double (x), scm_to_double (y));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glVertex3f (SCM x, SCM y, SCM z)
+{
+ glVertex3f (scm_to_double (x), scm_to_double (y), scm_to_double (z));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glViewport (SCM x, SCM y, SCM width, SCM height)
+{
+ glViewport (scm_to_int (x), scm_to_int (y), scm_to_int (width), scm_to_int (height));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glGenTextures (SCM n)
+{
+ SCM textures;
+ int nint = scm_to_int (n);
+ GLuint text[nint];
+ int i;
+
+ textures = scm_list_n (SCM_UNDEFINED);
+ glGenTextures (nint, &text[0]);
+
+ for (i = nint - 1; i >= 0; i--) {
+ textures = scm_cons (scm_from_int (text[i]), textures);
+ }
+
+ return textures;
+}
+
+SCM
+gacela_glDeleteTextures (SCM n, SCM textures)
+{
+ int nint = scm_to_int (n);
+ GLuint text[nint];
+ int i;
+
+ for (i = 0; i < nint; i++) {
+ text[i] = scm_to_int (scm_list_ref (textures, scm_from_int (i)));
+ }
+
+ glDeleteTextures (nint, &text[0]);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glBindTexture (SCM target, SCM texture)
+{
+ glBindTexture (scm_to_int (target), scm_to_int (texture));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glTexImage2D (SCM target, SCM level, SCM internalFormat, SCM width, SCM height, SCM border, SCM format, SCM type, SCM pixels)
+{
+ glTexImage2D (scm_to_int (target), scm_to_int (level), scm_to_int (internalFormat), scm_to_int (width), \
+ scm_to_int (height), scm_to_int (border), scm_to_int (format), scm_to_int (type), \
+ (GLvoid *)scm_to_int (pixels));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glTexParameteri (SCM target, SCM pname, SCM param)
+{
+ glTexParameteri (scm_to_int (target), scm_to_int (pname), scm_to_int (param));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glTexCoord2f (SCM s, SCM t)
+{
+ glTexCoord2f (scm_to_double (s), scm_to_double (t));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glLightfv (SCM light, SCM pname, SCM params)
+{
+ int n = scm_to_int (scm_length (params));
+ GLfloat gl_params[n];
+ int i;
+
+ for (i = 0; i < n; i++) {
+ gl_params[i] = scm_to_double (scm_list_ref (params, scm_from_int (i)));
+ }
+
+ glLightfv (scm_to_int (light), scm_to_int (pname), gl_params);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glNormal3f (SCM nx, SCM ny, SCM nz)
+{
+ glNormal3f (scm_to_double (nx), scm_to_double (ny), scm_to_double (nz));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glBlendFunc (SCM sfactor, SCM dfactor)
+{
+ glBlendFunc (scm_to_int (sfactor), scm_to_int (dfactor));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glOrtho (SCM left, SCM right, SCM bottom, SCM top, SCM near_val, SCM far_val)
+{
+ glOrtho (scm_to_double (left), scm_to_double (right), scm_to_double (bottom), scm_to_double (top), \
+ scm_to_double (near_val), scm_to_double (far_val));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glPushMatrix (void)
+{
+ glPushMatrix ();
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_glPopMatrix (void)
+{
+ glPopMatrix ();
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_gluPerspective (SCM fovy, SCM aspect, SCM zNear, SCM zFar)
+{
+ gluPerspective (scm_to_double (fovy), scm_to_double (aspect), scm_to_double (zNear), scm_to_double (zFar));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+gacela_gluBuild2DMipmaps (SCM target, SCM internalFormat, SCM width, SCM height, SCM format, SCM type, SCM data)
+{
+ return scm_from_int (gluBuild2DMipmaps (scm_to_int (target), scm_to_int (internalFormat), scm_to_int (width), \
+ scm_to_int (height), scm_to_int (format), scm_to_int (type), \
+ (void *)scm_to_int (data)));
+}
+
+SCM
+gacela_gluLookAt (SCM eyeX, SCM eyeY, SCM eyeZ, SCM centerX, SCM centerY, SCM centerZ, SCM upX, SCM upY, SCM upZ)
+{
+ gluLookAt (scm_to_double (eyeX), scm_to_double (eyeY), scm_to_double (eyeZ), \
+ scm_to_double (centerX), scm_to_double (centerY), scm_to_double (centerZ), \
+ scm_to_double (upX), scm_to_double (upY), scm_to_double (upZ));
+ return SCM_UNSPECIFIED;
+}
+
void*
GL_register_functions (void* data)
scm_c_define_gsubr ("glBegin", 1, 0, 0, gacela_glBegin);
+ scm_c_define_gsubr ("glClear", 1, 0, 0, gacela_glClear);
+ scm_c_define_gsubr ("glClearColor", 4, 0, 0, gacela_glClearColor);
+ scm_c_define_gsubr ("glClearDepth", 1, 0, 0, gacela_glClearDepth);
+ scm_c_define_gsubr ("glColor3f", 3, 0, 0, gacela_glColor3f);
+ scm_c_define_gsubr ("glColor4f", 4, 0, 0, gacela_glColor4f);
+ scm_c_define_gsubr ("glDepthFunc", 1, 0, 0, gacela_glDepthFunc);
+ scm_c_define_gsubr ("glEnable", 1, 0, 0, gacela_glEnable);
+ scm_c_define_gsubr ("glDisable", 1, 0, 0, gacela_glDisable);
+ scm_c_define_gsubr ("glEnd", 0, 0, 0, gacela_glEnd);
+ scm_c_define_gsubr ("glHint", 2, 0, 0, gacela_glHint);
+ scm_c_define_gsubr ("glLoadIdentity", 0, 0, 0, gacela_glLoadIdentity);
+ scm_c_define_gsubr ("glMatrixMode", 1, 0, 0, gacela_glMatrixMode);
+ scm_c_define_gsubr ("glRotatef", 4, 0, 0, gacela_glRotatef);
+ scm_c_define_gsubr ("glShadeModel", 1, 0, 0, gacela_glShadeModel);
+ scm_c_define_gsubr ("glTranslatef", 3, 0, 0, gacela_glTranslatef);
+ scm_c_define_gsubr ("glVertex2f", 2, 0, 0, gacela_glVertex2f);
+ scm_c_define_gsubr ("glVertex3f", 3, 0, 0, gacela_glVertex3f);
+ scm_c_define_gsubr ("glViewport", 4, 0, 0, gacela_glViewport);
+ scm_c_define_gsubr ("glGenTextures", 1, 0, 0, gacela_glGenTextures);
+ scm_c_define_gsubr ("glDeleteTextures", 2, 0, 0, gacela_glDeleteTextures);
+ scm_c_define_gsubr ("glBindTexture", 2, 0, 0, gacela_glBindTexture);
+ scm_c_define_gsubr ("glTexImage2D", 9, 0, 0, gacela_glTexImage2D);
+ scm_c_define_gsubr ("glTexParameteri", 3, 0, 0, gacela_glTexParameteri);
+ scm_c_define_gsubr ("glTexCoord2f", 2, 0, 0, gacela_glTexCoord2f);
+ scm_c_define_gsubr ("glLightfv", 3, 0, 0, gacela_glLightfv);
+ scm_c_define_gsubr ("glNormal3f", 3, 0, 0, gacela_glNormal3f);
+ scm_c_define_gsubr ("glBlendFunc", 2, 0, 0, gacela_glBlendFunc);
+ scm_c_define_gsubr ("glOrtho", 6, 0, 0, gacela_glOrtho);
+ scm_c_define_gsubr ("glPushMatrix", 0, 0, 0, gacela_glPushMatrix);
+ scm_c_define_gsubr ("glPopMatrix", 0, 0, 0, gacela_glPopMatrix);
+
+ scm_c_define_gsubr ("gluPerspective", 4, 0, 0, gacela_gluPerspective);
+ scm_c_define_gsubr ("gluBuild2DMipmaps", 7, 0, 0, gacela_gluBuild2DMipmaps);
+ scm_c_define_gsubr ("gluLookAt", 9, 0, 0, gacela_gluLookAt);
return NULL;
}
projects / gacela.git / commitdiff