-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathglls-render.scm
144 lines (133 loc) · 6.77 KB
/
glls-render.scm
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
(module glls-render (c-prefix
define-pipeline
export-pipeline)
(import chicken scheme)
(use (prefix glls glls:) glls-renderable (prefix gl-utils gl:))
(import-for-syntax (prefix glls glls:) (prefix glls-compiler glls:)
glls-renderable matchable miscmacros data-structures)
(reexport (except glls define-pipeline)
(only glls-renderable
renderable-size
unique-textures?
set-renderable-vao!
set-renderable-n-elements!
set-renderable-element-type!
set-renderable-mode!
set-renderable-offset!))
(begin-for-syntax
(require-library glls-renderable)
(define c-prefix (make-parameter '||))
(define header-included? (make-parameter #f)))
(define c-prefix (make-parameter '||)) ; Needs to be defined twice so it can be manipulated upon export (for some reason)
(define-syntax renderable-setters
(ir-macro-transformer
(lambda (exp i compare)
(match exp
((_ name uniforms)
(let ((base-name (symbol-append 'set- name '-renderable-)))
`(begin
,@(let loop ((uniforms uniforms) (i 0))
(if (null? uniforms)
'()
(cons `(define (,(symbol-append base-name (caar uniforms) '!)
renderable value)
(set-renderable-uniform-value! renderable ,i value
',(caar uniforms)))
(loop (cdr uniforms) (add1 i))))))))
(exp (syntax-error 'renderable-setters "Bad arguments" exp))))))
(define-for-syntax (get-uniforms s)
(cond
((and (list? s)
(list? (car s))
(member (caar s) glls:shader-types))
(get-keyword uniform: (cdar s) (lambda () '())))
((and (list? s) (>= (length s) 2) (member #:uniform s))
(cdr (member #:uniform s)))
(else (syntax-error 'define-pipeline "Only shaders that include uniform definitions may be used with glls-render" s))))
(define-syntax define-renderable-functions
(ir-macro-transformer
(lambda (exp i compare)
(match exp
((_ name . shaders)
(let* ((name (strip-syntax name))
(uniforms (delete-duplicates
(concatenate (map get-uniforms (strip-syntax shaders)))
(lambda (a b) (eq? (car a) (car b))))))
(let-values (((render-funs render-fun-name
render-arrays-fun-name
fast-fun-begin-name
fast-fun-name fast-fun-end-name
fast-fun-arrays-name)
(if (feature? compiling:)
(render-functions (c-prefix) name uniforms)
(values #f #f #f #f #f #f #f))))
`(begin
,(if (feature? compiling:)
`(begin
,(if (not (header-included?))
(begin
(header-included? #t)
`(begin
(import foreign)
(foreign-declare ,gllsRender.h)))
#f)
(foreign-declare ,render-funs)
(define ,(symbol-append 'render- name)
(foreign-lambda void ,render-fun-name c-pointer))
(define ,(symbol-append 'render-arrays- name)
(foreign-lambda void ,render-arrays-fun-name c-pointer))
(define (,(symbol-append name '-fast-render-functions))
(values
(foreign-lambda void ,(symbol->string fast-fun-begin-name)
c-pointer)
(foreign-lambda void ,(symbol->string fast-fun-name)
c-pointer)
(foreign-lambda void ,(symbol->string fast-fun-end-name))
(foreign-lambda void ,(symbol->string fast-fun-arrays-name)
c-pointer)
(foreign-value ,(string-append
"&" (symbol->string fast-fun-begin-name))
c-pointer)
(foreign-value ,(string-append
"&" (symbol->string fast-fun-name))
c-pointer)
(foreign-value ,(string-append
"&" (symbol->string fast-fun-end-name))
c-pointer)
(foreign-value ,(string-append
"&" (symbol->string fast-fun-arrays-name))
c-pointer))))
`(begin
(define (,(symbol-append 'render- name) renderable)
(render-renderable ',uniforms renderable #f))
(define (,(symbol-append 'render-arrays- name) renderable)
(render-renderable ',uniforms renderable #t))))
(define (,(symbol-append 'make- name '-renderable) . args)
(apply make-renderable ,name args))
(renderable-setters ,name ,uniforms)))))
(expr (syntax-error 'define-pipeline "Invalid pipeline definition" expr))))))
(define-syntax define-pipeline
(syntax-rules ()
((_ name shaders ...)
(begin (glls:define-pipeline name shaders ...)
(define-renderable-functions name shaders ...)))
((_ . expr) (syntax-error 'define-pipeline "Invalide pipeline definition" expr))))
(define-syntax export-pipeline
(ir-macro-transformer
(lambda (expr i c)
(cons 'export
(flatten
(let loop ((pipelines (cdr expr)))
(if (null? pipelines)
'()
(if (not (symbol? (car pipelines)))
(syntax-error 'export-shader "Expected a pipeline name" expr)
(cons (let* ((name (strip-syntax (car pipelines)))
(render (symbol-append 'render- name))
(make-renderable (symbol-append 'make- name
'-renderable))
(fast-funs (symbol-append name
'-fast-render-functions)))
(list name render make-renderable fast-funs))
(loop (cdr pipelines)))))))))))
) ; glls-render