153 lines
4.7 KiB
Racket
153 lines
4.7 KiB
Racket
;; By Brendan Burns, with modifications by Scott Owens
|
|
|
|
(module gl-frame lang/plt-pretty-big
|
|
(require sgl/gl
|
|
sgl/gl-vectors)
|
|
(provide set-gl-draw-fn
|
|
set-gl-init-fn
|
|
init-textures
|
|
image->gl-vector
|
|
bitmap->gl-vector
|
|
gl-load-texture
|
|
get-texture
|
|
add-key-mapping
|
|
clear-key-mappings
|
|
gl-run)
|
|
|
|
(define gl-draw void)
|
|
(define gl-init
|
|
(lambda ()
|
|
(glShadeModel GL_SMOOTH)
|
|
(glClearColor 0.0 0.0 0.0 0.5)
|
|
(glClearDepth 1)
|
|
(glEnable GL_DEPTH_TEST)
|
|
(glDepthFunc GL_LEQUAL)
|
|
(glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)))
|
|
|
|
(define (set-gl-draw-fn fn)
|
|
(set! gl-draw fn))
|
|
|
|
(define (set-gl-init-fn fn)
|
|
(set! gl-init fn))
|
|
|
|
;; A function that recorrects for a new aspect ratio when the window is resized
|
|
(define (gl-resize width height)
|
|
(glViewport 0 0 width height)
|
|
|
|
(glMatrixMode GL_PROJECTION)
|
|
(glLoadIdentity)
|
|
(gluPerspective 45 (/ width height) 0.1 100)
|
|
|
|
(glMatrixMode GL_MODELVIEW)
|
|
(glLoadIdentity))
|
|
|
|
(define (recursive-handle-key list code)
|
|
(cond
|
|
((empty? list) void)
|
|
((equal? (caar list) code) ((car (cdr (car list)))))
|
|
(else (recursive-handle-key (rest list) code))))
|
|
|
|
(define *key-mappings* '())
|
|
|
|
(define (add-key-mapping key fn)
|
|
(set! *key-mappings* (cons (list key fn) *key-mappings*)))
|
|
|
|
(define (clear-key-mappings)
|
|
(set! *key-mappings* '()))
|
|
|
|
(define (gl-handlekey key)
|
|
(recursive-handle-key *key-mappings* (send key get-key-code)))
|
|
|
|
(define glcanvas%
|
|
(class canvas%
|
|
(inherit refresh with-gl-context swap-gl-buffers)
|
|
|
|
(define/override (on-paint)
|
|
(with-gl-context
|
|
(lambda ()
|
|
(gl-draw)
|
|
(swap-gl-buffers)))
|
|
(refresh))
|
|
|
|
(define/override (on-size w h)
|
|
(with-gl-context
|
|
(lambda ()
|
|
(gl-resize w h)))
|
|
(refresh))
|
|
|
|
(define/override (on-char key)
|
|
(gl-handlekey key)
|
|
(refresh))
|
|
(super-new (style '(no-autoclear)))))
|
|
|
|
(define (gl-run)
|
|
(let* ((frame (new frame% (label "OpenGL Window")
|
|
(width 640)
|
|
(height 480)))
|
|
(glcanvas (new glcanvas% (parent frame))))
|
|
(unless (send (send (send glcanvas get-dc) get-gl-context) ok?)
|
|
(display "Error: OpenGL context failed to initialize")
|
|
(newline)
|
|
(exit))
|
|
(send frame show #t)
|
|
(send glcanvas with-gl-context gl-init)))
|
|
|
|
(define *textures* '())
|
|
|
|
(define init-textures
|
|
(lambda (count)
|
|
(set! *textures* (glGenTextures count))))
|
|
|
|
(define (bitmap->gl-vector bmp)
|
|
(let* (
|
|
(dc (instantiate bitmap-dc% (bmp)))
|
|
(pixels (* (send bmp get-width) (send bmp get-height)))
|
|
(vec (make-gl-ubyte-vector (* pixels 3)))
|
|
(data (make-bytes (* pixels 4)))
|
|
(i 0)
|
|
)
|
|
(send dc get-argb-pixels 0 0 (send bmp get-width) (send bmp get-height) data)
|
|
(letrec
|
|
([loop
|
|
(lambda ()
|
|
(if (< i pixels)
|
|
(begin
|
|
(gl-vector-set! vec (* i 3)
|
|
(bytes-ref data (+ (* i 4) 1)))
|
|
(gl-vector-set! vec (+ (* i 3) 1)
|
|
(bytes-ref data (+ (* i 4) 2)))
|
|
(gl-vector-set! vec (+ (* i 3) 2)
|
|
(bytes-ref data (+ (* i 4) 3)))
|
|
(set! i (+ i 1))
|
|
(loop))))])
|
|
(loop))
|
|
(send dc set-bitmap #f)
|
|
(list (send bmp get-width) (send bmp get-height) vec)))
|
|
|
|
(define (image->gl-vector file) (bitmap->gl-vector (make-object bitmap% file 'unknown #f)))
|
|
|
|
(define gl-load-texture
|
|
(lambda (image-vector width height min-filter mag-filter ix)
|
|
(glBindTexture GL_TEXTURE_2D (gl-vector-ref *textures* ix))
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER min-filter)
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER mag-filter)
|
|
(let* ((new-width 128)
|
|
(new-height 128)
|
|
(new-img-vec (make-gl-ubyte-vector (* new-width new-height 3))))
|
|
(gluScaleImage GL_RGB
|
|
width height GL_UNSIGNED_BYTE image-vector
|
|
new-width new-height GL_UNSIGNED_BYTE new-img-vec)
|
|
(if (or (= min-filter GL_LINEAR_MIPMAP_NEAREST)
|
|
(= mag-filter GL_LINEAR_MIPMAP_NEAREST))
|
|
(gluBuild2DMipmaps GL_TEXTURE_2D 3 new-width new-height GL_RGB GL_UNSIGNED_BYTE new-img-vec)
|
|
(glTexImage2D GL_TEXTURE_2D 0 3 new-width new-height 0 GL_RGB GL_UNSIGNED_BYTE new-img-vec))))
|
|
)
|
|
|
|
(define get-texture
|
|
(lambda (ix)
|
|
(gl-vector-ref *textures* ix)))
|
|
)
|
|
|
|
|
|
|