]> git.jsancho.org Git - gacela.git/blob - src/views.scm
75f90713bd0150a1344bc2f7533c295c00437212
[gacela.git] / src / views.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 views)
19   #:use-module (gacela gacela)
20   #:use-module ((gacela video) #:renamer (symbol-prefix-proc 'video:))
21   #:use-module ((gacela gl) #:select (glPushMatrix glPopMatrix))
22   #:use-module (ice-9 optargs))
23
24
25 ;;; Views
26
27 (define view-type
28   (make-record-type "view" 
29                     '(id constructor body meshes priority)
30                     (lambda (record port)
31                       (format port "#<view: ~a meshes>"
32                               (length (view-meshes record))))))
33
34 (define (build-view constructor) ((record-constructor view-type) (gensym) constructor #f '() 0))
35 (define view? (record-predicate view-type))
36 (define view-id (record-accessor view-type 'id))
37 (define view-constructor (record-accessor view-type 'constructor))
38 (define view-body (record-accessor view-type 'body))
39 (define view-body-set! (record-modifier view-type 'body))
40 (define view-meshes (record-accessor view-type 'meshes))
41 (define view-meshes-set! (record-modifier view-type 'meshes))
42 (define view-priority (record-accessor view-type 'priority))
43
44 (define-macro (make-view body)
45   `(build-view (lambda () ,body)))
46
47 (define activated-views '())
48
49 (define (sort-views views-alist)
50   (sort views-alist
51         (lambda (v1 v2)
52           (< (view-priority (cdr v1)) (view-priority (cdr v2))))))
53
54 (define (reset-view! view)
55   (view-body-set! view ((view-constructor view)))
56   (view-meshes-set! view '())
57   (view-priority-set! view 0))
58
59 (define (activate-view view)
60   (reset-view! view)
61   (set! activated-views
62         (sort-views (assoc-set! activated-views (view-id view) view)))
63   view)
64
65 (define (view-actived? view)
66   (and (assoc (view-id view) activated-views) #t))
67
68 (define (view-priority-set! view priority)
69   ((record-modifier view-type 'priority) view priority)
70   (if (view-actived? view)
71       (set! activated-views (sort-views activated-views))))
72
73 (define current-view #f)
74
75 (define* (run-views #:optional (views activated-views))
76   (cond ((not (null? views))
77          (set! current-view (cdar views))
78          ((view-body current-view))
79          (draw-meshes (view-meshes current-view))
80          (run-views (cdr views)))))
81
82 (define (draw-meshes meshes)
83   (cond ((not (null? meshes))
84          (catch #t
85                   (lambda () (mesh-draw (cdar meshes)))
86                   (lambda (key . args) #f))
87          (draw-meshes (cdr meshes)))))
88
89
90 (define default-view (activate-view (make-view (lambda () #f))))
91
92
93 ;;; Meshes
94
95 (define mesh-type
96   (make-record-type "mesh" 
97                     '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)
98                     (lambda (record port)
99                       (format port "#<mesh: ~a" (mesh-inner-property record 'type))
100                       (for-each (lambda (x)
101                                   (cond (((@ (gacela utils) bound?) (cdr x))
102                                          (format port " ~a" x))))
103                                 (mesh-properties record))
104                       (display ">" port))))
105                       
106
107 (define mesh? (record-predicate mesh-type))
108
109 (define* (make-mesh proc #:optional type)
110   (apply
111    (record-constructor mesh-type)
112    (let ((px 0) (py 0) (pz 0)
113          (ax 0) (ay 0) (az 0)
114          (rx 0) (ry 0) (rz 0)
115          (id (gensym))
116          (properties '()))
117      (let ((inner-properties
118             (lambda ()
119               `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))
120        (list
121         (lambda ()
122           "draw"
123           (video:glmatrix-block
124            (video:rotate ax ay az)
125            (video:translate px py pz)
126            (video:rotate rx ry rz)
127            (proc properties)))
128         (lambda (x y z)
129           "translate"
130           (set! px (+ px x))
131           (set! py (+ py y))
132           (set! pz (+ pz z)))
133         (lambda (x y z)
134           "turn"
135           (set! ax (+ ax x))
136           (set! ay (+ ay y))
137           (set! az (+ az z)))
138         (lambda (x y z)
139           "rotate"
140           (set! rx (+ rx x))
141           (set! ry (+ ry y))
142           (set! rz (+ rz z)))
143         (lambda ()
144           "inner-properties"
145           (inner-properties))
146         (lambda (prop-name)
147           "inner-property"
148           (assoc-ref (inner-properties) prop-name))
149         (lambda ()
150           "properties"
151           properties)
152         (lambda (new-properties)
153           "properties-set!"
154           (set! properties new-properties))
155         (lambda (prop-name)
156           "property"
157           (assoc-ref properties prop-name))
158         (lambda (prop-name value)
159           "property-set!"
160           (set! properties (assoc-set! properties prop-name value))))))))
161
162 (define (mesh-draw mesh)
163   (((record-accessor mesh-type 'draw) mesh)))
164
165 (define (mesh-inner-properties mesh)
166   (((record-accessor mesh-type 'inner-properties) mesh)))
167
168 (define (mesh-inner-property mesh prop-name)
169   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
170
171 (define (mesh-properties mesh)
172   (((record-accessor mesh-type 'properties) mesh)))
173
174 (define (mesh-properties-set! mesh new-properties)
175   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
176
177 (define (mesh-property mesh prop-name)
178   (((record-accessor mesh-type 'property) mesh) prop-name))
179
180 (define (mesh-property-set! mesh prop-name value)
181   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
182
183 (define* (show mesh #:optional (view current-view))
184   (let ((id (mesh-inner-property mesh 'id))
185         (table (view-meshes view)))
186     (if (not (assoc-ref table id))
187         (view-meshes-set! view (assoc-set! table id mesh))))
188   mesh)
189
190 (define* (hide mesh #:optional (view current-view))
191   (let ((id (mesh-inner-property mesh 'id))
192         (table (view-meshes view)))
193     (if (assoc-ref table id)
194         (view-meshes-set! view (assoc-remove! table id))))
195   mesh)
196
197 (define* (translate mesh x y #:optional (z 0))
198   (((record-accessor mesh-type 'translate) mesh) x y z)
199   mesh)
200
201 (define (turn mesh . params)
202   (apply ((record-accessor mesh-type 'turn) mesh)
203          (if (>= (length params) 3)
204              params
205              (list 0 0 (car params))))
206   mesh)
207
208 (define (rotate mesh . params)
209   (apply ((record-accessor mesh-type 'rotate) mesh)
210          (if (>= (length params) 3)
211              params
212              (list 0 0 (car params))))
213   mesh)
214
215
216 ;;; Primitives
217
218 (defmacro* define-primitive (proc #:optional type)
219   `(lambda (. params)
220      (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))
221        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
222        m)))
223
224 (define-macro (define-primitives . symbols)
225   (cond ((null? symbols)
226          `#t)
227         (else
228          (let ((origin (caar symbols))
229                (dest (cadar symbols)))
230            `(begin
231               (define ,origin (define-primitive ,dest ',origin))
232               (define-primitives ,@(cdr symbols)))))))
233
234 (define-primitives
235   (rectangle video:draw-rectangle)
236   (square video:draw-square))
237
238
239 ;;; Adding extensions to the main loop
240 (add-extension! run-views 10)
241
242
243 (module-map (lambda (sym var)
244               (if (not (eq? sym '%module-public-interface))
245                   (module-export! (current-module) (list sym))))
246             (current-module))