-
Notifications
You must be signed in to change notification settings - Fork 0
/
test3.rkt
181 lines (158 loc) · 5.84 KB
/
test3.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
#lang racket
(require sgl
sgl/gl
sgl/gl-vectors
sgl/bitmap
slideshow
racket/gui)
; make a texture!
(define bm (read-bitmap "model1.jpeg"))
(define b (instantiate bitmap% ((send bm get-width) (send bm get-height))))
(define b-dc (new bitmap-dc% [bitmap b]))
(send b-dc set-background (make-object color% "black"))
(send b-dc clear)
(send b-dc set-smoothing 'aligned)
;(send b-dc set-bitmap bm)
(send b-dc draw-bitmap bm 0 0)
#|
(define b-mask (instantiate bitmap% (*size* *size* #t)))
(define b-mask-dc (new bitmap-dc% [bitmap b-mask]))
(send b-mask-dc set-background (instantiate color% ("black")))
(send b-mask-dc clear)
(draw-pict (cc-superimpose (blank *size*) (standard-fish *size* (/ *size* 2) #:color "white")) b-mask-dc 0 0)
(send b set-loaded-mask b-mask)|#
; converts a racket/gui bitmap% into an array of ARGB bytes.
(define (bitmap->argb-bytes bm)
(let* ([width (send bm get-width)]
[height (send bm get-height)]
[mask (send bm get-loaded-mask)]
[buffer (make-bytes (* width height 4) 255)])
(send bm get-argb-pixels 0 0 width height buffer #f)
(when mask
(send bm get-argb-pixels 0 0 width height buffer #t))
buffer))
; converts an array of ARGB bytes into an OpenGL vector.
(define (argb-bytes->gl-rgba-vector argb-bytes)
(let* ([length (bytes-length argb-bytes)]
[gl-buf (make-gl-ubyte-vector length)])
(let loop ([i 0])
(when (< i length)
(gl-vector-set! gl-buf (+ i 0) (bytes-ref argb-bytes (+ i 1)))
(gl-vector-set! gl-buf (+ i 1) (bytes-ref argb-bytes (+ i 2)))
(gl-vector-set! gl-buf (+ i 2) (bytes-ref argb-bytes (+ i 3)))
(gl-vector-set! gl-buf (+ i 3) (bytes-ref argb-bytes (+ i 0)))
(loop (+ i 4))))
gl-buf))
; convert a bitmap straight to an OpenGL texture.
(define (bitmap->gl-tex bm)
(gl-enable 'texture-2d)
(let ([width (send bm get-width)]
[height (send bm get-height)]
[gl-tex (gl-vector-ref (glGenTextures 1) 0)]
[gl-tex-bytes (argb-bytes->gl-rgba-vector (bitmap->argb-bytes bm))])
(glBindTexture GL_TEXTURE_2D gl-tex)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
(gluBuild2DMipmaps GL_TEXTURE_2D GL_RGBA width height GL_RGBA GL_UNSIGNED_BYTE gl-tex-bytes)
gl-tex))
(define *texture* #f)
(define *init?* #f)
(define *pic* (glGenLists 1))
(define (gl-init)
(displayln "INIT")
(set! *init?* #t)
(glEnable GL_DEPTH_TEST)
(glDepthFunc GL_LEQUAL)
(glNewList *pic* GL_COMPILE)
(glEndList)
(gl-light-v 'light1 'ambient (vector->gl-float-vector #(0.5 0.5 0.5 0)))
(gl-light-v 'light1 'diffuse (vector->gl-float-vector #(1 1 1 0)))
(gl-light-v 'light1 'position (vector->gl-float-vector #(2 2 2 1)))
(glEnable GL_LIGHT1)
(glEnable GL_LIGHTING)
(set! *texture* (bitmap->gl-tex b)))
; fix the viewport when it's been resized
(define (gl-resize width height)
(unless *init?* (gl-init))
(glViewport 0 0 width height)
(glMatrixMode GL_PROJECTION)
(glLoadIdentity)
(let ([h (/ height width)])
(glFrustum -1 1 (- h) h 5.0 60.0))
(glMatrixMode GL_MODELVIEW)
(glLoadIdentity))
; draw the screen!
(define (gl-draw)
(gl-clear 'color-buffer-bit 'depth-buffer-bit)
(gl-clear-depth 1)
(gl-load-identity)
(gl-translate 0 0 -15.0)
(gl-rotate (/ (current-process-milliseconds) 30) 1 1 1)
(glBindTexture GL_TEXTURE_2D *texture*)
(gl-color 1 1 1 1)
(glBegin GL_QUADS)
(gl-normal 0 0 1)
(gl-tex-coord 0 0) (gl-vertex -1 -1 1)
(gl-tex-coord 1 0) (gl-vertex 1 -1 1)
(gl-tex-coord 1 1) (gl-vertex 1 1 1)
(gl-tex-coord 0 1) (gl-vertex -1 1 1)
(gl-normal 0 0 -1)
(gl-tex-coord 1 0) (gl-vertex -1 -1 -1)
(gl-tex-coord 1 1) (gl-vertex -1 1 -1)
(gl-tex-coord 0 1) (gl-vertex 1 1 -1)
(gl-tex-coord 0 0) (gl-vertex 1 -1 -1)
(gl-normal 0 1 0)
(gl-tex-coord 0 1) (gl-vertex -1 1 -1)
(gl-tex-coord 0 0) (gl-vertex -1 1 1)
(gl-tex-coord 1 0) (gl-vertex 1 1 1)
(gl-tex-coord 1 1) (gl-vertex 1 1 -1)
(gl-normal 0 -1 0)
(gl-tex-coord 1 1) (gl-vertex -1 -1 -1)
(gl-tex-coord 0 1) (gl-vertex 1 -1 -1)
(gl-tex-coord 0 0) (gl-vertex 1 -1 1)
(gl-tex-coord 1 0) (gl-vertex -1 -1 1)
(gl-normal 1 0 0)
(gl-tex-coord 1 0) (gl-vertex 1 -1 -1)
(gl-tex-coord 1 1) (gl-vertex 1 1 -1)
(gl-tex-coord 0 1) (gl-vertex 1 1 1)
(gl-tex-coord 0 0) (gl-vertex 1 -1 1)
(gl-normal -1 0 0)
(gl-tex-coord 0 0) (gl-vertex -1 -1 -1)
(gl-tex-coord 1 0) (gl-vertex -1 -1 1)
(gl-tex-coord 1 1) (gl-vertex -1 1 1)
(gl-tex-coord 0 1) (gl-vertex -1 1 -1)
(gl-end)
(gl-flush))
(define glcanvas%
(class canvas% (super-new)
(inherit refresh with-gl-context swap-gl-buffers get-parent)
(define/override (on-paint)
(with-gl-context
(lambda ()
(gl-draw)
(swap-gl-buffers)))
(when (send (get-parent) is-shown?)
(refresh)))
(define/override (on-size width height)
(displayln "RESIZED")
(with-gl-context
(lambda ()
(gl-resize width height)
(swap-gl-buffers)))
(refresh))
))
(define (run)
(let* ((frame (new frame% (label "OpenGL Window")))
(glcanvas (new glcanvas% (parent frame)
(min-width 640)
(min-height 480)
(style '(no-autoclear gl)))))
(unless (send (send (send glcanvas get-dc) get-gl-context) ok?)
(displayln "Error: OpenGL context failed to initialize")
(exit))
(send frame show #t)))
;bm
;b
(run)