src/gacela.scm

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