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 (define-module (gacela gacela)
  19   #:use-module (gacela events)
  20   #:use-module (gacela video)
  21   #:use-module (gacela audio)
  22   #:use-module (ice-9 optargs)
  23   #:export (load-texture
  24             load-font)
  25   #:re-export (get-current-color
  26                set-current-color
  27                with-color
  28                progn-textures
  29                draw
  30                draw-texture
  31                draw-line
  32                draw-quad
  33                draw-rectangle
  34                draw-square
  35                draw-cube
  36                translate
  37                rotate
  38                to-origin
  39                add-light
  40                set-camera
  41                camera-look
  42                render-text
  43                init-video
  44                quit-video))
  45
  46
  47 ;;; Default values for Gacela
  48
  49 (define *title* "Gacela")
  50 (define *width-screen* 640)
  51 (define *height-screen* 480)
  52 (define *bpp-screen* 32)
  53 (define *frames-per-second* 20)
  54 (define *mode* '2d)
  55
  56
  57 ;;; Resources Cache
  58
  59 (define resources-cache (make-weak-value-hash-table))
  60
  61 (define from-cache #f)
  62 (define into-cache #f)
  63
  64 (let ()
  65   (set! from-cache
  66         (lambda (key)
  67           (hash-ref resources-cache key)))
  68
  69   (set! into-cache
  70         (lambda (key res)
  71           (hash-set! resources-cache key res))))
  72
  73 (define-macro (use-cache-with module proc)
  74   (let* ((pwc (string->symbol (string-concatenate (list (symbol->string proc) "-without-cache")))))
  75     `(begin
  76        (define ,pwc (@ ,module ,proc))
  77        (define (,proc . param)
  78          (let* ((key param)
  79                 (res (from-cache key)))
  80            (cond (res
  81                   res)
  82                  (else
  83                   (set! res (apply ,pwc param))
  84                   (into-cache key res)
  85                   res)))))))
  86
  87 (use-cache-with (gacela video) load-texture)
  88 (use-cache-with (gacela video) load-font)
  89
  90
  91 ;;; GaCeLa Functions
  92
  93 (define set-game-properties! #f)
  94 (define get-game-properties #f)
  95
  96 (let ((ptitle *title*) (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode *mode*))
  97   (set! set-game-properties!
  98         (lambda* (#:key title width height bpp fps mode)
  99 ;         (init-video-mode)
 100           (if title
 101               (begin
 102                 (set! ptitle title)
 103                 (if (video-mode-on?) (SDL_WM_SetCaption title ""))))
 104           (if (or width height bpp)
 105               (begin
 106                 (if width (set! pwidth width))
 107                 (if height (set! pheight height))
 108                 (if bpp (set! pbpp bpp))
 109                 (if (video-mode-on?) (resize-screen pwidth pheight pbpp))))
 110           (if fps
 111               (begin
 112                 (set! pfps fps)
 113                 (set-frames-per-second fps)))
 114           (if mode
 115               (begin
 116                 (set! pmode mode)
 117                 (if (video-mode-on?)
 118                     (if (eq? mode '3d) (set-3d-mode) (set-2d-mode)))))
 119           (get-game-properties)))
 120
 121   (set! get-game-properties
 122         (lambda ()
 123           `((title . ,ptitle) (width . ,pwidth) (height . ,pheight) (bpp . ,pbpp) (fps . ,pfps) (mode . ,pmode)))))
 124
 125
 126 (define-macro (run-game . code)
 127   `(let ((game-function ,(if (null? code)
 128                              `(lambda () #f)
 129                              `(lambda () ,@code))))
 130      (init-video-mode)
 131      (set-game-code game-function)
 132      (cond ((not (game-running?))
 133             (game-loop)))))
 134
 135 (define game-loop #f)
 136 (define game-running? #f)
 137 (define set-game-code #f)
 138
 139 (let ((running #f) (game-code #f))
 140   (set! game-loop
 141         (lambda ()
 142           (refresh-active-mobs)
 143           (set! running #t)
 144           (quit! #f)
 145           (do () ((quit?))
 146             (init-frame-time)
 147             (check-connections)
 148             (eval-from-clients)
 149             (process-events)
 150             (cond ((not (quit?))
 151                    (cond ((video-mode-on?)
 152                           (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
 153                           (to-origin)))
 154                    (refresh-active-mobs)
 155                    (if (procedure? game-code)
 156                        (catch #t
 157                               (lambda () (game-code))
 158                               (lambda (key . args) #f)))
 159                    (cond ((video-mode-on?)
 160                           (run-mobs)
 161                           (SDL_GL_SwapBuffers)))
 162                    (delay-frame))))
 163           (set! running #f)))
 164
 165   (set! game-running?
 166         (lambda ()
 167           running))
 168
 169   (set! set-game-code
 170         (lambda (game-function)
 171           (set! game-code game-function))))