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
  20 (define *title* "Gacela")
  21 (define *width-screen* 640)
  22 (define *height-screen* 480)
  23 (define *bpp-screen* 32)
  24 (define *frames-per-second* 20)
  25 (define *mode* '2d)
  26
  27
  28 ;;; SDL Initialization Subsystem
  29
  30 (define init-sdl #f)
  31 (define sdl-on? #f)
  32 (define quit-sdl #f)
  33
  34 (let ((initialized #f))
  35   (set! init-sdl
  36         (lambda ()
  37           (cond ((not initialized) (SDL_Init SDL_INIT_EVERYTHING) (set! initialized #t))
  38                 (else initialized))))
  39
  40   (set! sdl-on?
  41         (lambda ()
  42           (if initialized #t #f)))
  43
  44   (set! quit-sdl
  45         (lambda ()
  46           (SDL_Quit)
  47           (set! initialized #f))))
  48
  49
  50 ;;; Video Subsystem
  51
  52 (define init-video-mode #f)
  53 (define video-mode-on? #f)
  54 (define resize-screen #f)
  55 (define quit-video-mode #f)
  56
  57 (let ((screen #f) (flags 0))
  58   (set! init-video-mode
  59         (lambda ()
  60           (cond ((not screen)
  61                  (init-sdl)
  62                  (let* ((props (get-game-properties))
  63                         (width (assoc-ref props 'width)) (height (assoc-ref props 'height))
  64                         (bpp (assoc-ref props 'bpp)) (title (assoc-ref props 'title))
  65                         (mode (assoc-ref props 'mode))
  66                         (info (SDL_GetVideoInfo)))
  67                    (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
  68                    (set! flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
  69                                   (if (= (assoc-ref info 'hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
  70                                   (if (= (assoc-ref info 'blit_hw) 0) 0 SDL_HWACCEL)))
  71                    (set! screen (SDL_SetVideoMode width height bpp flags))
  72                    (SDL_WM_SetCaption title "")
  73                    (init-gl)
  74                    (if (eq? mode '3d) (set-3d-mode) (set-2d-mode))))
  75                 (else #t))))
  76
  77   (set! video-mode-on?
  78         (lambda () (if screen #t #f)))
  79
  80   (set! resize-screen
  81         (lambda* (width height #:optional (bpp current-bpp))
  82           (cond (screen (set! screen (SDL_SetVideoMode width height bpp flags))
  83                         (resize-screen-GL width height)))))
  84
  85   (set! quit-video-mode
  86         (lambda ()
  87           (SDL_FreeSurface screen)
  88           (set! screen #f))))
  89
  90 (define (set-2d-mode)
  91   (cond ((not (3d-mode?))
  92          (init-video-mode)
  93          (glDisable GL_DEPTH_TEST)
  94          (apply-mode-change))))
  95
  96 (define (set-3d-mode)
  97   (cond ((3d-mode?)
  98          (init-video-mode)
  99          (glClearDepth 1)
 100          (glEnable GL_DEPTH_TEST)
 101          (glDepthFunc GL_LEQUAL)
 102          (apply-mode-change))))
 103
 104 (define (apply-mode-change)
 105   (let* ((props (get-game-properties))
 106          (width (assoc-ref props 'width)) (height (assoc-ref props 'height)))
 107     (resize-screen-GL width height)))
 108
 109 (define (3d-mode?)
 110   (eq? (assoc-ref (get-game-properties) 'mode) '3d))
 111
 112 (define (init-gl)
 113   (glShadeModel GL_SMOOTH)
 114   (glClearColor 0 0 0 0)
 115 ;  (glClearDepth 1)
 116 ;  (glDepthFunc GL_LEQUAL)
 117   (glEnable GL_BLEND)
 118 ;  (glBlendFunc GL_SRC_ALPHA GL_ONE)
 119   (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
 120   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
 121   #t)
 122
 123 (define (init-lighting)
 124   (init-video-mode)
 125   (glEnable GL_LIGHTING))
 126
 127 (define (resize-screen-GL width height)
 128   (glViewport 0 0 width height)
 129   (glMatrixMode GL_PROJECTION)
 130   (glLoadIdentity)
 131   (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height))))
 132                       (gluPerspective 45 ratio 0.1 100))) ;0.1
 133         (else (let* ((w (/ width 2)) (h (/ height 2)))
 134                 (glOrtho (- w) w (- h) h 0 1))))
 135   (glMatrixMode GL_MODELVIEW)
 136   (glLoadIdentity)
 137   #t)
 138
 139 (define get-current-color #f)
 140 (define set-current-color #f)
 141
 142 (let ((current-color '(1 1 1 1)))
 143   (set! get-current-color
 144         (lambda ()
 145           current-color))
 146
 147   (set! set-current-color
 148         (lambda* (red green blue #:optional (alpha 1))
 149           (set! current-color (list red green blue alpha))
 150           (glColor4f red green blue alpha))))
 151
 152
 153 ;;; Audio Subsystem
 154
 155 (define init-audio #f)
 156 (define quit-audio #f)
 157
 158 (let ((audio #f))
 159   (set! init-audio
 160         (lambda ()
 161           (cond ((not audio) (begin (init-sdl) (set! audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096))))
 162                 (else audio))))
 163
 164   (set! quit-audio
 165         (lambda ()
 166           (Mix_CloseAudio)
 167           (set! audio #f))))
 168
 169
 170 ;;; Resources Cache
 171
 172 (define resources-cache (make-weak-value-hash-table))
 173
 174 (define get-resource-from-cache #f)
 175 (define insert-resource-into-cache #f)
 176
 177 (let ()
 178   (set! get-resource-from-cache
 179         (lambda (key)
 180           (hash-ref resources-cache key)))
 181
 182   (set! insert-resource-into-cache
 183         (lambda (key res)
 184           (hash-set! resources-cache key res))))
 185
 186 ;;; GaCeLa Functions
 187
 188 (define set-frames-per-second #f)
 189 (define init-frame-time #f)
 190 (define delay-frame #f)
 191
 192 (let ((time 0) (time-per-frame (/ 1000.0 *frames-per-second*)))
 193   (set! set-frames-per-second
 194         (lambda (fps)
 195           (set! time-per-frame (/ 1000.0 fps))))
 196
 197   (set! init-frame-time
 198         (lambda ()
 199           (set! time (SDL_GetTicks))))
 200
 201   (set! delay-frame
 202         (lambda ()
 203           (let ((frame-time (- (SDL_GetTicks) time)))
 204             (cond ((< frame-time time-per-frame)
 205                    (SDL_Delay (- time-per-frame frame-time))))))))
 206
 207
 208 (define set-game-properties! #f)
 209 (define get-game-properties #f)
 210
 211 (let ((ptitle *title*) (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode *mode*))
 212   (set! set-game-properties!
 213         (lambda* (#:key title width height bpp fps mode)
 214 ;         (init-video-mode)
 215           (if title
 216               (begin
 217                 (set! ptitle title)
 218                 (if (video-mode-on?) (SDL_WM_SetCaption title ""))))
 219           (if (or width height bpp)
 220               (begin
 221                 (if width (set! pwidth width))
 222                 (if height (set! pheight height))
 223                 (if bpp (set! pbpp bpp))
 224                 (if (video-mode-on?) (resize-screen pwidth pheight pbpp))))
 225           (if fps
 226               (begin
 227                 (set! pfps fps)
 228                 (set-frames-per-second fps)))
 229           (if mode
 230               (begin
 231                 (set! pmode mode)
 232                 (if (video-mode-on?)
 233                     (if (eq? mode '3d) (set-3d-mode) (set-2d-mode)))))
 234           (get-game-properties)))
 235
 236   (set! get-game-properties
 237         (lambda ()
 238           `((title . ,ptitle) (width . ,pwidth) (height . ,pheight) (bpp . ,pbpp) (fps . ,pfps) (mode . ,pmode)))))
 239
 240
 241 (define-macro (run-game . code)
 242   `(let ((game-function ,(if (null? code)
 243                              `(lambda () #f)
 244                              `(lambda () ,@code))))
 245      (init-video-mode)
 246      (set-game-code game-function)
 247      (cond ((not (game-running?))
 248             (game-loop)))))
 249
 250 (define game-loop #f)
 251 (define game-running? #f)
 252 (define set-game-code #f)
 253
 254 (let ((running #f) (game-code #f) (mobs '()))
 255   (set! game-loop
 256         (lambda ()
 257           (set! mobs (get-active-mobs))
 258           (set! running #t)
 259           (quit! #f)
 260           (do () ((quit?))
 261             (init-frame-time)
 262             (check-connections)
 263             (eval-from-clients)
 264             (process-events)
 265             (cond ((not (quit?))
 266                    (cond ((video-mode-on?)
 267                           (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
 268                           (to-origin)))
 269                    (cond ((mobs-changed?) (set! mobs (get-active-mobs))))
 270                    (if (procedure? game-code)
 271                        (catch #t
 272                               (lambda () (game-code))
 273                               (lambda (key . args) #f)))
 274                    (cond ((video-mode-on?)
 275                           (run-mobs mobs)
 276                           (SDL_GL_SwapBuffers)))
 277                    (delay-frame))))
 278           (set! running #f)))
 279
 280   (set! game-running?
 281         (lambda ()
 282           running))
 283
 284   (set! set-game-code
 285         (lambda (game-function)
 286           (set! game-code game-function))))