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