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