blob: 4ae4bc9e6afd6091f9ae418b0e7d70cae020e94b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
(define-module (catbird region)
#:use-module (catbird camera)
#:use-module (catbird config)
#:use-module (catbird mixins)
#:use-module (catbird node)
#:use-module (catbird scene)
#:use-module (chickadee)
#:use-module (chickadee data array-list)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics viewport)
#:use-module (chickadee math rect)
#:use-module (ice-9 exceptions)
#:use-module (oop goops)
#:export (<region>
make-region
area
area-x
area-y
area-width
area-height
camera
scene
replace-scene
push-scene
pop-scene)
#:re-export (name
rank
render
update))
(define-root-class <region> (<renderable> <updatable> <nameable> <rankable>)
(area #:accessor area #:init-keyword #:area)
(camera #:accessor camera #:init-keyword #:camera #:init-value #f)
(scene #:accessor scene #:init-keyword #:scene #:init-value #f)
(scene-stack #:getter scene-stack #:init-thunk make-array-list)
(viewport #:accessor viewport))
(define-method (area-x (region <region>))
(rect-x (area region)))
(define-method (area-y (region <region>))
(rect-y (area region)))
(define-method (area-width (region <region>))
(rect-width (area region)))
(define-method (area-height (region <region>))
(rect-height (area region)))
(define (float->int x)
(inexact->exact (round x)))
(define-method (initialize (region <region>) args)
(next-method)
(let ((r (area region)))
(set! (viewport region)
(make-viewport (float->int (rect-x r))
(float->int (rect-y r))
(float->int (rect-width r))
(float->int (rect-height r))))))
(define (make-region area name rank)
(let* ((window (current-window))
(w (window-width window))
(h (window-height window)))
(when (or (< (rect-left area) 0.0)
(< (rect-bottom area) 0.0)
(> (rect-right area) w)
(> (rect-top area) h))
(raise-exception
(make-exception-with-message "region area exceeds window area")))
(make <region> #:area area #:name name #:rank rank)))
(define-method (replace-scene (r <region>) (new-scene <scene>))
(let ((old-scene (scene r)))
(when old-scene (on-exit old-scene))
(set! (scene r) new-scene)
(set! (regions new-scene) (cons r (regions new-scene)))
(on-enter new-scene)))
(define-method (push-scene (region <region>) (new-scene <scene>))
(let ((old-scene (scene region)))
(when old-scene
(array-list-push! (scene-stack region) old-scene))
(replace-scene region new-scene)))
(define-method (pop-scene (region <region>))
(let ((stack (scene-stack region)))
(unless (array-list-empty? stack)
(replace-scene (array-list-pop! stack)))))
(define-method (update (region <region>) dt)
(let ((s (scene region)))
(when s (update/around s dt))))
(define-method (render (region <region>) alpha)
(let ((s (scene region))
(c (camera region)))
(when (and s c)
(parameterize ((current-camera c))
(with-projection (projection-matrix (camera region))
(render/around s alpha))))))
|
