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