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 (eval-when (compile)
  19            (make-package 'gacela :nicknames '(gg) :use '(lisp))
  20            (in-package 'gacela :nicknames '(gg) :use '(lisp)))
  21
  22 ;(eval-when (load)
  23 ;          (make-package 'gacela :nicknames '(gg) :use '(lisp))
  24 ;          (in-package 'gacela :nicknames '(gg) :use '(lisp)))
  25
  26 (when (not (find-package 'gacela))
  27   (make-package 'gacela :nicknames '(gg) :use '(lisp)))
  28
  29 ;(eval-when (compile) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
  30 (eval-when (eval load) (in-package 'gacela :nicknames '(gg) :use '(lisp)))
  31
  32 ;;; Default values for Gacela
  33 (defvar *width-screen* 640)
  34 (defvar *height-screen* 480)
  35 (defvar *bpp-screen* 32)
  36 (defvar *frames-per-second* 20)
  37
  38 ;;; SDL Initialization Subsystem
  39 (let (initialized)
  40
  41   (defun init-sdl ()
  42     (cond ((null initialized) (setq initialized (SDL_Init SDL_INIT_EVERYTHING)))
  43           (t initialized)))
  44
  45   (defun quit-sdl ()
  46     (setq initialized (SDL_Quit))))
  47
  48
  49 ;;; Video Subsystem
  50 (let (screen flags (current-width *width-screen*) (current-height *height-screen*) current-bpp)
  51
  52   (defun init-video-mode (&key (width current-width) (height current-height) (bpp *bpp-screen*))
  53     (cond ((null screen)
  54            (init-sdl)
  55            (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
  56            (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
  57                           (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
  58                           (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL)))
  59            (setq screen (SDL_SetVideoMode width height bpp flags))
  60            (init-GL)
  61            (resize-screen-GL width height)
  62            (setq current-width width current-height height current-bpp bpp))
  63           (t t)))
  64
  65   (defun resize-screen (width height &optional (bpp current-bpp))
  66     (cond (screen (setq screen (SDL_SetVideoMode width height bpp flags))
  67                   (resize-screen-GL width height)))
  68     (setq current-width width current-height height))
  69
  70   (defun apply-mode-change ()
  71     (resize-screen-GL current-width current-height))
  72
  73   (defun quit-video-mode ()
  74     (setq screen nil)))
  75
  76 (defun set-2d-mode ()
  77   (cond ((3d-mode?)
  78          (init-video-mode)
  79          (glDisable GL_DEPTH_TEST)
  80          (apply-mode-change))))
  81
  82 (defun set-3d-mode ()
  83   (cond ((not (3d-mode?))
  84          (init-video-mode)
  85          (glClearDepth 1)
  86          (glEnable GL_DEPTH_TEST)
  87          (glDepthFunc GL_LEQUAL)
  88          (apply-mode-change))))
  89
  90 (defun 3d-mode? ()
  91   (eq (getf (get-game-properties) :mode) '3d))
  92
  93 (defun init-GL ()
  94   (glShadeModel GL_SMOOTH)
  95   (glClearColor 0 0 0 0)
  96 ;  (glClearDepth 1)
  97 ;  (glDepthFunc GL_LEQUAL)
  98 ;  (glEnable GL_BLEND)
  99 ;  (glBlendFunc GL_SRC_ALPHA GL_ONE)
 100   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
 101   t)
 102
 103 (defun init-lighting ()
 104   (init-video-mode)
 105   (glEnable GL_LIGHTING))
 106
 107 (defun resize-screen-GL (width height)
 108   (glViewPort 0 0 width height)
 109   (glMatrixMode GL_PROJECTION)
 110   (glLoadIdentity)
 111   (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height))))
 112                       (gluPerspective 45 ratio 0.1 100))) ;0.1
 113         (t (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h)))
 114              (glOrtho -w w -h h 0 1))))
 115   (glMatrixMode GL_MODELVIEW)
 116   (glLoadIdentity)
 117   t))
 118
 119 (let ((current-color '(1 1 1 1)))
 120   (defun get-current-color ()
 121     current-color)
 122
 123   (defun set-current-color (red green blue &optional (alpha 1))
 124     (setq current-color (list red green blue alpha))
 125     (glColor4f red green blue alpha)))
 126
 127 (defun load-image (image-file &key (transparent-color nil))
 128   (init-video-mode)
 129   (let ((loaded-image (IMG_Load image-file)))
 130     (cond ((= loaded-image 0) nil)
 131           (t (let ((optimized-image (SDL_DisplayFormat loaded-image)))
 132                (SDL_FreeSurface loaded-image)
 133                (cond ((= optimized-image 0) nil)
 134                      ((null transparent-color) optimized-image)
 135                      (t (SDL_SetColorKey optimized-image
 136                                          SDL_SRCCOLORKEY
 137                                          (SDL_MapRGB (surface-format optimized-image)
 138                                                      (car transparent-color)
 139                                                      (cadr transparent-color)
 140                                                      (caddr transparent-color)))
 141                         optimized-image)))))))
 142
 143
 144 ;;; Audio Subsystem
 145 (let ((audio nil))
 146
 147   (defun init-audio ()
 148     (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 2 4096))))
 149           (t audio)))
 150
 151   (defun quit-audio ()
 152     (setq audio (Mix_CloseAudio))))
 153
 154
 155 ;;; Resources Manager
 156 (defstruct resource plist constructor destructor time)
 157
 158 (defun make-resource-texture (&key filename min-filter mag-filter)
 159   `(:type texture :filename ,filename :min-filter ,min-filter :mag-filter ,mag-filter))
 160
 161 (defun make-resource-font (&key filename encoding)
 162   `(:type font :filename ,filename :enconding ,encoding))
 163
 164 (defmacro get-rtime (key)
 165   `(resource-time (gethash ,key resources-table)))
 166
 167 (defmacro get-rplist (key)
 168   `(resource-plist (gethash ,key resources-table)))
 169
 170 (defmacro get-rconstructor (key)
 171   `(resource-constructor (gethash ,key resources-table)))
 172
 173 (defmacro get-rdestructor (key)
 174   `(resource-destructor (gethash ,key resources-table)))
 175
 176 (let ((resources-table (make-hash-table :test 'equal))
 177       (expiration-time 50000))
 178
 179   (defun set-expiration-time (new-time)
 180     (setq expiration-time new-time))
 181
 182   (defun set-resource (key plist constructor destructor &key static)
 183     (expire-resources)
 184     (setf (gethash key resources-table)
 185           (make-resource :plist plist
 186                          :constructor constructor
 187                          :destructor destructor
 188                          :time (if static t (SDL_GetTicks)))))
 189
 190   (defun get-resource (key)
 191     (cond ((null (gethash key resources-table)) nil)
 192           (t (let ((time (get-rtime key)))
 193                (cond ((null time) (funcall (get-rconstructor key)))
 194                      ((numberp time) (setf (get-rtime key) (SDL_GetTicks))))
 195                (get-rplist key)))))
 196
 197   (defun free-resource (key)
 198     (funcall (get-rdestructor key))
 199     (setf (get-rtime key) nil))
 200
 201   (defun expire-resource (key &optional (now (SDL_GetTicks)))
 202     (let ((time (get-rtime key)))
 203       (cond ((and (numberp time) (> (- now time) expiration-time)) (free-resource key)))))
 204
 205   (defun expire-resources ()
 206     (maphash (lambda (key res) (expire-resource key)) resources-table))
 207
 208   (defun free-all-resources ()
 209     (maphash (lambda (key res) (free-resource key)) resources-table)))
 210
 211
 212 ;;; Connection with Gacela Clients
 213 (let (server-socket clients)
 214   (defun start-server (port)
 215     (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-connections)))))
 216
 217   (defun check-connections ()
 218     (cond ((and server-socket (listen server-socket)) (setq clients (cons (si::accept server-socket) clients)))))
 219
 220   (defun eval-from-clients ()
 221     (labels ((eval-clients (cli-socks)
 222                            (cond (cli-socks
 223                                   (let ((cli (car cli-socks)))
 224                                     (cond ((si::listen cli)
 225                                            (secure-block cli (eval (read cli)))
 226                                            (si::close cli)
 227                                            (eval-clients (cdr cli-socks)))
 228                                           (t
 229                                            (cons cli (eval-clients (cdr cli-socks))))))))))
 230             (setq clients (eval-clients clients))))
 231
 232   (defun stop-server ()
 233     (cond (server-socket (si::close server-socket) (setq server-socket nil)))
 234     (cond (clients
 235            (labels ((close-clients (cli-socks)
 236                                    (si::close (car cli-socks))
 237                                    (close-clients (cdr cli-socks))))
 238                    (close-clients clients))
 239            (setq clients nil)))))
 240
 241
 242 ;;; GaCeLa Functions
 243 (let (time (time-per-frame (/ 1000.0 *frames-per-second*)))
 244   (defun set-frames-per-second (fps)
 245     (setq time-per-frame (/ 1000.0 fps)))
 246
 247   (defun init-frame-time ()
 248     (setq time (SDL_GetTicks)))
 249
 250   (defun delay-frame ()
 251     (let ((frame-time (- (SDL_GetTicks) time)))
 252       (cond ((< frame-time time-per-frame)
 253              (SDL_Delay (- time-per-frame frame-time)))))))
 254
 255
 256 (let ((ptitle "") (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode '2d))
 257   (defun set-game-properties (&key title width height bpp fps mode)
 258     (init-video-mode)
 259     (when title (progn (setq ptitle title) (SDL_WM_SetCaption title "")))
 260     (when (or width height bpp)
 261       (progn
 262         (when width (setq pwidth width))
 263         (when height (setq pheight height))
 264         (when bpp (setq pbpp bpp))
 265         (resize-screen pwidth pheight pbpp)))
 266     (when fps (progn (setq pfps fps) (set-frames-per-second fps)))
 267     (when mode (progn (setq pmode mode) (if (eq mode '3d) (set-3d-mode) (set-2d-mode))))
 268     (get-game-properties))
 269
 270   (defun get-game-properties ()
 271     (list :title ptitle :width pwidth :height pheight :bpp pbpp :fps pfps :mode pmode)))
 272
 273
 274 (defmacro run-game (&body code)
 275   `(let ((game-function (lambda () ,@code)))
 276      (init-video-mode)
 277      (set-game-code game-function)
 278      (cond ((not (game-running?))
 279             (init-frame-time)
 280             (process-events)
 281             (game-loop)))))
 282
 283 (let (running game-code)
 284   (defun game-loop ()
 285     (setq running t)
 286     (do () ((quit?))
 287         (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
 288         (to-origin)
 289         (when (functionp game-code) (funcall game-code))
 290         (SDL_GL_SwapBuffers)
 291         (delay-frame)
 292         (init-frame-time)
 293         (check-connections)
 294         (eval-from-clients)
 295         (process-events))
 296     (setq running nil))
 297
 298   (defun game-running? ()
 299     running)
 300
 301   (defun set-game-code (game-function)
 302     (setq game-code game-function)))
 303
 304 (defun quit-game ()
 305   (free-all-resources)
 306 ;  (quit-audio)
 307   (quit-video-mode)
 308   (quit-all-mobs)
 309 ;  (clear-events)
 310 ;  (quit-events)
 311   (quit-sdl))