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