]> git.jsancho.org Git - gacela.git/blob - gacela.lisp
(no commit message)
[gacela.git] / gacela.lisp
1 ;;; Gacela, a GNU Common Lisp 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 (in-package :gacela)
19
20 ;;; Default values for Gacela
21 (defvar *width-screen* 640)
22 (defvar *height-screen* 480)
23 (defvar *bpp-screen* 32)
24 (defvar *title-screen* "Happy Hacking!!")
25 (defvar *frames-per-second* 20)
26 (defvar *transparent-color* '(:red 0 :green 0 :blue 0))
27 (defvar *background-color* '(:red 0 :green 0 :blue 0))
28
29 ;;; SDL Initialization Subsystem
30 (let (initialized)
31
32   (defun init-sdl ()
33     (cond ((null initialized) (setq initialized (SDL_Init SDL_INIT_EVERYTHING)))
34           (t initialized)))
35
36   (defun quit-sdl ()
37     (setq initialized (SDL_Quit))))
38
39
40 ;;; Video Subsystem
41 (defstruct surface address clip-w clip-h shape)
42
43 (let (screen flags)
44
45   (defun init-video-mode (&key (width *width-screen*) (height *height-screen*) (bpp *bpp-screen*))
46     (cond ((null screen)
47            (init-sdl)
48            (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
49            (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
50                           (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
51                           (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL)))
52            (setq screen (SDL_SetVideoMode width height bpp flags))
53            (init-GL)
54            (resize-screen-GL width height))
55           (t t)))
56
57   (defun resize-screen (width height bpp)
58     (setq screen (SDL_SetVideoMode width height bpp flags))
59     (resize-screen-GL width height))
60
61   (defun fill-screen (color)
62     (init-video-mode)
63     (fill-surface screen (getf color :red) (getf color :green) (getf color :blue)))
64
65   (defun flip ()
66     (cond ((null screen) nil)
67           (t (SDL_Flip screen))))
68
69   (defun create-surface (width height &key (trans-color *transparent-color*))
70     (init-video-mode)
71     (let ((new-surface (make-surface
72                         :address (create-SDL_Surface
73                                   (surface-address screen)
74                                   width
75                                   height
76                                   (getf trans-color :red)
77                                   (getf trans-color :green)
78                                   (getf trans-color :blue)))))
79       (set-resource 'image new-surface (gentemp))
80       new-surface))
81
82   (defun print-surface (x y surface)
83     (apply-surface x y surface screen)
84     surface)
85
86   (defun quit-video-mode ()
87     (setq screen nil)))
88
89
90 (defun init-GL ()
91   (2d-mode)
92   (glShadeModel GL_SMOOTH)
93   (glClearColor 0 0 0 0)
94   (glClearDepth 1)
95   (glDepthFunc GL_LEQUAL)
96 ;  (glEnable GL_BLEND)
97 ;  (glBlendFunc GL_SRC_ALPHA GL_ONE)
98   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
99   t)
100
101 (defun init-textures ()
102   (init-video-mode)
103   (glEnable GL_TEXTURE_2D))
104
105 (defun init-lighting ()
106   (init-video-mode)
107   (glEnable GL_LIGHTING))
108
109 (defun resize-screen-GL (width height)
110   (let ((ratio (if (= height 0) width (/ width height))))
111 ;    (glViewPort 0 0 width height)
112     (glMatrixMode GL_PROJECTION)
113     (glLoadIdentity)
114     (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h)))
115       (glOrtho -w w -h h 0 1))
116 ;    (gluPerspective 45 ratio 0.1 100)
117     (glMatrixMode GL_MODELVIEW)
118     (glLoadIdentity)
119     t))
120
121 (defun copy-surface (source)
122   (cond ((surface-p source)
123          (let ((new-surface
124                 (make-surface :address (copy-SDL_Surface (surface-address source))
125                               :clip-w (surface-clip-w source)
126                               :clip-h (surface-clip-h source)
127                               :shape (surface-shape source))))
128            (set-resource 'image new-surface (gentemp))
129            new-surface))))
130
131 (defun load-image (image-file &key (transparent-color nil))
132   (init-video-mode)
133   (let ((loaded-image (IMG_Load image-file)))
134     (cond ((= loaded-image 0) nil)
135           (t (let ((optimized-image (SDL_DisplayFormat loaded-image)))
136                (SDL_FreeSurface loaded-image)
137                (cond ((= optimized-image 0) nil)
138                      ((null transparent-color) optimized-image)
139                      (t (SDL_SetColorKey optimized-image
140                                          SDL_SRCCOLORKEY
141                                          (SDL_MapRGB (surface-format optimized-image)
142                                                      (car transparent-color)
143                                                      (cadr transparent-color)
144                                                      (caddr transparent-color)))
145                         optimized-image)))))))
146
147 (defun load-image2 (image-file &key (transparent-color nil))
148   (let ((address-image (load-image image-file :transparent-color transparent-color)))
149     (list
150      (lambda (x y) (print-surface x y address-image))
151      (lambda () (SDL_FreeSurface address-image)))))
152
153 (defun apply-surface (x y source destination)
154   (let ((offset (SDL_Rect x y 0 0)))
155     (SDL_BlitSurface source 0 destination offset)
156     (free offset)
157     destination))
158
159 (defun apply-surface-old (x y source destination &optional (clip nil))
160   (cond ((null clip)
161          (apply-surface2 x y (surface-address source) (surface-address destination) 0 0 0 0 0))
162         ((integerp clip)
163          (apply-surface2 x y (surface-address source) (surface-address destination) 0 0
164                          (surface-clip-w source) (surface-clip-h source) clip))
165         (t
166          (apply-surface2 x y (surface-address source) (surface-address destination)
167                          (first clip) (second clip) (third clip) (fourth clip) 0)))
168   destination)
169
170
171 (defun print-image (x y image-file &optional (clip nil))
172   (init-video-mode)
173   (let ((image (load-image image-file)))
174     (print-surface x y image clip)
175     image))
176
177
178 (defun clean-screen ()
179   (fill-screen *background-color*))
180
181 (defun refresh-screen ()
182   (clean-screen)
183   (funcall-procs #'print-mob)
184   (flip))
185
186
187 (defun filled-circle (radius &optional (color '(:red 255 :green 255 :blue 255)))
188   (init-video-mode)
189   (let ((new-surface (create-surface (1+ (* radius 2)) (1+ (* radius 2)))))
190     (sge_FilledCircle (surface-address new-surface)
191                       radius radius radius
192                       (getf color :red)
193                       (getf color :green)
194                       (getf color :blue))
195     (setf (surface-shape new-surface)
196           `((,radius ,radius) ,radius))
197     new-surface))
198
199
200 (defun filled-rect (width height &optional (color '(:red 255 :green 255 :blue 255)))
201   (init-video-mode)
202   (let ((new-surface (create-surface width height)))
203     (sge_FilledRect (surface-address new-surface)
204                     0 0 width height
205                     (getf color :red)
206                     (getf color :green)
207                     (getf color :blue))
208     (setf (surface-shape new-surface)
209           (make-rectangle 0 0 width height))
210     new-surface))
211
212
213 ;;; TTF Subsystem
214 (defstruct font address)
215
216 (let ((ttf nil))
217
218   (defun init-ttf ()
219     (cond ((null ttf) (progn (init-sdl) (setq ttf (TTF_Init))))
220           (t ttf)))
221
222   (defun quit-ttf ()
223     (setq ttf (TTF_Quit))))
224
225
226 (defun open-font (font-name tam)
227   (init-ttf)
228   (let ((font (get-resource 'font font-name tam)))
229     (if (null font)
230         (progn (setq font (make-font :address (TTF_OpenFont font-name tam)))
231                (set-resource 'font font font-name tam)))
232     font))
233
234
235 (defun render-text (text-message
236                     &key (color '(:red 255 :green 255 :blue 255))
237                     (font-name "lazy.ttf") (tam 28))
238   (init-ttf)
239   (let ((message (get-resource 'text text-message color font-name tam)))
240     (if (null message)
241         (progn
242           (setq message
243                 (make-surface
244                  :address (render-text2 (open-font font-name tam)
245                                         text-message
246                                         (getf color :red)
247                                         (getf color :green)
248                                         (getf color :blue))))
249           (set-resource 'text message text-message color font-name tam)))
250     message))
251
252
253 (defun print-text (x y text-message
254                      &key (color '(:red 255 :green 255 :blue 255))
255                      (font-name "lazy.ttf") (tam 28))
256   (init-video-mode)
257   (init-ttf)
258   (let ((message (render-text text-message :color color :font-name font-name :tam tam)))
259     (print-surface x y message)
260     message))
261
262
263 ;;; Audio Subsystem
264 (let ((audio nil))
265
266   (defun init-audio ()
267     (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 2 4096))))
268           (t audio)))
269
270   (defun quit-audio ()
271     (setq audio (Mix_CloseAudio))))
272
273
274 ;;; Resources Manager
275 (defstruct resource address free-function object)
276
277 (let ((resources-table (make-hash-table :test 'equal)))
278
279   (defun set-resource (type object &rest key)
280     (let ((res
281            (cond ((surface-p object)
282                   (make-resource :address (surface-address object)
283                                  :free-function #'SDL_FreeSurface
284                                  :object object))
285                  ((font-p object)
286                   (make-resource :address (font-address object)
287                                  :free-function #'TTF_CloseFont
288                                  :object object))
289                  ((cp-space-p object)
290                   (make-resource :address (cp-space-address object)
291                                  :free-function #'cpSpaceFree
292                                  :object object))
293                  ((cp-body-p object)
294                   (make-resource :address (cp-body-address object)
295                                  :free-function #'cpBodyFree
296                                  :object object))
297                  ((cp-shape-p object)
298                   (make-resource :address (cp-shape-address object)
299                                  :free-function #'cpShapeFree
300                                  :object object))
301                  (t nil))))
302       (cond (res (setf (gethash `(,type ,@key) resources-table) res)))))
303
304   (defun get-resource (type &rest key)
305     (let ((resource (gethash `(,type ,@key) resources-table)))
306       (cond ((null resource) nil)
307             (t (resource-object resource)))))
308
309   (defun free-all-resources ()
310     (maphash (lambda (key res) (funcall (resource-free-function res) (resource-address res)))
311              resources-table)
312     (clrhash resources-table)))
313
314
315 ;;; Connection with the GUI
316 (let (socket)
317   (defun connect-to-gui ()
318     (setq socket (si::socket 1984 :host "localhost")))
319
320   (defun eval-from-gui ()
321     (cond ((and socket (listen socket)) (eval (read socket))))))
322
323
324 ;;; GaCeLa Functions
325 ;(defun game-loop (code)
326 ;  (process-events)
327 ;  (cond ((quit?) nil)
328 ;       (t
329 ;        (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
330 ;        (glLoadIdentity)
331 ;        (translate 0 0 *zoom*)
332 ;        (funcall code)
333 ;        (SDL_GL_SwapBuffers)
334 ;        (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*)))
335 ;        (game-loop code))))
336
337 (let (commands)
338   (defun prog-command (command)
339     (setq commands (cons command commands)))
340
341   (defun run-commands ()
342     (cond (commands
343            (let (running)
344              (setq running commands)
345              (setq commands nil)
346              (labels ((run-com (comlst)
347                                (cond (comlst (run-com (cdr comlst))
348                                              (eval (read-from-string (concatenate 'string "(progn " (car comlst) ")")))))))
349                      (run-com running)))))))
350
351 (let ((gacela-timer (make-timer)))
352   (defun start-gacela-timer () (start-timer gacela-timer))
353   (defun get-gacela-time () (get-time gacela-timer)))
354
355 (defmacro run-game (title &body code)
356   `(progn
357      (init-video-mode)
358      (SDL_WM_SetCaption ,title "")
359      (process-events)
360      (do () ((quit?))
361          (start-gacela-timer)
362          (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
363          (glLoadIdentity)
364          ,@code
365          (SDL_GL_SwapBuffers)
366          (let ((frame-time (get-gacela-time)) (time-per-frame (/ 1000.0 *frames-per-second*)))
367            (cond ((< frame-time time-per-frame)
368                   (SDL_Delay (- time-per-frame frame-time)))))
369          (process-events)
370          (setq running nil))))
371
372 ;(defun run-game ()
373 ;  (init-video-mode)
374 ;  (SDL_WM_SetCaption *title-screen* "")
375 ;  (refresh-active-procs)
376 ;  (enjoy!)
377 ;  (do () ((quit?))
378 ;      (process-events)
379 ;      (logic-procs)
380 ;      (motion-procs)
381 ;      (refresh-active-procs)
382 ;      (refresh-screen)
383 ;      (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*)))))
384
385 (defun quit-game ()
386 ;  (free-all-resources)
387 ;  (quit-audio)
388 ;  (quit-ttf)
389   (quit-video-mode)
390 ;  (quit-all-procs)
391 ;  (clear-events)
392 ;  (quit-events)
393   (quit-sdl))