]> git.jsancho.org Git - gacela.git/blob - src/gacela_mobs.scm
5ae3296ab0287601d48b91062623f2e5aa3930b4
[gacela.git] / src / gacela_mobs.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 ;;; Mobs Factory
19
20 (define show-mob-hash #f)
21 (define hide-mob-hash #f)
22 (define get-active-mobs #f)
23 (define mobs-changed? #f)
24
25 (let ((active-mobs (make-hash-table)) (changed #f))
26   (set! show-mob-hash
27         (lambda (key mob)
28           (hash-set! active-mobs key mob)
29           (set! changed #t)))
30
31   (set! hide-mob-hash
32         (lambda (key)
33           (hash-remove! key)
34           (set! changed #t)))
35
36   (set! get-active-mobs
37         (lambda* (#:optional (refreshed #t))
38           (set! changed (not refreshed))
39           (hash-map->list (lambda (k v) v) active-mobs)))
40
41   (set! mobs-changed?
42         (lambda () changed)))
43
44
45 (define-macro (show-mob mob)
46   `(show-mob-hash ',mob (lambda (option) (,mob option))))
47
48 (define-macro (hide-mob mob)
49   `(hide-mob-hash ',mob))
50
51 (define (process-mobs mobs)
52   (for-each (lambda (m) (m #:render)) mobs))
53
54
55 ;;; Actions and looks for mobs
56
57 (define (get-attr list name default)
58   (let ((value (assoc-ref list name)))
59     (cond (value (car value))
60           (else default))))
61
62 (define (attr-def attr)
63   (let ((name (car attr))
64         (value (cadr attr)))
65     `(,name (get-attr attributes ',name ',value))))
66
67 (define (attr-save attr)
68   (let ((name (car attr)))
69     `(set! attributes (assoc-set! attributes ',name (list ,name)))))
70
71 (define-macro (define-action action-head . code)
72   (let ((name (car action-head)) (attr (cdr action-head)))
73     `(define ,name
74        (lambda-action ,attr ,@code))))
75
76 (define-macro (lambda-action attr . code)
77   `(lambda (attributes)
78      (let ,(map attr-def attr)
79        ,@code
80        ,(cons 'begin (map attr-save attr))
81        attributes)))
82
83 (define-macro (lambda-look attr . look)
84   (define (process-look look)
85     (cond ((null? look) (values '() '()))
86           (else
87            (let ((line (car look)))
88              (receive (lines images) (process-look (cdr look))
89                       (cond ((string? line)
90                              (let ((var (gensym)))
91                                (values (cons `(draw-texture ,var) lines)
92                                        (cons `(,var (load-texture ,line)) images))))
93                             (else
94                              (values (cons line lines)
95                                      images))))))))
96
97   (receive (look-lines look-images) (process-look look)
98            `(let ,look-images
99                 (lambda (attributes)
100                   (let ,(map attr-def attr)
101                     (glPushMatrix)
102                     ,@look-lines
103                     (glPopMatrix))))))
104
105
106 ;;; Making mobs
107
108 (define-macro (define-mob mob-head . look)
109   (let ((name (car mob-head)) (attr (cdr mob-head)))
110     `(define ,name
111        (lambda-mob ,attr ,@look))))
112
113 (define-macro (lambda-mob attr . look)
114   `(let ((mob #f))
115      (set! mob
116            (let ((attr ',attr) (actions '()) (renders '()))
117              (lambda (option . params)
118                (case option
119                  ((get-attr)
120                   attr)
121                  ((set-attr)
122                   (if (not (null? params)) (set! attr (car params))))
123                  ((get-actions)
124                   actions)
125                  ((set-actions)
126                   (if (not (null? params)) (set! actions (car params))))
127                  ((get-renders)
128                   renders)
129                  ((set-renders)
130                   (if (not (null? params)) (set! renders (car params))))
131                  ((render)
132                   (for-each (lambda (render) ((cdr render) attr)) renders))))))
133      (cond ((not (null? ',look))
134             (mob 'set-renders
135                  (list (cons
136                         'default-look
137                         (lambda-look ,attr ,@look))))))
138      mob))