public
Created

  • Download Gist
opengl-texture.rkt
Racket
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
#lang racket
(require sgl
sgl/gl
sgl/gl-vectors
slideshow
racket/gui)
 
; make a texture!
(define *size* 128)
(define b (instantiate bitmap% (*size* *size*)))
(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)
(draw-pict (cc-superimpose (blank *size*)
(standard-fish *size* (/ *size* 2)))
b-dc 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 (gl-init)
(displayln "INIT")
(set! *init?* #t)
(gl-enable 'depth-test)
; (gl-enable 'blend)
(gl-depth-func 'lequal)
(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)))
(gl-enable 'light1)
(gl-enable 'lighting)
(set! *texture* (bitmap->gl-tex b)))
 
; fix the viewport when it's been resized
(define (gl-resize width height)
(unless *init?* (gl-init))
(gl-viewport 0 0 width height)
(gl-matrix-mode 'projection)
(gl-load-identity)
(let ([h (/ height width)])
(gl-frustum -1 1 (- h) h 5.0 60.0))
(gl-matrix-mode 'modelview)
(gl-load-identity))
 
; draw the screen!
(define (gl-draw)
(gl-clear 'color-buffer-bit 'depth-buffer-bit)
(gl-clear-depth 1)
; (gl-blend-func 'one-minus-src-alpha 'src-alpha)
(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)
(gl-begin '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)))
 
(run)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.