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