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