gacela.lisp

   1 ;;; Gacela, a GNU Common Lisp extension for fast games development
   2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation, either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 (in-package :gacela :nicknames '(gg))
  19
  20 ;;; Default values for Gacela
  21 (defvar *width-screen* 640)
  22 (defvar *height-screen* 480)
  23 (defvar *bpp-screen* 32)
  24 (defvar *title-screen* "Happy Hacking!!")
  25 (defvar *frames-per-second* 20)
  26 (defvar *transparent-color* '(:red 0 :green 0 :blue 0))
  27 (defvar *background-color* '(:red 0 :green 0 :blue 0))
  28
  29 ;;; SDL Initialization Subsystem
  30 (let (initialized)
  31
  32   (defun init-sdl ()
  33     (cond ((null initialized) (setq initialized (SDL_Init SDL_INIT_EVERYTHING)))
  34           (t initialized)))
  35
  36   (defun quit-sdl ()
  37     (setq initialized (SDL_Quit))))
  38
  39
  40 ;;; Video Subsystem
  41 (let (screen flags current-width current-height)
  42
  43   (defun init-video-mode (&key (width *width-screen*) (height *height-screen*) (bpp *bpp-screen*))
  44     (cond ((null screen)
  45            (init-sdl)
  46            (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
  47            (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
  48                           (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
  49                           (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL)))
  50            (setq screen (SDL_SetVideoMode width height bpp flags))
  51            (init-GL)
  52            (resize-screen-GL width height)
  53            (setq current-width width current-height height))
  54           (t t)))
  55
  56   (defun resize-screen (width height bpp)
  57     (setq screen (SDL_SetVideoMode width height bpp flags))
  58     (resize-screen-GL width height)
  59     (setq current-width width current-height height))
  60
  61   (defun apply-mode-change ()
  62     (resize-screen-GL current-width current-height))
  63
  64   (defun fill-screen (color)
  65     (init-video-mode)
  66     (fill-surface screen (getf color :red) (getf color :green) (getf color :blue)))
  67
  68   (defun quit-video-mode ()
  69     (setq screen nil)))
  70
  71 (let ((mode '2d))
  72   (defun set-2d-mode ()
  73     (cond ((3d-mode?)
  74            (setq mode '2d)
  75            (init-video-mode)
  76            (glDisable GL_DEPTH_TEST)
  77            (apply-mode-change))))
  78
  79   (defun set-3d-mode ()
  80     (cond ((not (3d-mode?))
  81            (setq mode '3d)
  82            (init-video-mode)
  83            (glClearDepth 1)
  84            (glEnable GL_DEPTH_TEST)
  85            (glDepthFunc GL_LEQUAL)
  86            (apply-mode-change))))
  87
  88   (defun 3d-mode? ()
  89     (eq mode '3d)))
  90
  91 (defun init-GL ()
  92   (glShadeModel GL_SMOOTH)
  93   (glClearColor 0 0 0 0)
  94 ;  (glClearDepth 1)
  95 ;  (glDepthFunc GL_LEQUAL)
  96 ;  (glEnable GL_BLEND)
  97 ;  (glBlendFunc GL_SRC_ALPHA GL_ONE)
  98   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
  99   t)
 100
 101 (defun init-lighting ()
 102   (init-video-mode)
 103   (glEnable GL_LIGHTING))
 104
 105 (defun resize-screen-GL (width height)
 106   (glViewPort 0 0 width height)
 107   (glMatrixMode GL_PROJECTION)
 108   (glLoadIdentity)
 109   (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height))))
 110                       (gluPerspective 45 ratio 0.1 100))) ;0.1
 111         (t (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h)))
 112              (glOrtho -w w -h h 0 1))))
 113   (glMatrixMode GL_MODELVIEW)
 114   (glLoadIdentity)
 115   t))
 116
 117 (let ((current-color '(1 1 1 1)))
 118   (defun get-current-color ()
 119     current-color)
 120
 121   (defun set-current-color (red green blue &optional (alpha 1))
 122     (setq current-color (list red green blue alpha))
 123     (glColor4f red green blue alpha)))
 124
 125 (defun load-image (image-file &key (transparent-color nil))
 126   (init-video-mode)
 127   (let ((loaded-image (IMG_Load image-file)))
 128     (cond ((= loaded-image 0) nil)
 129           (t (let ((optimized-image (SDL_DisplayFormat loaded-image)))
 130                (SDL_FreeSurface loaded-image)
 131                (cond ((= optimized-image 0) nil)
 132                      ((null transparent-color) optimized-image)
 133                      (t (SDL_SetColorKey optimized-image
 134                                          SDL_SRCCOLORKEY
 135                                          (SDL_MapRGB (surface-format optimized-image)
 136                                                      (car transparent-color)
 137                                                      (cadr transparent-color)
 138                                                      (caddr transparent-color)))
 139                         optimized-image)))))))
 140
 141
 142 ;;; Audio Subsystem
 143 (let ((audio nil))
 144
 145   (defun init-audio ()
 146     (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 2 4096))))
 147           (t audio)))
 148
 149   (defun quit-audio ()
 150     (setq audio (Mix_CloseAudio))))
 151
 152
 153 ;;; Resources Manager
 154 (defstruct resource plist constructor destructor time)
 155
 156 (defun make-resource-texture (&key filename min-filter mag-filter)
 157   `(:type texture :filename ,filename :min-filter ,min-filter :mag-filter ,mag-filter))
 158
 159 (defun make-resource-font (&key filename encoding)
 160   `(:type font :filename ,filename :enconding ,encoding))
 161
 162 (defmacro get-rtime (key)
 163   `(resource-time (gethash ,key resources-table)))
 164
 165 (defmacro get-rplist (key)
 166   `(resource-plist (gethash ,key resources-table)))
 167
 168 (defmacro get-rconstructor (key)
 169   `(resource-constructor (gethash ,key resources-table)))
 170
 171 (defmacro get-rdestructor (key)
 172   `(resource-destructor (gethash ,key resources-table)))
 173
 174 (let ((resources-table (make-hash-table :test 'equal))
 175       (expiration-time 50000))
 176
 177   (defun set-expiration-time (new-time)
 178     (setq expiration-time new-time))
 179
 180   (defun set-resource (key plist constructor destructor &key static)
 181     (expire-resources)
 182     (setf (gethash key resources-table)
 183           (make-resource :plist plist
 184                          :constructor constructor
 185                          :destructor destructor
 186                          :time (if static t (SDL_GetTicks)))))
 187
 188   (defun get-resource (key)
 189     (cond ((null (gethash key resources-table)) nil)
 190           (t (let ((time (get-rtime key)))
 191                (cond ((null time) (funcall (get-rconstructor key)))
 192                      ((numberp time) (setf (get-rtime key) (SDL_GetTicks))))
 193                (get-rplist key)))))
 194
 195   (defun free-resource (key)
 196     (funcall (get-rdestructor key))
 197     (setf (get-rtime key) nil))
 198
 199   (defun expire-resource (key &optional (now (SDL_GetTicks)))
 200     (let ((time (get-rtime key)))
 201       (cond ((and (numberp time) (> (- now time) expiration-time)) (free-resource key)))))
 202
 203   (defun expire-resources ()
 204     (maphash (lambda (key res) (expire-resource key)) resources-table))
 205
 206   (defun free-all-resources ()
 207     (maphash (lambda (key res) (free-resource key)) resources-table)))
 208
 209
 210 ;;; Connection with Gacela Skin Clients
 211 (let (server-socket clients)
 212   (defun start-skin-server (port)
 213     (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-skin-connections)))))
 214
 215   (defun check-skin-connections ()
 216     (cond ((and server-socket (listen server-socket)) (setq clients (cons (si::accept server-socket) clients)))))
 217
 218   (defun eval-from-skin ()
 219     (labels ((eval-clients (cli-socks)
 220                            (cond (cli-socks
 221                                   (let ((cli (car cli-socks)))
 222                                     (cond ((si::listen cli)
 223                                            (secure-block cli (eval (read cli)))
 224                                            (si::close cli)
 225                                            (eval-clients (cdr cli-socks)))
 226                                           (t
 227                                            (cons cli (eval-clients (cdr cli-socks))))))))))
 228             (setq clients (eval-clients clients))))
 229
 230   (defun stop-skin-server ()
 231     (cond (server-socket (si::close server-socket) (setq server-socket nil)))
 232     (cond (clients
 233            (labels ((close-clients (cli-socks)
 234                                    (si::close (car cli-socks))
 235                                    (close-clients (cdr cli-socks))))
 236                    (close-clients clients))
 237            (setq clients nil)))))
 238
 239
 240 ;;; GaCeLa Functions
 241 (let (time (time-per-frame (/ 1000.0 *frames-per-second*)))
 242   (defun set-frames-per-second (fps)
 243     (setq time-per-frame (/ 1000.0 fps)))
 244
 245   (defun init-frame-time ()
 246     (setq time (SDL_GetTicks)))
 247
 248   (defun delay-frame ()
 249     (let ((frame-time (- (SDL_GetTicks) time)))
 250       (cond ((< frame-time time-per-frame)
 251              (SDL_Delay (- time-per-frame frame-time)))))))
 252
 253
 254 (defmacro run-game (title &body code)
 255   `(let ((game-function (lambda () ,@code)))
 256      (init-video-mode)
 257      (SDL_WM_SetCaption ,title "")
 258      (set-game-code game-function)
 259      (cond ((not (game-running?))
 260             (init-frame-time)
 261             (process-events)
 262             (game-loop)))))
 263
 264 (let (running game-code)
 265   (defun game-loop ()
 266     (setq running t)
 267     (do () ((quit?))
 268         (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
 269         (glLoadIdentity)
 270 (gluLookAt 0 0 50 0 0 0 0 1 0)
 271         (when (functionp game-code) (funcall game-code))
 272         (SDL_GL_SwapBuffers)
 273         (delay-frame)
 274         (init-frame-time)
 275         (check-skin-connections)
 276         (eval-from-skin)
 277         (process-events))
 278     (setq running nil))
 279
 280   (defun game-running? ()
 281     running)
 282
 283   (defun set-game-code (game-function)
 284     (setq game-code game-function)))
 285
 286 (defun quit-game ()
 287   (free-all-resources)
 288 ;  (quit-audio)
 289   (quit-video-mode)
 290   (quit-all-mobs)
 291 ;  (clear-events)
 292 ;  (quit-events)
 293   (quit-sdl))