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