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