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             *title*
  26             *width-screen*
  27             *height-screen*
  28             *bpp-screen*
  29             *frames-per-second*
  30             *mode*
  31             set-game-properties!
  32             get-game-properties
  33             init-gacela
  34             quit-gacela
  35             game-loop
  36             game-running?
  37             set-game-code
  38             show-mob-hash
  39             hide-mob-hash
  40             hide-all-mobs)
  41   #:export-syntax (game
  42                    show-mob
  43                    hide-mob
  44                    the-mob
  45                    define-mob
  46                    lambda-mob)
  47   #:re-export (get-current-color
  48                set-current-color
  49                with-color
  50                progn-textures
  51                draw
  52                draw-texture
  53                draw-line
  54                draw-quad
  55                draw-rectangle
  56                draw-square
  57                draw-cube
  58                translate
  59                rotate
  60                to-origin
  61                add-light
  62                set-camera
  63                camera-look
  64                render-text
  65                get-frame-time))
  66
  67
  68 ;;; Resources Cache
  69
  70 (define resources-cache (make-weak-value-hash-table))
  71
  72 (define (from-cache key)
  73   (hash-ref resources-cache key))
  74
  75 (define (into-cache key res)
  76   (hash-set! resources-cache key res))
  77
  78 (define-macro (use-cache-with module proc)
  79   (let* ((pwc (string->symbol (string-concatenate (list (symbol->string proc) "-without-cache")))))
  80     `(begin
  81        (define ,pwc (@ ,module ,proc))
  82        (define (,proc . param)
  83          (let* ((key param)
  84                 (res (from-cache key)))
  85            (cond (res
  86                   res)
  87                  (else
  88                   (set! res (apply ,pwc param))
  89                   (into-cache key res)
  90                   res)))))))
  91
  92 (use-cache-with (gacela video) load-texture)
  93 (use-cache-with (gacela video) load-font)
  94
  95
  96 ;;; Main Loop
  97
  98 (define loop-flag #f)
  99 (define game-code #f)
 100 (define game-loop-thread #f)
 101
 102 (define-macro (game . code)
 103   `(let ((game-function ,(if (null? code)
 104                              `(lambda () #f)
 105                              `(lambda () ,@code))))
 106      (set-game-code game-function)
 107      (cond ((not (game-running?))
 108             (game-loop)))))
 109
 110 (define-macro (run-in-game-loop . code)
 111   `(if game-loop-thread
 112        (system-async-mark (lambda () ,@code) game-loop-thread)
 113        (begin ,@code)))
 114
 115 (define (init-gacela)
 116   (set! game-loop-thread (call-with-new-thread (lambda () (game)))))
 117
 118 (define (quit-gacela)
 119   (set! game-loop-thread #f)
 120   (set! loop-flag #f))
 121
 122 (define (game-loop)
 123   (refresh-active-mobs)
 124   (set! loop-flag #t)
 125   (init-video *width-screen* *height-screen* *bpp-screen* #:title *title* #:mode *mode* #:fps *frames-per-second*)
 126   (while loop-flag
 127          (init-frame-time)
 128 ;           (check-connections)
 129          (process-events)
 130          (cond ((quit-signal?)
 131                 (quit-gacela))
 132                (else
 133                 (clear-screen)
 134                 (to-origin)
 135                 (refresh-active-mobs)
 136                 (if (procedure? game-code)
 137                     (catch #t
 138                            (lambda () (game-code))
 139                            (lambda (key . args) #f)))
 140                 (run-mobs)
 141                 (flip-screen)
 142                 (delay-frame))))
 143   (quit-video))
 144
 145 (define (game-running?)
 146   loop-flag)
 147
 148 (define (set-game-code game-function)
 149   (set! game-code game-function))
 150
 151
 152 ;;; Game Properties
 153
 154 (define *title* "Gacela")
 155 (define *width-screen* 640)
 156 (define *height-screen* 480)
 157 (define *bpp-screen* 32)
 158 (define *frames-per-second* 20)
 159 (define *mode* '2d)
 160
 161 (define* (set-game-properties! #:key title width height bpp fps mode)
 162   (if title
 163       (set-screen-title! title))
 164   (if bpp
 165       (run-in-game-loop (set-screen-bpp! bpp)))
 166   (if (or width height)
 167       (begin
 168         (if (not width) (set! width (get-screen-width)))
 169         (if (not height) (set! height (get-screen-height)))
 170         (run-in-game-loop (resize-screen width height))))
 171   (if fps
 172       (set-frames-per-second! fps))
 173   (if mode
 174       (if (eq? mode '3d) (set-3d-mode) (set-2d-mode))))
 175
 176 (define (get-game-properties)
 177   `((title . ,(get-screen-title)) (width . ,(get-screen-width)) (height . ,(get-screen-height)) (bpp . ,(get-screen-bpp)) (fps . ,(get-frames-per-second)) (mode . ,(if (3d-mode?) '3d '2d))))
 178
 179
 180 ;;; Mobs Factory
 181
 182 (define mobs-table (make-hash-table))
 183 (define active-mobs '())
 184 (define mobs-changed #f)
 185
 186 (define (show-mob-hash mob)
 187   (hash-set! mobs-table (mob 'get-mob-id) mob)
 188   (set! mobs-changed #t))
 189
 190 (define (hide-mob-hash mob-id)
 191   (hash-remove! mobs-table mob-id)
 192   (set! mobs-changed #t))
 193
 194 (define (refresh-active-mobs)
 195   (cond (mobs-changed
 196          (set! mobs-changed #f)
 197          (set! active-mobs (hash-map->list (lambda (k v) v) mobs-table)))))
 198
 199 (define (get-active-mobs)
 200   active-mobs)
 201
 202 (define (hide-all-mobs)
 203   (set! mobs-changed #t)
 204   (hash-clear! mobs-table))
 205
 206 (define (mobs-changed?)
 207   mobs-changed)
 208
 209
 210 (define-macro (show-mob mob)
 211   (cond ((list? mob)
 212          `(let ((m ,mob))
 213             (show-mob-hash m)))
 214         (else
 215          `(show-mob-hash (lambda* (#:optional (option #f)) (,mob option))))))
 216
 217 (define-macro (hide-mob mob)
 218   (cond ((list? mob)
 219          `(let ((m ,mob))
 220             (hide-mob-hash (m 'get-mob-id))))
 221         (else
 222          `(hide-mob-hash (,mob 'get-mob-id)))))
 223
 224 (define* (run-mobs #:optional (mobs (get-active-mobs)))
 225   (for-each
 226    (lambda (m)
 227      (glmatrix-block (m)))
 228    mobs))
 229
 230
 231 ;;; Making mobs
 232
 233 (define-macro (the-mob type attr publish . body)
 234   (let ((mob-id-symbol (gensym))
 235         (type-symbol (gensym))
 236         (time-symbol (gensym))
 237         (data-symbol (gensym)))
 238     `(let ((,mob-id-symbol (gensym))
 239            (,type-symbol ,type)
 240            (,time-symbol 0)
 241            (,data-symbol '())
 242            ,@attr)
 243        (lambda* (#:optional (option #f))
 244          (define (kill-me)
 245            (hide-mob-hash ,mob-id-symbol))
 246          (define (save-data)
 247            (let ((time (get-frame-time)))
 248              (cond ((not (= time ,time-symbol))
 249                     (set! ,time-symbol time)
 250                     (set! ,data-symbol ,(cons 'list (map (lambda (x) `(cons ',(car x) ,(car x))) publish)))))))
 251          (define (get-data)
 252            ,data-symbol)
 253          (define (filter-mobs type fun)
 254            #t)
 255          (define (map-mobs fun type)
 256            (let ((mobs (filter (lambda (m) (and (eq? (m 'get-type) type) (not (eq? (m 'get-mob-id) ,mob-id-symbol)))) (get-active-mobs))))
 257              (map (lambda (m) (fun (m 'get-data))) mobs)))
 258          (case option
 259            ((get-mob-id)
 260             ,mob-id-symbol)
 261            ((get-type)
 262             ,type-symbol)
 263            ((get-data)
 264             (save-data)
 265             ,data-symbol)
 266            (else
 267             (save-data)
 268             (catch #t
 269                    (lambda () ,@body)
 270                    (lambda (key . args) #f))))))))
 271
 272 (define-macro (define-mob mob-head . body)
 273   (let ((name (car mob-head)) (attr (cdr mob-head)))
 274     `(define ,(string->symbol (string-concatenate (list "make-" (symbol->string name))))
 275        (lambda* ,(if (null? attr) '() `(#:key ,@attr))
 276          (the-mob ',name () ,attr ,@body)))))
 277
 278 (define-macro (lambda-mob attr . body)
 279   `(the-mob 'undefined ,attr '() ,@body))
 280
 281
 282 ;;; Collisions
 283
 284 ;; (define-macro (lambda-mob-data attr . body)
 285 ;;   `(lambda ,attr ,@body))
 286
 287 ;; (define-macro (define-collision-check name mobs . body)
 288 ;;   `(defmacro* ,name (#:optional m)
 289 ;;      `(let ,(cond (m `((mob-id (,m 'get-mob-id)) (mob-type (,m 'get-type))))
 290 ;;                (else `()))
 291
 292 ;;      mob-id)))