blob: f87bff2e7bbbb9198eccbdf20340ec78ba068fc5 (
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
;;; Sly
;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
;;;
;;; Sly 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.
;;;
;;; Sly 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 this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Manages OpenGL state and reduces state changes.
;;
;;; Code:
(define-module (sly render context)
#:use-module (ice-9 match)
#:use-module (ice-9 q)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-42)
#:use-module (gl)
#:use-module (gl enums)
#:use-module (gl low-level)
#:use-module (sly wrappers gl)
#:use-module (sly math transform)
#:use-module (sly render shader)
#:use-module (sly render texture)
#:use-module (sly render utils)
#:use-module (sly render mesh)
#:use-module (sly render framebuffer)
#:use-module (sly render camera)
#:export (make-render-context
render-context?
with-render-context
render-context-blend-mode set-render-context-blend-mode!
render-context-depth-test? set-render-context-depth-test?!
render-context-texture set-render-context-texture!
render-context-shader set-render-context-shader!
render-context-mesh set-render-context-mesh!
render-context-framebuffer set-render-context-framebuffer!
render-context-viewport set-render-context-viewport!
render-context-transform render-context-transform*!
render-context-transform-identity!
with-transform-excursion))
(define-record-type <gl-parameter>
(%make-gl-parameter default bind value)
gl-parameter?
(default gl-parameter-default)
(bind gl-parameter-bind)
(value gl-parameter-ref %gl-parameter-set!))
(define (make-gl-parameter default bind)
(%make-gl-parameter default bind default))
(define* (gl-parameter-set! parameter value #:optional force?)
(unless (and (not force?) (equal? (gl-parameter-ref parameter) value))
(%gl-parameter-set! parameter value)
((gl-parameter-bind parameter) value)))
(define (gl-parameter-reset! parameter)
(gl-parameter-set! parameter (gl-parameter-default parameter) #t))
(define-record-type <render-context>
(%make-render-context blend-mode depth-test? texture shader
mesh framebuffer viewport transform-stack)
render-context?
(blend-mode render-context-blend-mode)
(depth-test? render-context-depth-test?)
(texture render-context-texture)
(shader render-context-shader)
(mesh render-context-mesh)
(framebuffer render-context-framebuffer)
(viewport render-context-viewport)
(transform-stack render-context-transform-stack))
(define (make-null-transform)
(make-transform 0 0 0 0
0 0 0 0
0 0 0 0
0 0 0 0))
(define (make-transform-stack size)
(let ((stack (make-q)))
(do-ec (: i 128) (q-push! stack (make-null-transform)))
stack))
(define* (make-render-context #:optional (transform-stack-size 32))
(%make-render-context (make-gl-parameter #f apply-blend-mode)
(make-gl-parameter #t apply-depth-test)
(make-gl-parameter null-texture apply-texture)
(make-gl-parameter null-shader-program
apply-shader-program)
(make-gl-parameter null-mesh apply-mesh)
(make-gl-parameter null-framebuffer apply-framebuffer)
(make-gl-parameter null-viewport apply-viewport)
(make-transform-stack transform-stack-size)))
(define (render-context-reset! context)
(gl-parameter-reset! (render-context-blend-mode context))
(gl-parameter-reset! (render-context-depth-test? context))
(gl-parameter-reset! (render-context-texture context))
(gl-parameter-reset! (render-context-shader context))
(gl-parameter-reset! (render-context-mesh context))
(gl-parameter-reset! (render-context-framebuffer context))
(gl-parameter-reset! (render-context-viewport context))
(render-context-transform-identity! context))
(define-syntax-rule (with-render-context context body ...)
(begin (render-context-reset! context)
body ...
(render-context-reset! context)))
(define-syntax-rule (define-context-setter name accessor)
(define (name context value)
(gl-parameter-set! (accessor context) value)))
(define-context-setter set-render-context-blend-mode!
render-context-blend-mode)
(define-context-setter set-render-context-depth-test?!
render-context-depth-test?)
(define-context-setter set-render-context-texture!
render-context-texture)
(define-context-setter set-render-context-shader!
render-context-shader)
(define-context-setter set-render-context-mesh!
render-context-mesh)
(define-context-setter set-render-context-framebuffer!
render-context-framebuffer)
(define-context-setter set-render-context-viewport!
render-context-viewport)
(define (render-context-transform context)
(q-front (render-context-transform-stack context)))
(define (render-context-push-transform! context t)
(q-push! (render-context-transform-stack context) t))
(define render-context-pop-transform!
(compose q-pop! render-context-transform-stack))
(define (copy-transform! src dest)
(array-copy! (transform-matrix src) (transform-matrix dest)))
;; emacs: (put 'with-transform-excursion 'scheme-indent-function 1)
(define-syntax-rule (with-transform-excursion context body ...)
(let ((t (render-context-pop-transform! context)))
(dynamic-wind
(lambda ()
(copy-transform! t (render-context-transform context)))
(lambda () body ...)
(lambda ()
(render-context-push-transform! context t)))))
(define (render-context-transform*! context t)
(let ((dest (render-context-transform context)))
(with-transform-excursion context
(transform*! dest (render-context-transform context) t))))
(define (render-context-transform-identity! context)
(copy-transform! identity-transform (render-context-transform context)))
|
