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