This repository has been archived by the owner on Dec 5, 2022. It is now read-only.
-
-
Notifications
You must be signed in to change notification settings - Fork 9
/
gl-bitmap.rkt
190 lines (168 loc) · 6.24 KB
/
gl-bitmap.rkt
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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
#lang at-exp racket/base
(require racket/match
racket/string
racket/format
ffi/vector
opengl)
;; This is mostly copied from Mode-λ, but simplified
(define-syntax-rule (with-texture (GL_TEXTUREx TextureId) body ...)
(let ()
(glActiveTexture GL_TEXTUREx)
(glBindTexture GL_TEXTURE_2D TextureId)
body ...
(glActiveTexture GL_TEXTUREx)
(glBindTexture GL_TEXTURE_2D 0)))
;; Copied from opengl (and sgl)
(define (argb->rgba! pixels)
(for ((i (in-range (/ (bytes-length pixels) 4))))
(let* ((offset (* 4 i))
(alpha (bytes-ref pixels (+ 0 offset)))
( red (bytes-ref pixels (+ 1 offset)))
(green (bytes-ref pixels (+ 2 offset)))
( blue (bytes-ref pixels (+ 3 offset))))
(bytes-set! pixels (+ 0 offset) red)
(bytes-set! pixels (+ 1 offset) green)
(bytes-set! pixels (+ 2 offset) blue)
(bytes-set! pixels (+ 3 offset) alpha))))
;; These helpers are very busy for getting good errors when the
;; shaders break. It is very unlikely these shaders will ever break.
(define (print-shader-log glGetShaderInfoLog shader-name shader-id shader-source)
(define-values (infoLen infoLog)
(glGetShaderInfoLog shader-id 1024))
(unless (zero? infoLen)
(eprintf "Log of shader(~a):\n" shader-name)
(define real-log (bytes->string/utf-8 (subbytes infoLog 0 infoLen)))
(define shader-lines (string-split shader-source "\n"))
(for ([l (in-list (string-split real-log "\n"))])
(eprintf "\t~a\n" l)
(match (regexp-match #rx"^0\\(([0-9]*?)\\) : " l)
[(list _ ns)
(eprintf "\t\t=> ~a\n"
(list-ref shader-lines (sub1 (string->number ns))))]
[_
(void)]))
(eprintf "Shader source follows:\n~a\n"
shader-source)))
(define (compile-shader GL_VERTEX_SHADER ProgramId VertexShader)
(define VertexShaderId (glCreateShader GL_VERTEX_SHADER))
(glShaderSource VertexShaderId 1
(vector
(format "#version ~a\n~a"
;; XXX This is likely to be a problem in
;; Wayland (which I think mandates ES? But
;; I don't know what version.)
(match '3.3
['3.3 "330 core"]
['es3.1 "310 es"])
VertexShader))
(s32vector))
(glCompileShader VertexShaderId)
(unless (= GL_TRUE (glGetShaderiv VertexShaderId GL_COMPILE_STATUS))
(print-shader-log glGetShaderInfoLog ProgramId VertexShaderId VertexShader)
(error 'compile-shader "failed to compile ~a shader ~v"
(if (= GL_FRAGMENT_SHADER GL_VERTEX_SHADER)
"fragment"
"vertex")
ProgramId))
(glAttachShader ProgramId VertexShaderId))
(define (glLinkProgram&check ProgramId ProgramName)
(glLinkProgram ProgramId)
(unless (= GL_TRUE (glGetProgramiv ProgramId GL_LINK_STATUS))
(print-shader-log glGetProgramInfoLog ProgramId ProgramId "[inside linking]")
(error 'glLinkProgram&check "failed to link program ~v" ProgramId))
(glValidateProgram ProgramId)
(unless (= GL_TRUE (glGetProgramiv ProgramId GL_VALIDATE_STATUS))
(print-shader-log glGetProgramInfoLog ProgramId ProgramId "[during validation]")
(error 'glLinkProgram&check "failed to validate program ~v" ProgramName)))
(define (make-draw bm-w bm-h bm-bs)
(define (glGen glGenThing)
(u32vector-ref (glGenThing 1) 0))
(define bm-tex (glGen glGenTextures))
(with-texture (GL_TEXTURE0 bm-tex)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE)
(argb->rgba! bm-bs)
(glTexImage2D GL_TEXTURE_2D
0 GL_RGBA
bm-w bm-h 0
GL_RGBA GL_UNSIGNED_BYTE
bm-bs))
(define bm-program (glCreateProgram))
(define bm-vert
@~a{
out vec2 texCoord;
const vec2 full_coordData[4] =
vec2[4]( vec2(0.0, 1.0),
vec2(0.0, 0.0),
vec2(1.0, 1.0),
vec2(1.0, 0.0) );
const vec2 center_coordData[4] =
vec2[4]( vec2(-1.0, +1.0),
vec2(-1.0, -1.0),
vec2(+1.0, +1.0),
vec2(+1.0, -1.0) );
void main() {
gl_Position = vec4( center_coordData[ gl_VertexID ].xy, 0.0, 1.0 );
texCoord = full_coordData[ gl_VertexID ];
}})
(define bm-fragment
@~a{
uniform sampler2D BitmapTex;
in vec2 texCoord;
out vec4 oFragColor;
void main() {
oFragColor = texture(BitmapTex, texCoord);
}})
(compile-shader GL_VERTEX_SHADER bm-program bm-vert)
(compile-shader GL_FRAGMENT_SHADER bm-program bm-fragment)
(define bm-vao (glGen glGenVertexArrays))
(glBindVertexArray bm-vao)
(glLinkProgram&check bm-program 'bm)
(glUseProgram bm-program)
(glUniform1i (glGetUniformLocation bm-program "BitmapTex") 0)
(glUseProgram 0)
(glBindVertexArray 0)
(λ (c-w c-h)
(glUseProgram bm-program)
(with-texture (GL_TEXTURE0 bm-tex)
(glBindVertexArray bm-vao)
(glClearColor 0.0 0.0 0.0 0.0)
(glClear GL_COLOR_BUFFER_BIT)
(glDrawArrays GL_TRIANGLE_STRIP 0 4))
(glBindVertexArray 0)
(glUseProgram 0)))
(module+ main
(require racket/gui
racket/class
racket/draw
framework)
(define bm (icon:get-gc-on-bitmap))
(define W (send bm get-width))
(define H (send bm get-height))
(define bs (make-bytes (* 4 W H)))
(send bm get-argb-pixels 0 0 W H bs)
(define draw #f)
(define (paint-canvas c dc)
(define-values (cw ch) (send c get-scaled-client-size))
(define gl-ctx (send dc get-gl-context))
(send gl-ctx
call-as-current
(λ ()
(unless draw
(set! draw (make-draw W H bs)))
(draw cw ch)
(send gl-ctx swap-buffers))))
(define gl-conf (new gl-config%))
(send gl-conf set-legacy? #f)
(define f (new frame% [label "GL Bitmap"] [width W] [height H]))
(define c
(new canvas%
[parent f]
[min-width W]
[min-height H]
[gl-config gl-conf]
[style '(no-autoclear gl)]
[paint-callback paint-canvas]))
(send f show #t))