blob: f1cc3065663e136739006579b2a7cc15df18890f (
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Catbird is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Catbird is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Catbird. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Rectangular sub-regions of the game window to which a scene can be
;; rendered.
;;
;;; Code:
(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 (width (region <region>))
(area-width region))
(define-method (area-height (region <region>))
(rect-height (area region)))
(define-method (height (region <region>))
(area-height 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))))))
|
