+++ /dev/null
-#define max(a, b) ((a > b) ? a : b)
-#define min(a, b) ((a < b) ? a : b)
-
-int
-gacela_SDL_SurfaceFormat (int surface)
-{
- SDL_Surface *s = surface;
-
- return s->format;
-}
-
-void
-gacela_SDL_BlitSurface (int src, int srcrect, int dst, int dstrect)
-{
- SDL_BlitSurface (src, srcrect, dst, dstrect);
-}
-
-int
-gacela_SDL_Rect (int x, int y, int w, int h)
-{
- SDL_Rect *rect;
-
- rect = (SDL_Rect *)malloc (sizeof (SDL_Rect));
- rect->x = x;
- rect->y = y;
- rect->w = w;
- rect->h = h;
-
- return rect;
-}
-
-int
-gacela_TTF_Init (void)
-{
- return TTF_Init ();
-}
-
-int
-gacela_TTF_OpenFont (char *file, int ptsize)
-{
- return TTF_OpenFont (file, ptsize);
-}
-
-void
-gacela_TTF_CloseFont (int font)
-{
- TTF_CloseFont (font);
-}
-
-void
-gacela_TTF_Quit (void)
-{
- TTF_Quit ();
-}
-
-int
-gacela_Mix_OpenAudio (int frequency, int channels, int chunksize)
-{
- return Mix_OpenAudio (frequency, MIX_DEFAULT_FORMAT, channels, chunksize);
-}
-
-int
-gacela_Mix_LoadMUS (char *filename)
-{
- return Mix_LoadMUS (filename);
-}
-
-int
-gacela_Mix_LoadWAV (char *filename)
-{
- return Mix_LoadWAV (filename);
-}
-
-int
-gacela_Mix_PlayChannel (int channel, int chunk, int loops)
-{
- return Mix_PlayChannel (channel, chunk, loops);
-}
-
-int
-gacela_Mix_PlayMusic (int music, int loops)
-{
- return Mix_PlayMusic (music, loops);
-}
-
-int
-gacela_Mix_PlayingMusic (void)
-{
- return Mix_PlayingMusic ();
-}
-
-int
-gacela_Mix_PausedMusic (void)
-{
- return Mix_PausedMusic ();
-}
-
-void
-gacela_Mix_PauseMusic (void)
-{
- Mix_PauseMusic ();
-}
-
-void
-gacela_Mix_ResumeMusic (void)
-{
- Mix_ResumeMusic ();
-}
-
-int
-gacela_Mix_HaltMusic (void)
-{
- return Mix_HaltMusic ();
-}
-
-void
-gacela_Mix_FreeChunk (int chunk)
-{
- Mix_FreeChunk (chunk);
-}
-
-void
-gacela_Mix_FreeMusic (int music)
-{
- Mix_FreeMusic (music);
-}
-
-void
-gacela_Mix_CloseAudio (void)
-{
- Mix_CloseAudio ();
-}
-
-void
-gacela_sge_FilledCircle (int surface, int x, int y, int r, int red, int green, int blue)
-{
- SDL_Surface *s = surface;
-
- sge_FilledCircle (s, x, y, r, SDL_MapRGB (s->format, red, green, blue));
-}
-
-void
-gacela_sge_FilledRect (int surface, int x1, int y1, int x2, int y2, int red, int green, int blue)
-{
- SDL_Surface *s = surface;
-
- sge_FilledRect (s, x1, y1, x2, y2, SDL_MapRGB (s->format, red, green, blue));
-}
-
-void
-gacela_free (int pointer)
-{
- free (pointer);
-}
-
-void
-apply_surface (int x, int y, int source, int destination, \
- int cx, int cy, int cw, int ch, int cid)
-{
- SDL_Rect offset;
- SDL_Rect *clip = NULL;
- SDL_Surface *tmps = source;
- int tmpw, tmpx, tmpy;
-
- if (cw != 0 || ch != 0)
- {
- clip = (SDL_Rect *)malloc(sizeof(SDL_Rect));
- if (cid == 0)
- {
- clip->x = cx;
- clip->y = cy;
- }
- else
- {
- tmpw = tmps->w / cw;
- if (tmps->w % cw > 0) tmpw++;
- tmpy = cid / tmpw;
- tmpx = cid - tmpw*tmpy;
-
- if (tmpx * cw > tmps->w || tmpy * ch > tmps->h)
- {
- clip->x = 0;
- clip->y = 0;
- }
- else
- {
- clip->x = tmpx * cw;
- clip->y = tmpy * ch;
- }
- printf ("Id: %d cx: %d cy: %d\n", cid, clip->x, clip->y);
- }
- clip->w = cw;
- clip->h = ch;
- }
-
- offset.x = x;
- offset.y = y;
- SDL_BlitSurface (source, clip, destination, &offset);
- free(clip);
-}
-
-int
-render_text (int font, char *text, int red, int green, int blue)
-{
- SDL_Color textColor = {red, green, blue};
- return TTF_RenderText_Solid (font, text, textColor);
-}
-
-int
-load_image (char *filename, int red, int green, int blue)
-{
- SDL_Surface *loadedImage = NULL;
- SDL_Surface *optimizedImage = NULL;
-
- loadedImage = IMG_Load (filename);
- if (loadedImage != NULL)
- {
- optimizedImage = SDL_DisplayFormat (loadedImage);
- SDL_FreeSurface (loadedImage);
- if (optimizedImage != NULL)
- {
- SDL_SetColorKey (optimizedImage, SDL_SRCCOLORKEY, SDL_MapRGB (optimizedImage->format, red, green, blue));
- }
- }
- return optimizedImage;
-}
-
-void
-fill_surface (int surface, int red, int green, int blue)
-{
- SDL_Surface *s = surface;
-
- SDL_FillRect (s, &s->clip_rect, SDL_MapRGB (s->format, red, green, blue));
-}
-
-int
-box_collision (int surface1, int x1, int y1, int surface2, int x2, int y2)
-{
- SDL_Surface *s1 = surface1;
- SDL_Surface *s2 = surface2;
- int left1, left2, bottom1, bottom2;
- int xstart, xend, ystart, yend;
- int x, y;
-
- left1 = x1 + s1->w - 1;
- bottom1 = y1 + s1->h - 1;
- left2 = x2 + s2->w - 1;
- bottom2 = y2 + s2->h - 1;
-
- if ((x1 > left2) || (x2 > left1)) return 0;
- if ((y1 > bottom2) || (y2 > bottom1)) return 0;
- return 1;
-}
-
-int
-transparent_pixel (SDL_Surface *surface, int x, int y)
-{
- int bpp = surface->format->BytesPerPixel;
- Uint8 *p;
- Uint32 pixelcolor;
-
- if (SDL_MUSTLOCK (surface)) SDL_LockSurface (surface);
- assert ((x < surface->w) && (y < surface->h));
-
- p = (Uint8 *)surface->pixels + y*surface->pitch + x*bpp;
-
- switch (bpp)
- {
- case (1):
- pixelcolor = *p;
- break;
-
- case (2):
- pixelcolor = *(Uint16 *)p;
- break;
-
- case (3):
- if (SDL_BYTEORDER == SDL_BIG_ENDIAN)
- pixelcolor = p[0] << 16 | p[1] << 8 | p[2];
- else
- pixelcolor = p[0] | p[1] << 8 | p[2] << 16;
- break;
-
- case (4):
- pixelcolor = *(Uint32 *)p;
- break;
- }
-
- if (SDL_MUSTLOCK (surface)) SDL_UnlockSurface (surface);
-
- return (pixelcolor == surface->format->colorkey);
-}
-
-int
-create_SDL_Surface (int screen, int w, int h, int red, int green, int blue)
-{
- SDL_Surface *s = screen;
- SDL_Surface *new = NULL;
-
- new = SDL_CreateRGBSurface (s->flags, w, h, \
- s->format->BitsPerPixel, \
- s->format->Rmask, s->format->Gmask, \
- s->format->Bmask, s->format->Amask);
- if (new != NULL)
- {
- SDL_SetColorKey (new, SDL_SRCCOLORKEY, SDL_MapRGB (new->format, red, green, blue));
- }
-
- return new;
-}
-
-int
-copy_SDL_Surface (int surface)
-{
- SDL_Surface *s = surface;
-
- return SDL_ConvertSurface (s, s->format, s->flags);
-}
+++ /dev/null
-;; Sample usage: Create lisp defstructs corresponding to C structures:
-(use-package "SLOOP")
-;; How to: Create a file foo.c which contains just structures
-;; and possibly some externs.
-;; cc -E /tmp/foo1.c > /tmp/fo2.c
-;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c
-;; then (parse-file "/tmp/fo3.c")
-;; will return a list of defstructs and appropriate slot offsets.
-
-
-(defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline #\tab)))
-
-(defvar *eof* (code-char 255))
-(defun delimiter(ch) (or (white-space ch)
- (member ch '(#\, #\; #\{ #\} #\*))))
-(defun next-char (st)
- (let ((char (read-char st nil *eof*)))
-
- (case char
- (#\{ char)
- (
- #\/ (cond ((eql (peek-char nil st nil) #\*)
- (read-char st)
- (sloop when (eql (read-char st) #\*)
- do (cond ((eql (read-char st) #\/ )
- (return-from next-char (next-char st))))))
- (t char)))
- ((#\tab #\linefeed #\return #\newline )
- (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline ))
- (return-from next-char (next-char st))))
- #\space)
- (t char))))
-
-(defun get-token (st &aux tem)
- (sloop while (white-space (peek-char nil st nil))
- do (read-char st))
- (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} ))
- (return-from get-token (coerce (list (next-char st)) 'string))))
- (sloop with x = (make-array 10 :element-type 'character :fill-pointer 0
- :adjustable t)
- when (delimiter (setq tem (next-char st)))
- do (cond ((> (length x) 0)
- (or (white-space tem) (unread-char tem st))
- (return x)))
- else
- do
- (cond ((eql tem *eof*) (return *eof*))
- (t (vector-push-extend tem x)))))
-(defvar *parse-list* nil)
-(defvar *structs* nil)
-
-(defun parse-file (fi &optional *structs*)
- (with-open-file (st fi)
- (let ((*parse-list*
- (sloop while (not (eql *eof* (setq tem (get-token st))))
- collect (intern tem))))
- (print *parse-list*)
- (let ((structs
- (sloop while (setq tem (parse-struct))
- do (push tem *structs*)
- collect tem)))
- (get-sizes fi structs)
- (with-open-file (st "gaz3.lsp")
- (prog1
- (list structs (read st))
- (delete-file "gaz3.lsp")))))))
-
-
-
-
-
-(defparameter *type-alist* '((|short| . signed-short)
- (|unsigned short| . unsigned-short)
- (|char| . signed-char)
- (|unsigned char| . unsigned-char)
- (|int| . fixnum)
- (|long| . fixnum)
- (|object| . t)))
-
-
-(defun parse-type( &aux top)
- (setq top (pop *parse-list*))
- (cond ((member top '(|unsigned| |signed|))
- (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*)
- (parse-type))
- ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum)
- ((eq top '|struct|)
- (prog1
- (cond ((car (member (car *parse-list*) *STRUCTS* :key 'cadr)))
- (t (error "unknown struct ~a " (car *parse-list*))))
- (pop *parse-list*)
- ))
- ((cdr (assoc top *type-alist*)))
- (t (error "unknown type ~a " top))))
-(defun expect (x) (or (eql (car *parse-list*) x)
- (error "expected ~a at beginning of ~s" x *parse-list*))
- (pop *parse-list*))
-(defun parse-field ( &aux tem)
- (cond ((eql (car *parse-list*) '|}|)
- (pop *parse-list*)
- (expect '|;|)
- nil)
- (t
- (let ((type (parse-type)))
-
- (sloop until (eql (setq tem (pop *parse-list*)) '|;|)
- append (get-field tem type)
-
- do (or (eq (car *parse-list*) '|;|) (expect '|,|)))))))
-(deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum))
-(defun get-field (name type)
- (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer))
- ((and (consp type) (eq (car type) 'defstruct))
- (sloop for w in (cddr type)
- append (get-field
- (intern (format nil "~a.~a" name (car w)))
- (fourth w))))
- (t
- `((,name ,(if (eq type t) nil 0) :type ,type)))))
-
-(defun parse-struct ()
- (cond ((null *parse-list*) (return-from parse-struct nil)))
- (cond ((not (eq (car *parse-list*) '|struct|))
- (sloop until (eq (pop *parse-list*) '|;|))
- (return-from parse-struct (parse-struct))))
- (expect '|struct|)
- (let* ((name (prog1 (pop *parse-list*)(expect '|{|))))
- `(defstruct ,name ,@
- (sloop while (setq tem (parse-field))
- append tem))))
-
-(defun printf (st x &rest y)
- (format st "~%printf(\"~a\"" x)
- (sloop for w in y do (princ "," st) (princ y st))
- (princ ");" st))
-
-(defun get-sizes (file structs)
- (with-open-file (st "gaz0" :direction :output)
- (sloop for i from 1
- for u in structs
- do (format st "struct ~a SSS~a;~%" (second u) i))
- (format st "~%main() {~%")
- (printf st "(")
- (sloop for i from 1
- for u in structs
- do
- (printf st (format nil "(|~a| " (second u)))
- (sloop for w in (cddr u)
- do
- (printf st " %d "
- (format nil "(char *)&SSS~a.~a - (char *)&SSS~a"
- i (car w) i)))
- (printf st ")"))
- (printf st ")")
- (princ " ;}" st))
- (system
- (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (./tmpx > gaz3.lsp) ; rm -f gaz0" file)))
+++ /dev/null
-struct SDL_Rect {
- signed int x, y;
- unsigned int w, h;
-};
-
+++ /dev/null
-struct SDL_Rect {
- int x, y;
- int w, h;
-};
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-;;; Default values for Gacela
-(defvar *width-screen* 640)
-(defvar *height-screen* 480)
-(defvar *bpp-screen* 32)
-(defvar *frames-per-second* 20)
-
-;;; SDL Initialization Subsystem
-(let (initialized)
-
- (defun init-sdl ()
- (cond ((null initialized) (setq initialized (SDL_Init SDL_INIT_EVERYTHING)))
- (t initialized)))
-
- (defun quit-sdl ()
- (setq 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))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defmacro mapcconst (type c-type name)
- (let ((c-header (concatenate 'string c-type " gacela_" name " (void)"))
- (c-body (concatenate 'string "return " name ";"))
- (c-name (concatenate 'string "gacela_" name))
- (lisp-name (intern (string-upcase name))))
- `(progn
- (defcfun ,c-header 0 ,c-body)
- (defentry ,lisp-name () (,type ,c-name))
- (eval-when (load) (defconstant ,lisp-name (,lisp-name))))))
-
-(clines "#include <FTGL/ftgl.h>")
-
-(mapcconst int "int" "ft_encoding_unicode")
-(mapcconst int "int" "FTGL_RENDER_ALL")
-
-;;; FTGL Functions
-(defcfun "int gacela_ftglCreateTextureFont (char *file)" 0
- "return ftglCreateTextureFont (file);")
-
-(defcfun "int gacela_ftglSetFontFaceSize (int font, int size, int res)" 0
- "return ftglSetFontFaceSize (font, size, res);")
-
-(defcfun "int gacela_ftglSetFontCharMap (int font, int encoding)" 0
- "return ftglSetFontCharMap (font, encoding);")
-
-(defcfun "void gacela_ftglRenderFont (int font, char *string, int mode)" 0
- "ftglRenderFont (font, string, mode);")
-
-(defcfun "void gacela_ftglDestroyFont (int font)" 0
- "ftglDestroyFont (font);")
-
-(defentry ftglCreateTextureFont (string) (int "gacela_ftglCreateTextureFont"))
-(defentry ftglSetFontFaceSize (int int int) (int "gacela_ftglSetFontFaceSize"))
-(defentry ftglSetFontCharMap (int int) (int "gacela_ftglSetFontCharMap"))
-(defentry ftglRenderFont (int string int) (void "gacela_ftglRenderFont"))
-(defentry ftglDestroyFont (int) (void "gacela_ftglDestroyFont"))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defmacro mapcconst (type c-type name)
- (let ((c-header (concatenate 'string c-type " gacela_" name " (void)"))
- (c-body (concatenate 'string "return " name ";"))
- (c-name (concatenate 'string "gacela_" name))
- (lisp-name (intern (string-upcase name))))
- `(progn
- (defcfun ,c-header 0 ,c-body)
- (defentry ,lisp-name () (,type ,c-name))
- (eval-when (load) (defconstant ,lisp-name (,lisp-name))))))
-
-(clines "#include <GL/gl.h>")
-(clines "#include <GL/glu.h>")
-
-;;; Data types
-(mapcconst int "int" "GL_UNSIGNED_BYTE")
-
-;;; Primitives
-(mapcconst int "int" "GL_POINTS")
-(mapcconst int "int" "GL_LINES")
-(mapcconst int "int" "GL_LINE_LOOP")
-(mapcconst int "int" "GL_LINE_STRIP")
-(mapcconst int "int" "GL_TRIANGLES")
-(mapcconst int "int" "GL_TRIANGLE_STRIP")
-(mapcconst int "int" "GL_TRIANGLE_FAN")
-(mapcconst int "int" "GL_QUADS")
-(mapcconst int "int" "GL_QUAD_STRIP")
-(mapcconst int "int" "GL_POLYGON")
-
-;;; Matrix Mode
-(mapcconst int "int" "GL_MODELVIEW")
-(mapcconst int "int" "GL_PROJECTION")
-
-;;; Depth buffer
-(mapcconst int "int" "GL_LEQUAL")
-(mapcconst int "int" "GL_DEPTH_TEST")
-
-;;; Lighting
-(mapcconst int "int" "GL_LIGHTING")
-(mapcconst int "int" "GL_LIGHT1")
-(mapcconst int "int" "GL_AMBIENT")
-(mapcconst int "int" "GL_DIFFUSE")
-(mapcconst int "int" "GL_POSITION")
-(mapcconst int "int" "GL_SMOOTH")
-
-;;; Blending
-(mapcconst int "int" "GL_BLEND")
-(mapcconst int "int" "GL_ONE")
-(mapcconst int "int" "GL_SRC_ALPHA")
-
-;;; Fog
-(mapcconst int "int" "GL_LINEAR")
-
-;;; Buffers, Pixel Drawing/Reading
-(mapcconst int "int" "GL_RGB")
-(mapcconst int "int" "GL_RGBA")
-
-;;; Hints
-(mapcconst int "int" "GL_PERSPECTIVE_CORRECTION_HINT")
-(mapcconst int "int" "GL_NICEST")
-
-;;; Texture mapping
-(mapcconst int "int" "GL_TEXTURE_2D")
-(mapcconst int "int" "GL_TEXTURE_MAG_FILTER")
-(mapcconst int "int" "GL_TEXTURE_MIN_FILTER")
-(mapcconst int "int" "GL_LINEAR_MIPMAP_NEAREST")
-(mapcconst int "int" "GL_NEAREST")
-
-;;; glPush/PopAttrib bits
-(mapcconst int "int" "GL_DEPTH_BUFFER_BIT")
-(mapcconst int "int" "GL_COLOR_BUFFER_BIT")
-
-;;; OpenGL 1.2
-(mapcconst int "int" "GL_BGR")
-(mapcconst int "int" "GL_BGRA")
-
-;;; OpenGL Functions
-(defcfun "void gacela_glBegin (int mode)" 0
- "glBegin (mode);")
-
-(defcfun "void gacela_glClear (int mask)" 0
- "glClear (mask);")
-
-(defcfun "void gacela_glClearColor (float red, float green, float blue, float alpha)" 0
- "glClearColor (red, green, blue, alpha);")
-
-(defcfun "void gacela_glClearDepth (double depth)" 0
- "glClearDepth (depth);")
-
-(defcfun "void gacela_glColor3f (float red, float green, float blue)" 0
- "glColor3f (red, green, blue);")
-
-(defcfun "void gacela_glColor4f (float red, float green, float blue, float alpha)" 0
- "glColor4f (red, green, blue, alpha);")
-
-(defcfun "void gacela_glDepthFunc (int func)" 0
- "glDepthFunc (func);")
-
-(defcfun "void gacela_glEnable (int cap)" 0
- "glEnable (cap);")
-
-(defcfun "void gacela_glDisable (int cap)" 0
- "glDisable (cap);")
-
-(defcfun "void gacela_glEnd (void)" 0
- "glEnd ();")
-
-(defcfun "void gacela_glHint (int target, int mode)" 0
- "glHint (target, mode);")
-
-(defcfun "void gacela_glLoadIdentity (void)" 0
- "glLoadIdentity ();")
-
-(defcfun "void gacela_glMatrixMode (int mode)" 0
- "glMatrixMode (mode);")
-
-(defcfun "void gacela_glRotatef (float angle, float x, float y, float z)" 0
- "glRotatef (angle, x, y, z);")
-
-(defcfun "void gacela_glShadeModel (int mode)" 0
- "glShadeModel (mode);")
-
-(defcfun "void gacela_glTranslatef (float x, float y, float z)" 0
- "glTranslatef (x, y, z);")
-
-(defcfun "void gacela_glVertex2f (float x, float y)" 0
- "glVertex2f (x, y);")
-
-(defcfun "void gacela_glVertex3f (float x, float y, float z)" 0
- "glVertex3f (x, y, z);")
-
-(defcfun "void gacela_glViewport (int x, int y, int width, int height)" 0
- "glViewport (x, y, width, height);")
-
-(defcfun "static object gacela_glGenTextures (int n)" 0
- "object textures;"
- "GLuint text[n];"
- "int i, t;"
- ('nil textures)
- "glGenTextures (n, &text[0]);"
- "for (i = n - 1; i >= 0; i--) {"
- "t = text[i];"
- ((cons (int t) textures) textures)
- "}"
- "return textures;")
-
-(defcfun "void gacela_glDeleteTextures (int n, object textures)" 0
- "GLuint text[n];"
- "int i, t;"
- "for (i = 0; i < n; i++) {"
- ((nth (int i) textures) t)
- "text[i] = t;"
- "}"
- "glDeleteTextures (n, &text[0]);")
-
-(defcfun "void gacela_glBindTexture (int target, int texture)" 0
- "glBindTexture (target, texture);")
-
-(defcfun "void gacela_glTexImage2D (int target, int level, int internalFormat, int width, int height, int border, int format, int type, int pixels)" 0
- "glTexImage2D (target, level, internalFormat, width, height, border, format, type, pixels);")
-
-(defcfun "void gacela_glTexParameteri (int target, int pname, int param)" 0
- "glTexParameteri (target, pname, param);")
-
-(defcfun "void gacela_glTexCoord2f (float s, float t)" 0
- "glTexCoord2f (s, t);")
-
-(defcfun "void gacela_glLightfv (int light, int pname, float param1, float param2, float param3, float param4)" 0
- "GLfloat params[4];"
- "params[0] = param1;"
- "params[1] = param2;"
- "params[2] = param3;"
- "params[3] = param4;"
- "glLightfv (light, pname, params);")
-
-(defcfun "void gacela_glNormal3f (float nx, float ny, float nz)" 0
- "glNormal3f (nx, ny, nz);")
-
-(defcfun "void gacela_glBlendFunc (int sfactor, int dfactor)" 0
- "glBlendFunc (sfactor, dfactor);")
-
-(defcfun "void gacela_glOrtho (float left, float right, float bottom, float top, float near_val, float far_val)" 0
- "glOrtho (left, right, bottom, top, near_val, far_val);")
-
-(defcfun "void gacela_glPushMatrix (void)" 0
- "glPushMatrix ();")
-
-(defcfun "void gacela_glPopMatrix (void)" 0
- "glPopMatrix ();")
-
-(defcfun "void gacela_gluPerspective (double fovy, double aspect, double zNear, double zFar)" 0
- "gluPerspective (fovy, aspect, zNear, zFar);")
-
-(defcfun "int gacela_gluBuild2DMipmaps (int target, int internalFormat, int width, int height, int format, int type, int data)" 0
- "return gluBuild2DMipmaps (target, internalFormat, width, height, format, type, data);")
-
-(defcfun "void gacela_gluLookAt (double eyeX, double eyeY, double eyeZ, double centerX, double centerY, double centerZ, double upX, double upY, double upZ)" 0
- "gluLookAt (eyeX, eyeY, eyeZ, centerX, centerY, centerZ, upX, upY, upZ);")
-
-(defentry glBegin (int) (void "gacela_glBegin"))
-(defentry glClear (int) (void "gacela_glClear"))
-(defentry glClearColor (float float float float) (void "gacela_glClearColor"))
-(defentry glClearDepth (double) (void "gacela_glClearDepth"))
-(defentry glColor3f (float float float) (void "gacela_glColor3f"))
-(defentry glColor4f (float float float float) (void "gacela_glColor4f"))
-(defentry glDepthFunc (int) (void "gacela_glDepthFunc"))
-(defentry glEnable (int) (void "gacela_glEnable"))
-(defentry glDisable (int) (void "gacela_glDisable"))
-(defentry glEnd () (void "gacela_glEnd"))
-(defentry glHint (int int) (void "gacela_glHint"))
-(defentry glLoadIdentity () (void "gacela_glLoadIdentity"))
-(defentry glMatrixMode (int) (void "gacela_glMatrixMode"))
-(defentry glRotatef (float float float float) (void "gacela_glRotatef"))
-(defentry glShadeModel (int) (void "gacela_glShadeModel"))
-(defentry glTranslatef (float float float) (void "gacela_glTranslatef"))
-(defentry glVertex2f (float float) (void "gacela_glVertex2f"))
-(defentry glVertex3f (float float float) (void "gacela_glVertex3f"))
-(defentry glViewport (int int int int) (void "gacela_glViewport"))
-(defentry glGenTextures (int) (object "gacela_glGenTextures"))
-(defentry glDeleteTextures (int object) (void "gacela_glDeleteTextures"))
-(defentry glBindTexture (int int) (void "gacela_glBindTexture"))
-(defentry glTexImage2D (int int int int int int int int int) (void "gacela_glTexImage2D"))
-(defentry glTexParameteri (int int int) (void "gacela_glTexParameteri"))
-(defentry glTexCoord2f (float float) (void "gacela_glTexCoord2f"))
-(defentry glLightfv (int int float float float float) (void "gacela_glLightfv"))
-(defentry glNormal3f (float float float) (void "gacela_glNormal3f"))
-(defentry glBlendFunc (int int) (void "gacela_glBlendFunc"))
-(defentry glOrtho (float float float float float float) (void "gacela_glOrtho"))
-(defentry glPushMatrix () (void "gacela_glPushMatrix"))
-(defentry glPopMatrix () (void "gacela_glPopMatrix"))
-
-(defentry gluPerspective (double double double double) (void "gacela_gluPerspective"))
-(defentry gluBuild2DMipmaps (int int int int int int int) (int "gacela_gluBuild2DMipmaps"))
-(defentry gluLookAt (double double double double double double double double double) (void "gacela_gluLookAt"))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defmacro mapcconst (type c-type name)
- (let ((c-header (concatenate 'string c-type " gacela_" name " (void)"))
- (c-body (concatenate 'string "return " name ";"))
- (c-name (concatenate 'string "gacela_" name))
- (lisp-name (intern (string-upcase name))))
- `(progn
- (defcfun ,c-header 0 ,c-body)
- (defentry ,lisp-name () (,type ,c-name))
- (eval-when (load) (defconstant ,lisp-name (,lisp-name))))))
-
-(clines "#include <SDL/SDL.h>")
-(clines "#include <SDL/SDL_image.h>")
-(clines "#include <SDL/SDL_mixer.h>")
-
-;;; SDL constants as functions
-(mapcconst int "int" "SDL_INIT_TIMER")
-(mapcconst int "int" "SDL_INIT_AUDIO")
-(mapcconst int "int" "SDL_INIT_VIDEO")
-(mapcconst int "int" "SDL_INIT_CDROM")
-(mapcconst int "int" "SDL_INIT_JOYSTICK")
-(mapcconst int "int" "SDL_INIT_NOPARACHUTE")
-(mapcconst int "int" "SDL_INIT_EVENTTHREAD")
-(mapcconst int "int" "SDL_INIT_EVERYTHING")
-
-(mapcconst int "int" "SDL_SWSURFACE")
-(mapcconst int "int" "SDL_HWSURFACE")
-(mapcconst int "int" "SDL_ASYNCBLIT")
-
-(mapcconst int "int" "SDL_ANYFORMAT")
-(mapcconst int "int" "SDL_HWPALETTE")
-(mapcconst int "int" "SDL_DOUBLEBUF")
-(mapcconst int "int" "SDL_FULLSCREEN")
-(mapcconst int "int" "SDL_OPENGL")
-(mapcconst int "int" "SDL_OPENGLBLIT")
-(mapcconst int "int" "SDL_RESIZABLE")
-(mapcconst int "int" "SDL_NOFRAME")
-
-(mapcconst int "int" "SDL_HWACCEL")
-(mapcconst int "int" "SDL_SRCCOLORKEY")
-
-(mapcconst int "int" "SDL_GL_DOUBLEBUFFER")
-
-(mapcconst int "int" "SDL_DEFAULT_REPEAT_DELAY")
-(mapcconst int "int" "SDL_DEFAULT_REPEAT_INTERVAL")
-
-(mapcconst int "int" "SDL_LIL_ENDIAN")
-(mapcconst int "int" "SDL_BIG_ENDIAN")
-
-(mapcconst int "int" "MIX_DEFAULT_FORMAT")
-
-;;; SDL Functions
-(defcfun "int gacela_SDL_Init (int flags)" 0
- "return SDL_Init (flags);")
-
-(defcfun "void gacela_SDL_Quit (void)" 0
- "SDL_Quit ();")
-
-(defcfun "int gacela_SDL_SetVideoMode (int width, int height, int bpp, int flags)" 0
- "close(2);"
- "return SDL_SetVideoMode (width, height, bpp, flags);")
-
-(defcfun "void gacela_SDL_WM_SetCaption (char *title, char *icon)" 0
- "SDL_WM_SetCaption (title, icon);")
-
-(defcfun "int gacela_SDL_Flip (int screen)" 0
- "return SDL_Flip (screen);")
-
-(defcfun "void gacela_SDL_FreeSurface (int surface)" 0
- "SDL_FreeSurface (surface);")
-
-(defcfun "void gacela_SDL_Delay (int ms)" 0
- "SDL_Delay (ms);")
-
-(defcfun "int gacela_SDL_GetTicks (void)" 0
- "return SDL_GetTicks ();")
-
-(defcfun "int gacela_SDL_DisplayFormat (int surface)" 0
- "return SDL_DisplayFormat (surface);")
-
-(defcfun "int gacela_SDL_MapRGB (int format, int r, int g, int b)" 0
- "return SDL_MapRGB (format, r, g, b);")
-
-(defcfun "int gacela_SDL_SetColorKey (int surface, int flag, int key)" 0
- "return SDL_SetColorKey (surface, flag, key);")
-
-(defcfun "int gacela_SDL_LoadBMP (char *file)" 0
- "return SDL_LoadBMP (file);")
-
-(defcfun "int gacela_IMG_Load (char *filename)" 0
- "return IMG_Load (filename);")
-
-(defcfun "static object gacela_SDL_GetVideoInfo (void)" 0
- "const SDL_VideoInfo *info;"
- "object vi, label;"
- "info = SDL_GetVideoInfo ();"
- ('nil vi)
- ((cons (int info->blit_hw) vi) vi) (':blit_hw label) ((cons label vi) vi)
- ((cons (int info->hw_available) vi) vi) (':hw_available label) ((cons label vi) vi)
- "return vi;")
-
-(defcfun "int gacela_SDL_GL_SetAttribute (int attr, int value)" 0
- "return SDL_GL_SetAttribute (attr, value);")
-
-(defcfun "static object gacela_SDL_PollEvent (void)" 0
- "SDL_Event sdl_event;"
- "object event, label;"
- ('nil event)
- "if (SDL_PollEvent (&sdl_event)) {"
- " switch (sdl_event.type) {"
- " case SDL_KEYDOWN:"
- " case SDL_KEYUP:"
- ((cons (int sdl_event.key.keysym.sym) event) event) (':key.keysym.sym label) ((cons label event) event)
- " break;"
- " }"
- ((cons (int sdl_event.type) event) event) (':type label) ((cons label event) event)
- "}"
- "return event;")
-
-(defcfun "void gacela_SDL_GL_SwapBuffers (void)" 0
- "SDL_GL_SwapBuffers ();")
-
-(defcfun "int gacela_SDL_EnableKeyRepeat (int delay, int interval)" 0
- "return SDL_EnableKeyRepeat (delay, interval);")
-
-(defcfun "int gacela_SDL_ByteOrder (void)" 0
- "return SDL_BYTEORDER;")
-
-(defcfun "int gacela_zoomSurface (int src, double zoomx, double zoomy, int smooth)" 0
- "return zoomSurface (src, zoomx, zoomy, smooth);")
-
-(defcfun "int gacela_Mix_OpenAudio (int frequency, int format, int channels, int chunksize)" 0
- "return Mix_OpenAudio (frequency, format, channels, chunksize);")
-
-(defcfun "int gacela_Mix_LoadMUS (char *file)" 0
- "return Mix_LoadMUS (file);")
-
-(defcfun "int gacela_Mix_LoadWAV (char *file)" 0
- "return Mix_LoadWAV (file);")
-
-(defcfun "int gacela_Mix_PlayChannel (int channel, int chunk, int loops)" 0
- "return Mix_PlayChannel (channel, chunk, loops);")
-
-(defcfun "int gacela_Mix_PlayMusic (int music, int loops)" 0
- "return Mix_PlayMusic (music, loops);")
-
-(defcfun "int gacela_Mix_PlayingMusic (void)" 0
- "return Mix_PlayingMusic ();")
-
-(defcfun "int gacela_Mix_PausedMusic (void)" 0
- "return Mix_PausedMusic ();")
-
-(defcfun "void gacela_Mix_PauseMusic (void)" 0
- "Mix_PauseMusic ();")
-
-(defcfun "void gacela_Mix_ResumeMusic (void)" 0
- "Mix_ResumeMusic ();")
-
-(defcfun "int gacela_Mix_HaltMusic (void)" 0
- "return Mix_HaltMusic ();")
-
-(defcfun "void gacela_Mix_FreeMusic (int music)" 0
- "Mix_FreeMusic (music);")
-
-(defcfun "void gacela_Mix_FreeChunk (int chunk)" 0
- "Mix_FreeChunk (chunk);")
-
-(defcfun "void gacela_Mix_CloseAudio (void)" 0
- "Mix_CloseAudio ();")
-
-(defentry SDL_Init (int) (int "gacela_SDL_Init"))
-(defentry SDL_Quit () (void "gacela_SDL_Quit"))
-(defentry SDL_SetVideoMode (int int int int) (int "gacela_SDL_SetVideoMode"))
-(defentry SDL_WM_SetCaption (string string) (void "gacela_SDL_WM_SetCaption"))
-(defentry SDL_Flip (int) (int "gacela_SDL_Flip"))
-(defentry SDL_FreeSurface (int) (void "gacela_SDL_FreeSurface"))
-(defentry SDL_Delay (int) (void "gacela_SDL_Delay"))
-(defentry SDL_GetTicks () (int "gacela_SDL_GetTicks"))
-(defentry SDL_DisplayFormat (int) (int "gacela_SDL_DisplayFormat"))
-;(defentry SDL_SurfaceFormat (int) (int "gacela_SDL_SurfaceFormat"))
-(defentry SDL_MapRGB (int int int int) (int "gacela_SDL_MapRGB"))
-(defentry SDL_SetColorKey (int int int) (int "gacela_SDL_SetColorKey"))
-;(defentry SDL_BlitSurface (int int int int) (void "gacela_SDL_BlitSurface"))
-;(defentry SDL_Rect (int int int int) (int "gacela_SDL_Rect"))
-(defentry SDL_LoadBMP (string) (int "gacela_SDL_LoadBMP"))
-(defentry IMG_Load (string) (int "gacela_IMG_Load"))
-(defentry SDL_GetVideoInfo () (object "gacela_SDL_GetVideoInfo"))
-(defentry SDL_GL_SetAttribute (int int) (int "gacela_SDL_GL_SetAttribute"))
-(defentry SDL_PollEvent () (object "gacela_SDL_PollEvent"))
-;(defentry TTF_Init () (int "gacela_TTF_Init"))
-;(defentry TTF_OpenFont (string int) (int "gacela_TTF_OpenFont"))
-;(defentry TTF_CloseFont (int) (void "gacela_TTF_CloseFont"))
-;(defentry TTF_Quit () (void "gacela_TTF_Quit"))
-(defentry Mix_OpenAudio (int int int int) (int "gacela_Mix_OpenAudio"))
-(defentry Mix_LoadMUS (string) (int "gacela_Mix_LoadMUS"))
-(defentry Mix_LoadWAV (string) (int "gacela_Mix_LoadWAV"))
-(defentry Mix_PlayChannel (int int int) (int "gacela_Mix_PlayChannel"))
-(defentry Mix_PlayMusic (int int) (int "gacela_Mix_PlayMusic"))
-(defentry Mix_PlayingMusic () (int "gacela_Mix_PlayingMusic"))
-(defentry Mix_PausedMusic () (int "gacela_Mix_PausedMusic"))
-(defentry Mix_PauseMusic () (void "gacela_Mix_PauseMusic"))
-(defentry Mix_ResumeMusic () (void "gacela_Mix_ResumeMusic"))
-(defentry Mix_HaltMusic () (int "gacela_Mix_HaltMusic"))
-(defentry Mix_FreeMusic (int) (void "gacela_Mix_FreeMusic"))
-(defentry Mix_FreeChunk (int) (void "gacela_Mix_FreeChunk"))
-(defentry Mix_CloseAudio () (void "gacela_Mix_CloseAudio"))
-;(defentry free (int) (void "gacela_free"))
-(defentry SDL_GL_SwapBuffers () (void "gacela_SDL_GL_SwapBuffers"))
-(defentry SDL_EnableKeyRepeat (int int) (int "gacela_SDL_EnableKeyRepeat"))
-(defentry SDL_ByteOrder () (int "gacela_SDL_ByteOrder"))
-(defentry zoomSurface (int double double int) (int "gacela_zoomSurface"))
-
-;;; C-Gacela Functions
-(defcfun "int gacela_surface_format (int surface)" 0
- "const SDL_Surface *s = surface;"
- "return s->format;")
-
-(defcfun "int gacela_surface_w (int surface)" 0
- "const SDL_Surface *s = surface;"
- "return s->w;")
-
-(defcfun "int gacela_surface_h (int surface)" 0
- "const SDL_Surface *s = surface;"
- "return s->h;")
-
-(defcfun "int gacela_surface_pixels (int surface)" 0
- "const SDL_Surface *s = surface;"
- "return s->pixels;")
-
-(defcfun "int gacela_surface_format_BytesPerPixel (int surface)" 0
- "const SDL_Surface *s = surface;"
- "return s->format->BytesPerPixel;")
-
-;(defentry apply-surface2 (int int int int int int int int int) (void "apply_surface"))
-;(defentry render-text2 (int string int int int) (int "render_text"))
-;(defentry box-collision (int int int int int int) (int "box_collision"))
-;(defentry create-SDL_Surface (int int int int int int) (int "create_SDL_Surface"))
-;(defentry copy-SDL_Surface (int) (int "copy_SDL_Surface"))
-(defentry surface-format (int) (int "gacela_surface_format"))
-(defentry surface-w (int) (int "gacela_surface_w"))
-(defentry surface-h (int) (int "gacela_surface_h"))
-(defentry surface-pixels (int) (int "gacela_surface_pixels"))
-(defentry surface-format-BytesPerPixel (int) (int "gacela_surface_format_BytesPerPixel"))
+++ /dev/null
-
-#include "cmpinclude.h"
-#include "gacela_chip.h"
-void init__home_jsancho_proyectos_gacela_gacela_chip(){do_init((void *)VV);}
-#include "gacela_chipmunk.c"
-/* function definition for CPINITCHIPMUNK */
-
-static void L1()
-{ object *old_base=vs_base;
- gacela_cpInitChipmunk();
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPRESETSHAPEIDCOUNTER */
-
-static void L2()
-{ object *old_base=vs_base;
- gacela_cpResetShapeIdCounter();
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPSPACENEW */
-
-static void L3()
-{ object *old_base=vs_base;
- int x;
- x=
- gacela_cpSpaceNew();
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=CMPmake_fixnum(x);
-}
-/* function definition for CPSPACEADDBODY */
-
-static void L4()
-{ object *old_base=vs_base;
- gacela_cpSpaceAddBody(
- object_to_int(vs_base[0]),
- object_to_int(vs_base[1]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPSPACEADDSHAPE */
-
-static void L5()
-{ object *old_base=vs_base;
- gacela_cpSpaceAddShape(
- object_to_int(vs_base[0]),
- object_to_int(vs_base[1]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPSPACEFREE */
-
-static void L6()
-{ object *old_base=vs_base;
- gacela_cpSpaceFree(
- object_to_int(vs_base[0]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPBODYNEW */
-
-static void L7()
-{ object *old_base=vs_base;
- int x;
- x=
- gacela_cpBodyNew(
- object_to_float(vs_base[0]),
- object_to_float(vs_base[1]),
- object_to_float(vs_base[2]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=CMPmake_fixnum(x);
-}
-/* function definition for CPBODYFREE */
-
-static void L8()
-{ object *old_base=vs_base;
- gacela_cpBodyFree(
- object_to_int(vs_base[0]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for CPCIRCLESHAPENEW */
-
-static void L9()
-{ object *old_base=vs_base;
- int x;
- x=
- gacela_cpCircleShapeNew(
- object_to_int(vs_base[0]),
- object_to_float(vs_base[1]),
- object_to_float(vs_base[2]),
- object_to_float(vs_base[3]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=CMPmake_fixnum(x);
-}
-/* function definition for CPPOLYSHAPENEW */
-
-static void L10()
-{ object *old_base=vs_base;
- int x;
- x=
- gacela_cpPolyShapeNew(
- object_to_int(vs_base[0]),
- object_to_int(vs_base[1]),
- object_to_int(vs_base[2]),
- object_to_float(vs_base[3]),
- object_to_float(vs_base[4]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=CMPmake_fixnum(x);
-}
-/* function definition for CPSHAPEFREE */
-
-static void L11()
-{ object *old_base=vs_base;
- gacela_cpShapeFree(
- object_to_int(vs_base[0]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for SET-SPACE-PROPERTIES */
-
-static void L12()
-{ object *old_base=vs_base;
- set_space_properties(
- object_to_int(vs_base[0]),
- object_to_float(vs_base[1]),
- object_to_float(vs_base[2]));
- vs_top=(vs_base=old_base)+1;
- vs_base[0]=Cnil;
-}
-/* function definition for MAKE-SPACE */
-
-static void L13()
-{register object *base=vs_base;
- register object *sup=base+VM1; VC1
- vs_check;
- {object V1;
- parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
- V1=(base[0]);
- base[2]= ((object)VV[0]);
- base[3]= (V1);
- vs_top=(vs_base=base+2)+2;
- siLmake_structure();
- return;
- }
-}
-/* function definition for MAKE-BODY */
-
-static void L14()
-{register object *base=vs_base;
- register object *sup=base+VM2; VC2
- vs_check;
- {object V2;
- parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
- V2=(base[0]);
- base[2]= ((object)VV[1]);
- base[3]= (V2);
- vs_top=(vs_base=base+2)+2;
- siLmake_structure();
- return;
- }
-}
-/* function definition for MAKE-SHAPE */
-
-static void L15()
-{register object *base=vs_base;
- register object *sup=base+VM3; VC3
- vs_check;
- {object V3;
- parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
- V3=(base[0]);
- base[2]= ((object)VV[2]);
- base[3]= (V3);
- vs_top=(vs_base=base+2)+2;
- siLmake_structure();
- return;
- }
-}
-/* function definition for CREATE-SPACE */
-
-static void L16()
-{register object *base=vs_base;
- register object *sup=base+VM4; VC4
- vs_check;
- {object V4;
- parse_key(vs_base,FALSE,FALSE,1,VV[7]);vs_top=sup;
- V4=(base[0]);
- vs_base=vs_top;
- (void) (*Lnk8)();
- vs_top=sup;
- {object V5;
- register object V6;
- base[2]= ((object)VV[3]);
- vs_base=vs_top;
- (void) (*Lnk9)();
- vs_top=sup;
- base[3]= vs_base[0];
- vs_top=(vs_base=base+2)+2;
- (void) (*Lnk10)();
- vs_top=sup;
- V5= vs_base[0];
- V6= Cnil;
- base[2]= ((object)VV[0]);
- base[3]= (V5);
- vs_base=vs_top;
- Lgentemp();
- vs_top=sup;
- base[4]= vs_base[0];
- vs_top=(vs_base=base+2)+3;
- (void) (*Lnk11)();
- vs_top=sup;
- if(((V4))==Cnil){
- goto T15;}
- V6= (VFUN_NARGS=2,(*(LnkLI12))((V4),(V6)));
- goto T15;
-T15:;
- if(((V6))==Cnil){
- goto T19;}
- {object V7;
- V7= make_cons(STREF(object,(V5),0),(V6));
- vs_top=base+2;
- while(V7!=Cnil)
- {vs_push((V7)->c.c_car);V7=(V7)->c.c_cdr;}
- vs_base=base+2;}
- (void) (*Lnk13)();
- vs_top=sup;
- goto T19;
-T19:;
- base[2]= (V5);
- vs_top=(vs_base=base+2)+1;
- return;}
- }
-}
-/* function definition for CREATE-BODY */
-
-static void L17()
-{register object *base=vs_base;
- register object *sup=base+VM5; VC5
- vs_check;
- {object V8;
- object V9;
- parse_key(vs_base,FALSE,FALSE,2,VV[14],VV[15]);vs_top=sup;
- if(base[2]==Cnil){
- V8= ((object)VV[4]);
- }else{
- V8=(base[0]);}
- if(base[3]==Cnil){
- V9= ((object)VV[5]);
- }else{
- V9=(base[1]);}
- vs_base=vs_top;
- (void) (*Lnk8)();
- vs_top=sup;
- {object V10;
- base[4]= ((object)VV[3]);
- base[6]= (V8);
- base[7]= (V9);
- base[8]= ((object)VV[6]);
- vs_top=(vs_base=base+6)+3;
- (void) (*Lnk16)();
- vs_top=sup;
- base[5]= vs_base[0];
- vs_top=(vs_base=base+4)+2;
- (void) (*Lnk17)();
- vs_top=sup;
- V10= vs_base[0];
- base[4]= ((object)VV[1]);
- base[5]= (V10);
- vs_base=vs_top;
- Lgentemp();
- vs_top=sup;
- base[6]= vs_base[0];
- vs_top=(vs_base=base+4)+3;
- (void) (*Lnk11)();
- vs_top=sup;
- base[4]= (V10);
- vs_top=(vs_base=base+4)+1;
- return;}
- }
-}
-static void LnkT17(){ call_or_link(((object)VV[17]),(void **)(void *)&Lnk17);} /* MAKE-BODY */
-static void LnkT16(){ call_or_link(((object)VV[16]),(void **)(void *)&Lnk16);} /* CPNEWBODY */
-static void LnkT13(){ call_or_link(((object)VV[13]),(void **)(void *)&Lnk13);} /* SET-SPACE-PROPERTIES */
-static object LnkTLI12(object first,...){object V1;va_list ap;va_start(ap,first);V1=call_vproc_new(((object)VV[12]),(void **)(void *)&LnkLI12,first,ap);va_end(ap);return V1;} /* UNION */
-static void LnkT11(){ call_or_link(((object)VV[11]),(void **)(void *)&Lnk11);} /* SET-RESOURCE */
-static void LnkT10(){ call_or_link(((object)VV[10]),(void **)(void *)&Lnk10);} /* MAKE-SPACE */
-static void LnkT9(){ call_or_link(((object)VV[9]),(void **)(void *)&Lnk9);} /* CPSPACENEW */
-static void LnkT8(){ call_or_link(((object)VV[8]),(void **)(void *)&Lnk8);} /* INIT-CHIPMUNK */
-
-#ifdef SYSTEM_SPECIAL_INIT
-SYSTEM_SPECIAL_INIT
-#endif
-
+++ /dev/null
-(in-package 'chipmunk)
-
-(clines "#include \"gacela_chipmunk.c\"")
-
-(defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
-
-;;; Chipmunk functions
-(defentry cpInitChipmunk () (void "gacela_cpInitChipmunk"))
-(defentry cpResetShapeIdCounter () (void "gacela_cpResetShapeIdCounter"))
-(defentry cpSpaceNew () (int "gacela_cpSpaceNew"))
-(defentry cpSpaceAddBody (int int) (void "gacela_cpSpaceAddBody"))
-(defentry cpSpaceAddShape (int int) (void "gacela_cpSpaceAddShape"))
-(defentry cpSpaceFree (int) (void "gacela_cpSpaceFree"))
-(defentry cpBodyNew (float float float) (int "gacela_cpBodyNew"))
-(defentry cpBodyFree (int) (void "gacela_cpBodyFree"))
-(defentry cpCircleShapeNew (int float float float) (int "gacela_cpCircleShapeNew"))
-(defentry cpPolyShapeNew (int int int float float) (int "gacela_cpPolyShapeNew"))
-(defentry cpShapeFree (int) (void "gacela_cpShapeFree"))
-
-;;; C-Gacela functions
-(defentry set-space-properties (int float float) (void "set_space_properties"))
-
-;;; Physics Subsystem
-(defstruct space address)
-(defstruct body address)
-(defstruct shape address)
-
-(let ((initialized nil)
- (mobs-space nil))
-
- (defun init-chipmunk ()
- (cond ((null initialized) (cpInitChipmunk) (setq initialized t))
- (t initialized)))
-
- (defun init-mobs-physics (&key (gravity nil))
- (cond ((null mobs-space) (init-chipmunk) (setq mobs-space (create-space)))
- (t mobs-space))))
-
-(defun create-space (&key (gravity nil))
- (init-chipmunk)
- (let ((new-space (make-space :address (cpSpaceNew)))
- (properties nil))
- (set-resource 'space new-space (gentemp))
- (cond (gravity (setq properties (union gravity properties))))
- (cond (properties (apply #'set-space-properties (cons (space-address new-space) properties))))
- new-space))
-
-(defun create-body (&key (mass INFINITY) (inertia INFINITY))
- (init-chipmunk)
- (let ((new-body (make-body :address (cpNewBody mass inertia INFINITY))))
- (set-resource 'body new-body (gentemp))
- new-body))
+++ /dev/null
-#include <chipmunk/chipmunk.h>
-
-void
-gacela_cpInitChipmunk (void)
-{
- cpInitChipmunk ();
-}
-
-void
-gacela_cpResetShapeIdCounter (void)
-{
- cpResetShapeIdCounter ();
-}
-
-int
-gacela_cpSpaceNew (void)
-{
- return cpSpaceNew ();
-}
-
-void
-gacela_cpSpaceAddBody (int space, int body)
-{
- cpSpaceAddBody (space, body);
-}
-
-void
-gacela_cpSpaceAddShape (int space, int shape)
-{
- cpSpaceAddShape (space, shape);
-}
-
-void
-gacela_cpSpaceFree (int space)
-{
- cpSpaceFree (space);
-}
-
-int
-gacela_cpBodyNew (float mass, float inertia, float infinity)
-{
- return cpBodyNew ((mass >= infinity ? INFINITY : mass), (inertia >= infinity ? INFINITY : inertia));
-}
-
-float
-gacela_cpMomentForCircle (float mass, float r1, float r2, float x, float y)
-{
- return cpMomentForCircle (mass, r1, r2, cpv (x, y));
-}
-
-void
-gacela_cpBodyFree (int space)
-{
- cpBodyFree (space);
-}
-
-int
-gacela_cpCircleShapeNew (int body, float radius, float x, float y)
-{
- return cpCircleShapeNew (body, radius, cpv (x, y));
-}
-
-int
-gacela_cpPolyShapeNew (int body, int numVerts, int verts, float x, float y)
-{
- return cpPolyShapeNew (body, numVerts, verts, cpv (x, y));
-}
-
-void
-gacela_cpShapeFree (int shape)
-{
- cpShapeFree (shape);
-}
-
-void
-set_cp_space_gravity (int space, float x, float y)
-{
- cpSpace *s = space;
-
- s->gravity = cpv (x, y);
-}
+++ /dev/null
-//#include <SDL/SDL.h>
-//#include <GL/gl.h>
-#include <libguile.h>
-
-static void*
-register_functions (void* data)
-{
- // scm_c_define_gsubr ("prueba", 0, 0, 0, &prueba);
-// scm_c_define_gsubr ("ver-contador", 0, 0, 0, &ver_contador);
-// scm_c_define_gsubr ("lanzar-bucle", 0, 0, 0, &lanzar_bucle);
- return NULL;
-}
-
-
-int main (int argc, char *argv[]) {
- // scm_with_guile (®ister_functions, NULL);
- scm_init_guile();
- scm_c_eval_string("(set-repl-prompt! \"gacela>\")");
- scm_c_eval_string("(use-modules (ice-9 readline))");
- scm_c_eval_string("(activate-readline)");
- scm_c_eval_string("(format #t \"eo~%\")");
-// scm_shell (argc, argv);
-}
-
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defmacro with-color (color &body code)
- (cond (color
- `(let ((original-color (get-current-color))
- result)
- (apply #'set-current-color ,color)
- (setq result ,@code)
- (apply #'set-current-color original-color)
- result))
- (t
- `(progn
- ,@code))))
-
-(defmacro progn-textures (&body code)
- `(let (values)
- (init-video-mode)
- (glEnable GL_TEXTURE_2D)
- (setq values (multiple-value-list (progn ,@code)))
- (glDisable GL_TEXTURE_2D)
- (apply #'values values)))
-
-(defun draw (&rest vertexes)
- (begin-draw (length vertexes))
- (draw-vertexes vertexes)
- (glEnd))
-
-(defun begin-draw (number-of-points)
- (cond ((= number-of-points 3) (glBegin GL_TRIANGLES))
- ((= number-of-points 4) (glBegin GL_QUADS))))
-
-(defun draw-vertexes (vertexes)
- (cond ((null vertexes) nil)
- (t (draw-vertex (car vertexes))
- (draw-vertexes (cdr vertexes)))))
-
-(defun draw-vertex (vertex &key texture-coord)
- (cond ((consp (car vertex))
- (with-color (car vertex)
- (apply #'simple-draw-vertex (cadr vertex))))
- (t (cond (texture-coord (apply #'glTexCoord2f texture-coord)))
- (apply #'simple-draw-vertex vertex))))
-
-(defun simple-draw-vertex (x y &optional (z 0))
- (cond ((3d-mode?) (glVertex3f x y z))
- (t (glVertex2f x y))))
-
-(defun load-image-for-texture (filename)
- (init-video-mode)
- (let ((image (IMG_Load filename)))
- (cond ((/= image 0)
- (let* ((width (surface-w image)) (height (surface-h image))
- (power-2 (nearest-power-of-two (min width height)))
- resized-image)
- (cond ((and (= width power-2) (= height power-2)) (values image width height))
- (t (setq resized-image (resize-surface image power-2 power-2))
- (SDL_FreeSurface image)
- (cond ((/= resized-image 0) (values resized-image width height))))))))))
-
-(defun resize-surface (surface width height)
- (let ((old-width (surface-w surface)) (old-height (surface-h surface)))
- (cond ((and (= width old-width) (= height old-height)) surface)
- (t (let ((zoomx (/ (+ width 0.5) old-width)) (zoomy (/ (+ height 0.5) old-height)))
- (zoomSurface surface zoomx zoomy 0))))))
-
-(defun load-texture (filename &key (min-filter GL_LINEAR) (mag-filter GL_LINEAR) static)
- (let ((key (make-resource-texture :filename filename :min-filter min-filter :mag-filter mag-filter)))
- (cond ((get-resource key) key)
- (t (true-load-texture filename min-filter mag-filter static)))))
-
-(defun true-load-texture (filename min-filter mag-filter static)
- (let ((key (make-resource-texture :filename filename :min-filter min-filter :mag-filter mag-filter)))
- (progn-textures
- (multiple-value-bind
- (image real-w real-h) (load-image-for-texture filename)
- (cond (image
- (let ((width (surface-w image)) (height (surface-h image))
- (byteorder (if (= (SDL_ByteOrder) SDL_LIL_ENDIAN)
- (if (= (surface-format-BytesPerPixel image) 3) GL_BGR GL_BGRA)
- (if (= (surface-format-BytesPerPixel image) 3) GL_RGB GL_RGBA)))
- (texture (car (glGenTextures 1))))
-
- (glBindTexture GL_TEXTURE_2D texture)
- (glTexImage2D GL_TEXTURE_2D 0 3 width height 0 byteorder GL_UNSIGNED_BYTE (surface-pixels image))
- (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER min-filter)
- (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER mag-filter)
- (SDL_FreeSurface image)
- (set-resource key
- `(:id-texture ,texture :width ,real-w :height ,real-h)
- (lambda () (true-load-texture filename min-filter mag-filter static))
- (lambda () (glDeleteTextures 1 `(,texture)))
- :static static)
- key)))))))
-
-(defun draw-image (filename &ptional (zoom 1))
- (let ((texture (load-texture filename)))
- (cond (texture (draw-texture texture zoom)))))
-
-(defun draw-texture (texture &optional (zoom 1))
- (cond (texture
- (let ((width (getf (get-resource texture) :width))
- (height (getf (get-resource texture) :height)))
- (draw-rectangle (* zoom width) (* zoom height) :texture texture)))))
-
-(defun draw-quad (v1 v2 v3 v4 &key texture)
- (let ((id-texture (getf (get-resource texture) :id-texture)))
- (cond (id-texture
- (progn-textures
- (glBindTexture GL_TEXTURE_2D id-texture)
- (begin-draw 4)
- (draw-vertex v1 :texture-coord '(0 0))
- (draw-vertex v2 :texture-coord '(1 0))
- (draw-vertex v3 :texture-coord '(1 1))
- (draw-vertex v4 :texture-coord '(0 1))
- (glEnd)))
- ((consp texture) (with-color texture (draw v1 v2 v3 v4)))
- (t (draw v1 v2 v3 v4)))))
-
-(defun draw-rectangle (width height &key texture)
- (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h)))
- (draw-quad (list -w h 0) (list w h 0) (list w -h 0) (list -w -h 0) :texture texture)))
-
-(defun draw-square (&key (size 1) texture)
- (draw-rectangle size size :texture texture))
-
-(defun draw-cube (&key (size 1) texture texture-1 texture-2 texture-3 texture-4 texture-5 texture-6)
- (let ((-size (neg size)))
- (progn-textures
- (glNormal3f 0 0 1)
- (draw-quad (list -size size size) (list size size size) (list size -size size) (list -size -size size) :texture (or texture-1 texture))
- (glNormal3f 0 0 -1)
- (draw-quad (list -size -size -size) (list size -size -size) (list size size -size) (list -size size -size) :texture (or texture-2 texture))
- (glNormal3f 0 1 0)
- (draw-quad (list size size size) (list -size size size) (list -size size -size) (list size size -size) :texture (or texture-3 texture))
- (glNormal3f 0 -1 0)
- (draw-quad (list -size -size size) (list size -size size) (list size -size -size) (list -size -size -size) :texture (or texture-4 texture))
- (glNormal3f 1 0 0)
- (draw-quad (list size -size -size) (list size -size size) (list size size size) (list size size -size) :texture (or texture-5 texture))
- (glNormal3f -1 0 0)
- (draw-quad (list -size -size size) (list -size -size -size) (list -size size -size) (list -size size size) :texture (or texture-6 texture)))))
-
-(defun add-light (&key light position ambient (id GL_LIGHT1) (turn-on t))
- (init-lighting)
- (and light (glLightfv id GL_DIFFUSE (first light) (second light) (third light) (fourth light)))
- (and light position (glLightfv GL_POSITION (first position) (second position) (third position) (fourth position)))
- (and ambient (glLightfv id GL_AMBIENT (first ambient) (second ambient) (third ambient) (fourth ambient)))
- (and turn-on (glEnable id))
- id)
-
-(defun translate (x y &optional (z 0))
- (glTranslatef x y z))
-
-(defun rotate (&rest rot)
- (cond ((3d-mode?) (apply #'3d-rotate rot))
- (t (apply #'2d-rotate rot))))
-
-(defun 3d-rotate (xrot yrot zrot)
- (glRotatef xrot 1 0 0)
- (glRotatef yrot 0 1 0)
- (glRotatef zrot 0 0 1))
-
-(defun 2d-rotate (rot)
- (glRotatef rot 0 0 1))
-
-(defun to-origin ()
- (glLoadIdentity)
- (cond ((3d-mode?) (camera-look))))
-
-(let ((camera-eye '(0 0 0)) (camera-center '(0 0 -100)) (camera-up '(0 1 0)))
- (defun set-camera (&key eye center up)
- (cond (eye (setq camera-eye eye)))
- (cond (center (setq camera-center center)))
- (cond (up (setq camera-up up))))
-
- (defun camera-look ()
- (apply #'gluLookAt (concatenate 'list camera-eye camera-center camera-up))))
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-;;; SDL Events
-(defconstant SDL_NOEVENT 0)
-(defconstant SDL_ACTIVEEVENT 1)
-(defconstant SDL_KEYDOWN 2)
-(defconstant SDL_KEYUP 3)
-(defconstant SDL_MOUSEMOTION 4)
-(defconstant SDL_MOUSEBUTTONDOWN 5)
-(defconstant SDL_MOUSEBUTTONUP 6)
-(defconstant SDL_JOYAXISMOTION 7)
-(defconstant SDL_JOYBALLMOTION 8)
-(defconstant SDL_JOYHATMOTION 9)
-(defconstant SDL_JOYBUTTONDOWN 10)
-(defconstant SDL_JOYBUTTONUP 11)
-(defconstant SDL_QUIT 12)
-(defconstant SDL_SYSWMEVENT 13)
-(defconstant SDL_EVENT_RESERVEDA 14)
-(defconstant SDL_EVENT_RESERVEDB 15)
-(defconstant SDL_VIDEORESIZE 16)
-(defconstant SDL_VIDEOEXPOSE 17)
-(defconstant SDL_EVENT_RESERVED2 18)
-(defconstant SDL_EVENT_RESERVED3 19)
-(defconstant SDL_EVENT_RESERVED4 20)
-(defconstant SDL_EVENT_RESERVED5 21)
-(defconstant SDL_EVENT_RESERVED6 22)
-(defconstant SDL_EVENT_RESERVED7 23)
-(defconstant SDL_USEREVENT 24)
-(defconstant SDL_NUMEVENTS 32)
-
-;;; Functions
-(defun get-event (events &rest types)
- (remove nil (mapcar
- (lambda (l)
- (cond ((member (getf l :type) types) l)))
- events)))
-
-(defun poll-events ()
- (let ((event (SDL_PollEvent)))
- (cond ((null event) nil)
- (t (cons event (poll-events))))))
-
-(defun process-events ()
- (let ((events (poll-events)))
- (quit? t (and (get-event events SDL_QUIT) t))
- (clear-key-state)
- (process-keyboard-events (get-event events SDL_KEYDOWN SDL_KEYUP))))
-
-(let (will-happen happenings)
- (defun next-happenings ()
- (setq happenings will-happen)
- (setq will-happen nil))
-
- (defun will-happen (happening)
- (setq will-happen (cons happening will-happen)))
-
- (defun is-happening? (happening &optional (test #'eql))
- (remove nil (mapcar
- (lambda (l)
- (cond ((funcall test happening l) l)))
- happenings))))
-
-(let (quit)
- (defun quit? (&optional change newquit)
- (if change (setq quit newquit) quit)))
-
-(defun process-keyboard-events (events)
- (cond (events
- (let ((event (car events)))
- (cond ((= (getf event :type) SDL_KEYDOWN) (key-press (getf event :key.keysym.sym)))
- ((= (getf event :type) SDL_KEYUP) (key-release (getf event :key.keysym.sym)))))
- (process-keyboard-events (cdr events)))))
-
-(let ((keymap (make-hash-table))
- (pressed (make-hash-table))
- (released (make-hash-table)))
- (defun key? (key)
- (gethash (get-keycode key) keymap))
-
- (defun key-pressed? (key)
- (gethash (get-keycode key) pressed))
-
- (defun key-released? (key)
- (gethash (get-keycode key) released))
-
- (defun key-press (key-code)
- (setf (gethash key-code keymap) t)
- (setf (gethash key-code pressed) t)
- (setf (gethash key-code released) nil))
-
- (defun key-release (key-code)
- (setf (gethash key-code keymap) nil)
- (setf (gethash key-code pressed) nil)
- (setf (gethash key-code released) t))
-
- (defun clear-keymap ()
- (clrhash keymap))
-
- (defun clear-key-state ()
- (clrhash pressed)
- (clrhash released)))
-
-(let ((keys
- '((8 . backspace)
- (9 . tab)
- (12 . clear)
- (13 . return)
- (19 . pause)
- (27 . escape)
- (32 . space)
- (33 . exclaim)
- (34 . quotedbl)
- (35 . hash)
- (36 . dollar)
- (38 . ampersand)
- (39 . quote)
- (40 . leftparen)
- (41 . rightparen)
- (42 . asterisk)
- (43 . plus)
- (44 . comma)
- (45 . minus)
- (46 . period)
- (47 . slash)
- (48 . 0)
- (49 . 1)
- (50 . 2)
- (51 . 3)
- (52 . 4)
- (53 . 5)
- (54 . 6)
- (55 . 7)
- (56 . 8)
- (57 . 9)
- (58 . colon)
- (59 . semicolon)
- (60 . less)
- (61 . equals)
- (62 . greater)
- (63 . question)
- (64 . at)
- (269 . kp-minus)
- (270 . kp-plus)
- (273 . up)
- (274 . down)
- (275 . right)
- (276 . left)
- (282 . f1)
- (283 . f2)
- (284 . f3)
- (285 . f4)
- (286 . f5)
- (287 . f6)
- (288 . f7)
- (289 . f8)
- (290 . f9)
- (291 . f10)
- (292 . f11)
- (293 . f12))))
-
- (defun get-keycode (keyname)
- (car (rassoc keyname keys)))
-
- (defun get-keyname (keycode)
- (cdr (assoc keycode keys))))
+++ /dev/null
-;;;
-;;; Chipmunk Physics Engine
-;;;
-
-(clines "#include \"gacela_chipmunk.c\"")
-
-;;; Chipmunk functions
-(defentry cpInitChipmunk () (void "gacela_cpInitChipmunk"))
-(defentry cpResetShapeIdCounter () (void "gacela_cpResetShapeIdCounter"))
-(defentry cpSpaceNew () (int "gacela_cpSpaceNew"))
-(defentry cpSpaceAddBody (int int) (void "gacela_cpSpaceAddBody"))
-(defentry cpSpaceAddShape (int int) (void "gacela_cpSpaceAddShape"))
-(defentry cpSpaceFree (int) (void "gacela_cpSpaceFree"))
-(defentry cpBodyNew (float float float) (int "gacela_cpBodyNew"))
-(defentry cpMomentForCircle (float float float float float) (float "gacela_cpMomentForCircle"))
-(defentry cpBodyFree (int) (void "gacela_cpBodyFree"))
-(defentry cpCircleShapeNew (int float float float) (int "gacela_cpCircleShapeNew"))
-(defentry cpPolyShapeNew (int int int float float) (int "gacela_cpPolyShapeNew"))
-(defentry cpShapeFree (int) (void "gacela_cpShapeFree"))
-
-;;; C-Gacela functions
-(defentry set-cp-space-gravity (int float float) (void "set_cp_space_gravity"))
-
-;;; Physics Subsystem
-(defstruct cp-space address gravity)
-(defstruct cp-body address position)
-(defstruct cp-shape address)
-
-(let ((initialized nil)
- (mobs-cp-space nil))
-
- (defun init-chipmunk ()
- (cond ((null initialized) (cpInitChipmunk) (setq initialized t))
- (t initialized)))
-
- (defun init-cp-space (&key (gravity nil))
- (cond ((null mobs-cp-space) (init-chipmunk) (setq mobs-cp-space (create-cp-space)))
- (t mobs-cp-space)))
-
- (defun add-cp-body (body)
- (cpSpaceAddBody (cp-space-address mobs-cp-space) (cp-body-address body)))
-
- (defun add-cp-shape (shape)
- (cpSpaceAddShape (cp-space-address mobs-cp-space) (cp-shape-address shape))))
-
-(defun create-cp-space (&key (gravity nil))
- (init-chipmunk)
- (let ((new-cp-space (make-cp-space :address (cpSpaceNew) :gravity gravity))
- (properties nil))
- (set-resource 'cp-space new-cp-space (gentemp))
- (cond (gravity (setq properties (union gravity properties))))
- (cond (properties (apply #'set-cp-space-properties (cons (cp-space-address new-cp-space) properties))))
- new-cp-space))
-
-(defun create-cp-body (&key (mass INFINITY) (inertia INFINITY) (x 0) (y 0))
- (init-chipmunk)
- (let ((new-cp-body (make-cp-body :address (cpNewBody mass inertia INFINITY) :position `(,x ,y))))
- (set-resource 'cp-body new-cp-body (gentemp))
- new-cp-body))
-
-(defun create-circle-cp-shape (cp-body shape)
- (init-chipmunk)
- (destructure ((shape ((x y) r)))
- (make-cp-shape :address (cpCircleShapeNew cp-body r x y))))
-
-(defun create-cp-shape (cp-body shape)
- (init-chipmunk)
- (let ((new-cp-shape (cond ((circle-p shape) (create-circle-cp-shape cp-body shape)))))
- (set-resource 'cp-shape new-cp-shape (gentemp))
- new-cp-shape))
-
-(defun cp-moment (mass shape)
- (cond ((circle-p shape) (destructure ((shape ((x y) r))) (cpMomentForCircle mass 0.0 r x y)))
- t INFINITY))
-
-;(defun use-chipmunk ()
-; (defun physics-add-mob (mass shape x y)
-; (init-cp-space)
-; (let ((new-cp-body (create-cp-body mass (cp-moment mass shape))))
-; (add-cp-body new-cp-body)
-
\ No newline at end of file
+++ /dev/null
-;;; Gacela, a GNU Common Lisp 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/>.
-
-
-(eval-when (compile load eval)
- (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
- (in-package 'gacela :nicknames '(gg) :use '(lisp)))
-
-
-(defun load-font (font-file &key (size 40) (encoding ft_encoding_unicode) static)
- (let* ((key (make-resource-font :filename font-file :encoding encoding))
- (res (get-resource key)))
- (cond (res (ftglSetFontFaceSize (getf res :id-font) size 72)
- key)
- (t (true-load-font font-file size encoding static)))))
-
-(defun true-load-font (font-file size encoding static)
- (let ((key (make-resource-font :filename font-file :encoding encoding))
- (font (ftglCreateTextureFont font-file)))
- (cond ((/= font 0)
- (ftglSetFontFaceSize font size 72)
- (ftglSetFontCharMap font encoding)
- (set-resource key
- `(:id-font ,font)
- (lambda () (true-load-font font-file size encoding static))
- (lambda () (ftglDestroyFont font))
- :static static)
- key))))
-
-(defun render-text (text font &key size)
- (let ((id-font (getf (get-resource font) :id-font)))
- (cond (size (ftglSetFontFaceSize id-font size 72)))
- (ftglRenderFont id-font text FTGL_RENDER_ALL)))
+++ /dev/null
-(clines "#include <pthread.h>")
-(clines "#include <time.h>")
-
-(clines "#define inheap(pp) ((char *)(pp) < heap_end)")
-(clines "static object pepe;")
-
-(defcfun "static object staticp (object array)" 0
- "if (inheap (array->st.st_self)) return Ct;"
- "else return Cnil;")
-
-(defcfun "static void *eval_code (void *parameter)" 0
- "int t = time (NULL);"
- "while (time (NULL) - t < 10);"
- (eval pepe))
-
-(defcfun "int run_thread (object code)" 0
- "pthread_t tid;"
- "int ret;"
- "pepe = code;"
- "ret = pthread_create (&tid, NULL, eval_code, NULL);"
- "return ret;")
-
-;(defentry eval-code (object) (void "eval_code"))
-(defentry run-thread (object) (int "run_thread"))
-(defentry staticp (object) (object "staticp"))
-
-(defun runt (code)
- (and (staticp code) (run-thread code)))
+++ /dev/null
-(clines "#include <pthread.h>")
-
-(clines "#define inheap(pp) ((char *)(pp) < heap_end)")
-(clines "static object code_for_eval_code;")
-
-(defcfun "static object staticp (object array)" 0
- "if (inheap (array->st.st_self)) return Ct;"
- "else return Cnil;")
-
-(defcfun "static void *eval_code (void *parameter)" 0
- (eval code_for_eval_code))
-
-(defcfun "int run_thread (object code)" 0
- "pthread_t tid;"
- "int ret;"
- "code_for_eval_code = code;"
- "ret = pthread_create (&tid, NULL, eval_code, NULL);"
- "return ret;")
-
-(defcfun "int runprocess (object code)" 0
- "int pid;"
- "pid = fork ();"
- "if (pid == 0) {"
- "close (0);"
- (eval code)
- "exit (0);"
- "} else {"
- "return pid;"
- "}")
-
-(defentry run-thread2 (object) (int "run_thread"))
-(defentry staticp (object) (object "staticp"))
-(defentry run-process (object) (int "runprocess"))
-
-(defun run-thread (code)
- (and (staticp code) (run-thread2 code)))
+++ /dev/null
-struct SDL_Rect {
- int x, y;
- int w, h;
-};
-struct SDL_Rect SSS1;
-
-main() {
-
-printf("(");
-printf("(|SDL_Rect| ");
-printf(" %d ",((char *)&SSS1.x - (char *)&SSS1));
-printf(" %d ",((char *)&SSS1.y - (char *)&SSS1));
-printf(" %d ",((char *)&SSS1.w - (char *)&SSS1));
-printf(" %d ",((char *)&SSS1.h - (char *)&SSS1));
-printf(")");
-printf(")"); ;}
\ No newline at end of file
projects / gacela.git / commitdiff