Playing with OpenGL in Racket

2d.rkt

#lang send-exp racket/gui

(require sgl/gl)
(require sgl/gl-vectors)
(require pict)

(define texture%
  (class object%
    (init [(initial-bitmap bitmap)])
    (field [width 0]
           [height 0]
           [textures #f])

    (define {get-width self} width)
    (define {get-height self} height)

    (define {bind-texture self}
      (when (not textures) (error 'bind-texture "Attempt to use disposed texture%"))
      (glBindTexture GL_TEXTURE_2D (gl-vector-ref textures 0)))

    (define {load-from-bitmap! self bitmap}
      (when textures {dispose self})
      (set! textures (glGenTextures 1))
      {bind-texture self}
      (define image-data
        (let ()
          (set! width {get-width bitmap})
          (set! height {get-height bitmap})
          (define dc (new bitmap-dc% [bitmap bitmap]))
          (define pixels (* width height))
          (define vec (make-gl-ubyte-vector (* pixels 4)))
          (define data (make-bytes (* pixels 4)))
          {get-argb-pixels dc 0 0 width height data #f #t}
          (for ((i (in-range pixels)))
            (for ((j (in-range 4)))
              (gl-vector-set! vec (+ (* i 4) j) (bytes-ref data (+ (* i 4) (- 3 j))))))
          vec))
      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
      (glTexImage2D GL_TEXTURE_2D 0 4 width height 0 GL_BGRA GL_UNSIGNED_BYTE image-data))

    (define {dispose self}
      (when textures
        (glDeleteTextures textures)
        (set! textures #f)))

    (super-new)
    (load-from-bitmap! initial-bitmap)))

(define sim-time
  (let ((start-time (current-inexact-milliseconds)))
    (lambda ()
      (- (current-inexact-milliseconds) start-time))))

(define glcanvas%
  (class canvas%
    (inherit refresh with-gl-context swap-gl-buffers)

    (define *texture*
      (delay
        (new texture%
             [bitmap
              (pict->bitmap (cc-superimpose (colorize (disk 100) "white")
                                            (text "yo" 'default 72)))])))

    (define init? #f)

    (define-values (bg-r bg-g bg-b) (values 0.9 0.9 0.9))
    (define near-depth 10) ;; 2.5D
    (define far-depth 15) ;; 2.5D

    (define (lerp a b v) (+ (* v a) (* (- 1 v) b)))

    (define/override (on-paint)
      (with-gl-context
        (lambda ()
          (unless init?
            (glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA)
            ;; (glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_ALPHA)
            (glEnable GL_BLEND)

            ;; Standard Init
            (glEnable GL_TEXTURE_2D)

            (set! init? #t))

          (let ((bg-cycle-divisor (/ 1000.0 1)))
            (glClearColor (lerp bg-r 0 (sin (+ 0 (/ (sim-time) bg-cycle-divisor))))
                          (lerp bg-g 0 (sin (+ (* pi 2/3) (/ (sim-time) bg-cycle-divisor))))
                          (lerp bg-b 0 (sin (+ (* pi 4/3) (/ (sim-time) bg-cycle-divisor))))
                          1.0))
          (glClear GL_COLOR_BUFFER_BIT)

          (glLoadIdentity)
          (glTranslated 0 0 (- near-depth))

          {bind-texture (force *texture*)}

          (define (face x y w h layer #:color [color '(1 1 1)])
            (define blend (- 1 (abs layer)))
            (define z (lerp far-depth near-depth layer))
            (define cx (/ (+ x w) 2))
            (define cy (/ (+ y h) 2))
            (define ww (* w (/ near-depth z)))
            (define hh (* h (/ near-depth z)))
            (define xx (- cx (/ ww 2)))
            (define yy (- cy (/ hh 2)))
            (match color
              [(list r g b)
               (glColor4d (lerp r 0 blend)
                          (lerp g 0 blend)
                          (lerp b 0 blend)
                          (lerp 1 0 blend))])
            (glPushMatrix)
            (glTranslated cx cy 0)
            (glRotated (/ (sim-time) 10) 0 0 -1)
            (glTranslated (- cx) (- cy) 0)
            (glBegin GL_QUADS)
            (glNormal3d 0 0 -1)
            (glTexCoord2i 0 0)
            (glVertex3d xx yy 0)
            (glTexCoord2i 1 0)
            (glVertex3d (+ xx ww) yy 0)
            (glTexCoord2i 1 1)
            (glVertex3d (+ xx ww) (+ yy hh) 0)
            (glTexCoord2i 0 1)
            (glVertex3d xx (+ yy hh) 0)
            (glEnd)
            (glPopMatrix))

          (let* ((layer-divisor (/ 1000.0 3))
                 (layer (expt (sin (/ (sim-time) layer-divisor)) 10))
                 (w {get-width (force *texture*)})
                 (h {get-height (force *texture*)}))
            (face 010 110 w h layer #:color (list 1 0 0))
            (face 410 110 w h layer #:color (list 0 0 1))
            (face (+ 210 (* (sin (/ (sim-time) 500.0)) 200))
                  (+ 110 (* (sin (/ (sim-time) 120.0)) 100))
                  (* w 2)
                  (* h 2)
                  0)
            (face 210 110 w h (- layer) #:color (list 0 1 0)))

          (glFlush)

          (swap-gl-buffers)))
      (queue-callback (lambda () (refresh)) #f))

    (define/override (on-size width height)
      (with-gl-context
        (lambda ()
          (glViewport 0 0 width height)

          (glMatrixMode GL_PROJECTION)
          (glLoadIdentity)
          ;; (gluPerspective 45 (/ width height) 0.1 100)
          (glOrtho 0 width height 0 0.1 100)

          (glMatrixMode GL_MODELVIEW)
          (glLoadIdentity)))
      (refresh))

    (define/override (on-char key)
      (define key-code {get-key-code key})
      (cond
        [(and {get-control-down key} (equal? key-code #\q))
         {show {get-top-level-window this} #f}]
        [(equal? key-code 'release) (void)]
        [else
         (with-gl-context
           (lambda ()
             (define p (cc-superimpose (colorize (disk 100) "white")
                                       (text (format "~a" key-code) 'default 72)))
             {load-from-bitmap! (force *texture*) (pict->bitmap p)}))])
      (refresh))

    (super-new (style '(gl no-autoclear)))))

(module+ main
  (define frame (new frame%
                     [style '(no-resize-border no-caption no-system-menu hide-menu-bar)]
                     [label "OpenGL Window"]
                     [width 640]
                     [height 480]))
  (define glcanvas (new glcanvas% [parent frame]))
  (unless {ok? {get-gl-context {get-dc glcanvas}}}
    (error 'gl-run "OpenGL context failed to initialize"))
  {focus glcanvas}
  {show frame #t})

chromelauncher2beta_screenshot2.jpg

glui.rkt

#lang racket/base
;; Experimentation with OpenGL for widgetry.

(require racket/class)
(require racket/gui/base)
(require sgl)
(require sgl/gl-vectors)

(define c%
  (class canvas%
    (inherit refresh with-gl-context swap-gl-buffers)

    (super-new)

    ;; (define/override (on-paint)
    ;;   (define dc (send this get-dc))
    ;;   (send dc set-brush "black" 'solid)
    ;;   (send dc draw-rectangle 0 0 (send this get-width) (send this get-height)))

    (define view-rotx 20.0)
    (define view-roty 30.0)
    (define view-rotz 0.0)

    (define/public (STEP)
      ;; (set! view-rotx (+ view-rotx 1))
      (set! view-roty (+ view-roty 2))
      (set! view-rotz (+ view-rotz 1))
      (refresh)
      (sleep/yield 1/60)
      (queue-callback (lambda _ (send this STEP)) #f))

    (define/override (on-paint)
      (with-gl-context
       (lambda ()
         (gl-clear-color 0.0 0.0 0.0 0.0)
         (gl-clear 'color-buffer-bit 'depth-buffer-bit)

         (gl-push-matrix)
         (gl-rotate view-rotx 1.0 0.0 0.0)
         (gl-rotate view-roty 0.0 1.0 0.0)
         (gl-rotate view-rotz 0.0 0.0 1.0)

         (define (face xr yr zr)
           (gl-push-matrix)
           (gl-rotate xr 1.0 0.0 0.0)
           (gl-rotate yr 0.0 1.0 0.0)
           (gl-rotate zr 0.0 0.0 1.0)
           (gl-translate 0 0 1)
           (gl-color 1 1 0) (gl-rect 0 0 1 1)
           (gl-color 1 0 0) (gl-rect -1 -1 0 0)
           (gl-color 0 1 0) (gl-rect -1 0 0 1)
           (gl-color 0 0 1) (gl-rect 0 -1 1 0)
           (gl-pop-matrix))

         (face 0 0 0)
         (face 90 0 0)
         (face 0 90 0)

         (face 0 180 0)
         (face 90 180 0)
         (face 0 270 0)

         ;; (gl-begin 'quads)
         ;; (gl-normal 0 0 1)
         ;; (gl-vertex -1 -1 1)
         ;; (gl-vertex 1 -1 1)
         ;; (gl-vertex 1 1 1)
         ;; (gl-vertex -1 1 1)
         ;; (gl-end)

         (gl-pop-matrix)

         (swap-gl-buffers)
         (gl-flush))))

    (define/override (on-event e)
      (when (is-a? e mouse-event%)
	(when (eq? (send e get-event-type) 'left-down)
	  (exit 0))))

    (define/override (on-size width height)
      (with-gl-context
       (lambda ()
         (gl-viewport 0 0 width height)

         (gl-matrix-mode 'projection)
         (gl-load-identity)
         (let ((h (/ height width)))
           (gl-frustum -1.0 1.0 (- h) h 5.0 60.0))

         (gl-matrix-mode 'modelview)
         (gl-load-identity)
         (gl-translate 0.0 0.0 -40.0)

         (gl-light-v 'light0 'position (vector->gl-float-vector
                                        (vector 5.0 5.0 10.0 0.0)))
         (gl-enable 'cull-face)
         (gl-enable 'lighting)
         (gl-enable 'light0)
         (gl-enable 'depth-test)

         ;;(gl-material-v 'front 'ambient-and-diffuse (vector->gl-float-vector (vector 1 1 0 1)))
         ;;(gl-material-v 'front 'specular (vector->gl-float-vector (vector 1 1 1 1)))
         ;;(gl-material-v 'front 'emission (vector->gl-float-vector (vector 0 0 0 1)))
         (gl-color-material 'front 'ambient-and-diffuse)
         (gl-enable 'color-material)
         ))
      (refresh))

    ))

(module+ main
  (define-values (W H) (get-display-size #t))
  (define f (new frame%
                 [style '(no-resize-border
                          no-caption
                          no-system-menu
                          hide-menu-bar)]
                 [label "glui"]
                 [width W]
                 [height H]))
  (define c (new c%
                 [parent f]
                 [style '(gl)]))
  (send f show #t)
  (send f center 'both)

  (send c STEP))

hacked-up-alpha.rkt

#lang send-exp racket/gui

(require sgl/gl
         sgl/gl-vectors)

(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)
    (let loop ()
      (when (< i pixels)
        (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)))
    (send dc set-bitmap #f)
    (list (send bmp get-width) (send bmp get-height) vec)))

(define *texture*
  (bitmap->gl-vector
   (make-object bitmap% "chromelauncher2beta_screenshot2.jpg" 'unknown #f)))

(define glcanvas%
  (class canvas%
    (inherit refresh with-gl-context swap-gl-buffers)

    (define *xrot* 0)
    (define *yrot* 0)
    (define *zrot* 0)

    (define init? #f)
    (define/override (on-paint)
      (with-gl-context
        (lambda ()
          (unless init?

            ;; (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 res *texture*)

            ;; Same texture, three smoothing styles...
            (init-textures 3)
            (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
                                     GL_NEAREST GL_NEAREST 0)
              (error "Couldn't load texture"))
            (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
                                     GL_LINEAR GL_LINEAR 1)
              (error "Couldn't load texture"))
            (unless (gl-load-texture (list-ref res 2) (list-ref res 0) (list-ref res 1)
                                     GL_LINEAR GL_LINEAR_MIPMAP_NEAREST 2)
              (error "Couldn't load texture"))

            ;; Set-up alpha blending 50% transparency
            (glColor4d 1 1 1 0.5)
            (glBlendFunc GL_SRC_ALPHA GL_ONE)
            (glEnable GL_BLEND)

            ;; Standard Init
            (glEnable GL_TEXTURE_2D)
            (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)

            ;; default light
            (glEnable GL_LIGHT0)
            (glEnable GL_LIGHTING)

            (set! init? #t))

          ;; erase the background
          (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
          ;; turn blending on/off
          (if #t (glEnable GL_BLEND) (glDisable GL_BLEND))

          ;; draw cube.
          (glLoadIdentity)
          (glTranslated 0 0 -5)
          (glRotated *xrot* 1 0 0)
          (glRotated *yrot* 0 1 0)
          (glRotated *zrot* 0 0 1)
          (glBindTexture GL_TEXTURE_2D (get-texture 0))
          (glBegin GL_QUADS)
          ; front
          (glNormal3d 0 0 1)
          (glTexCoord2i 0 0)
          (glVertex3i -1 -1 1)
          (glTexCoord2i 1 0)
          (glVertex3i 1 -1 1)
          (glTexCoord2i 1 1)
          (glVertex3i 1 1 1)
          (glTexCoord2i 0 1)
          (glVertex3i -1 1 1)
          ; back
          (glNormal3d 0 0 -1)
          (glTexCoord2i 1 0)
          (glVertex3i -1 -1 -1)
          (glTexCoord2i 1 1)
          (glVertex3i 1 -1 -1)
          (glTexCoord2i 0 1)
          (glVertex3i 1 1 -1)
          (glTexCoord2i 0 0)
          (glVertex3i -1 1 -1)
          ; top
          (glNormal3d 0 1 0)
          (glTexCoord2i 0 1)
          (glVertex3i -1 1 -1)
          (glTexCoord2i 0 0)
          (glVertex3i 1 1 -1)
          (glTexCoord2i 1 0)
          (glVertex3i 1 1 1)
          (glTexCoord2i 1 1)
          (glVertex3i -1 1 1)
          ; bottom
          (glNormal3d 0 -1 0)
          (glTexCoord2i 1 1)
          (glVertex3i -1 -1 -1)
          (glTexCoord2i 0 1)
          (glVertex3i -1 -1 1)
          (glTexCoord2i 0 0)
          (glVertex3i 1 -1 1)
          (glTexCoord2i 1 0)
          (glVertex3i 1 -1 -1)
          ; right
          (glNormal3d 1 0 0)
          (glTexCoord2i 1 0)
          (glVertex3i 1 -1 -1)
          (glTexCoord2i 1 1)
          (glVertex3i 1 -1 1)
          (glTexCoord2i 0 1)
          (glVertex3i 1 1 1)
          (glTexCoord2i 0 0)
          (glVertex3i 1 1 -1)
          ;left
          (glNormal3d -1 0 0)
          (glTexCoord2i 0 0)
          (glVertex3i -1 -1 -1)
          (glTexCoord2i 1 0)
          (glVertex3i -1 1 -1)
          (glTexCoord2i 1 1)
          (glVertex3i -1 1 1)
          (glTexCoord2i 0 1)
          (glVertex3i -1 -1 1)

          (glEnd)
          (set! *xrot* (+ *xrot* 0.3))
          (set! *yrot* (+ *yrot* 0.2))
          (set! *zrot* (+ *zrot* 0.4))

          (glFlush)

          (swap-gl-buffers)))
      (queue-callback (lambda () (refresh)) #f))

    (define/override (on-size width height)
      (with-gl-context
        (lambda ()
          (glViewport 0 0 width height)

          (glMatrixMode GL_PROJECTION)
          (glLoadIdentity)
          (gluPerspective 45 (/ width height) 0.1 100)

          (glMatrixMode GL_MODELVIEW)
          (glLoadIdentity)))
      (refresh))

    (define/override (on-char key)
      (log-info "Key: ~v" (send key get-key-code))
      (refresh))

    (super-new (style '(gl no-autoclear)))))



;; (define texture%
;;   (class object%
;;     (define textures (glGenTextures 1))
;;     (super-new)

(define *textures* '())

(define (init-textures count)
  (set! *textures* (glGenTextures count)))

(define (gl-load-texture 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 ix)
  (gl-vector-ref *textures* ix))


(module+ main
  (define frame (new frame%
                     [label "OpenGL Window"]
                     [width 640]
                     [height 480]))
  (define glcanvas (new glcanvas% [parent frame]))
  (unless (send (send (send glcanvas get-dc) get-gl-context) ok?)
    (error 'gl-run "OpenGL context failed to initialize"))
  (send frame show #t))

main.rkt

#lang send-exp racket/gui

(require sgl/gl)
(require sgl/gl-vectors)
(require pict)

(define texture%
  (class object%
    (init [(initial-bitmap bitmap)])
    (field [width 0]
           [height 0]
           [textures #f])

    (define {get-width self} width)
    (define {get-height self} height)

    (define {bind-texture self}
      (when (not textures) (error 'bind-texture "Attempt to use disposed texture%"))
      (glBindTexture GL_TEXTURE_2D (gl-vector-ref textures 0)))

    (define {load-from-bitmap! self bitmap}
      (when textures {dispose self})
      (set! textures (glGenTextures 1))
      {bind-texture self}
      (define image-data
        (let ()
          (set! width {get-width bitmap})
          (set! height {get-height bitmap})
          (define dc (new bitmap-dc% [bitmap bitmap]))
          (define pixels (* width height))
          (define vec (make-gl-ubyte-vector (* pixels 4)))
          (define data (make-bytes (* pixels 4)))
          {get-argb-pixels dc 0 0 width height data}
          (for ((i (in-range pixels)))
            (for ((j (in-range 4)))
              (gl-vector-set! vec (+ (* i 4) j) (bytes-ref data (+ (* i 4) (- 3 j))))))
          vec))
      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
      (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
      (glTexImage2D GL_TEXTURE_2D 0 4 width height 0 GL_BGRA GL_UNSIGNED_BYTE image-data))

    (define {dispose self}
      (when textures
        (glDeleteTextures textures)
        (set! textures #f)))

    (super-new)
    (load-from-bitmap! initial-bitmap)))

(define sim-time
  (let ((start-time (current-inexact-milliseconds)))
    (lambda ()
      (- (current-inexact-milliseconds) start-time))))

(define glcanvas%
  (class canvas%
    (inherit refresh with-gl-context swap-gl-buffers)

    (define *xrot* 0)
    (define *yrot* 0)
    (define *zrot* 0)

    (define *texture*
      (delay
        (new texture%
             [bitmap (make-object bitmap% "chromelauncher2beta_screenshot2.jpg" 'unknown #f)])))

    (define init? #f)
    (define/override (on-paint)
      (with-gl-context
        (lambda ()
          (unless init?
            (glEnable GL_COLOR_MATERIAL)
            (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
            (glEnable GL_BLEND)

            ;; Standard Init
            (glEnable GL_TEXTURE_2D)
            (glShadeModel GL_SMOOTH)
            (glClearColor 0.9 0.9 0.9 1.0)
            (glClearDepth 1)
            (glEnable GL_DEPTH_TEST)
            (glDepthFunc GL_LEQUAL)
            (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)

            ;; default light
            (glEnable GL_LIGHT0)
            (glEnable GL_LIGHTING)

            (set! init? #t))

          (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))

          ;; draw cube.
          (glLoadIdentity)
          (glTranslated 0 0 -5)
          (glRotated *xrot* 1 0 0)
          (glRotated *yrot* 0 1 0)
          (glRotated *zrot* 0 0 1)
          {bind-texture (force *texture*)}
          (glBegin GL_QUADS)

          ;; (face [[top left corner point]] [[normal vec]] [[x axis vec]] [[width]] [[height]])
          (define (face x1 y1 z1 nx0 ny0 nz0 xx0 xy0 xz0 w h)
            (define (vlen x y z) (sqrt (+ (* x x) (* y y) (* z z))))
            (define (cross x1 y1 z1 x2 y2 z2) (values (- (* y1 z2) (* z1 y2))
                                                      (- (* z1 x2) (* x1 z2))
                                                      (- (* x1 y2) (* y1 x2))))
            (define (scale s x y z) (values (* x s) (* y s) (* z s)))
            (define (norm x y z) (let ((l (vlen x y z)))
                                   (if (zero? l)
                                       (values 0 0 1)
                                       (scale (/ l) x y z))))
            (define-values (nx ny nz) (norm nx0 ny0 nz0))
            (define-values (xx xy xz) (norm xx0 xy0 xz0))
            (define-values (yx yy yz) (cross xx xy xz nx ny nz))
            (define (v x y)
              (glVertex3d (+ x1 (* xx (wobble x)) (* yx y))
                          (+ y1 (* xy x) (* yy (wobble y)))
                          (+ z1 (* xz x) (* yz y))))
            (glNormal3d nx ny nz)
            (glTexCoord2i 0 0)
            (v 0 0)
            (glTexCoord2i 1 0)
            (v w 0)
            (glTexCoord2i 1 1)
            (v w h)
            (glTexCoord2i 0 1)
            (v 0 h))

          (define (wobble v)
            (define s (sin (/ (sim-time) 333.3)))
            (+ v (abs s)))

          (glColor4d 1 0 0 1)
          (face -1 +1 +1  0 0 +1  +1 0 0  2 2)
          (glColor4d 1 0 1 1)
          (face +1 +1 -1  0 0 -1  -1 0 0  2 2)

          (glColor4d 0 1 0 1)
          (face +1 +1 +1  +1 0 0  0 0 -1  2 2)
          (glColor4d 0 1 1 1)
          (face -1 +1 -1  -1 0 0  0 0 +1  2 2)

          (glColor4d 0 0 1 1)
          (face -1 +1 -1  0 +1 0  +1 0 0  2 2)
          (glColor4d 1 1 1 1)
          (face -1 -1 +1  0 -1 0  +1 0 0  2 2)

          (glEnd)
          (set! *xrot* (+ *xrot* 0.3))
          (set! *yrot* (+ *yrot* 0.2))
          (set! *zrot* (+ *zrot* 0.4))

          (glFlush)

          (swap-gl-buffers)))
      (queue-callback (lambda () (refresh)) #f))

    (define/override (on-size width height)
      (with-gl-context
        (lambda ()
          (glViewport 0 0 width height)

          (glMatrixMode GL_PROJECTION)
          (glLoadIdentity)
          (gluPerspective 45 (/ width height) 0.1 100)
          ;; (glOrtho 0 width height 0 0.1 100)

          (glMatrixMode GL_MODELVIEW)
          (glLoadIdentity)))
      (refresh))

    (define/override (on-char key)
      (define key-code {get-key-code key})
      (cond
        [(and {get-control-down key} (equal? key-code #\q))
         {show {get-top-level-window this} #f}]
        [(equal? key-code 'release) (void)]
        [else
         (with-gl-context
           (lambda ()
             (define p (cc-superimpose (colorize (disk 100) "white")
                                       (text (format "~a" key-code) 'default 72)))
             {load-from-bitmap! (force *texture*) (pict->bitmap p)}))])
      (refresh))

    (super-new (style '(gl no-autoclear)))))

(module+ main
  (define frame (new frame%
                     [label "OpenGL Window"]
                     [width 640]
                     [height 480]))
  (define glcanvas (new glcanvas% [parent frame]))
  (unless {ok? {get-gl-context {get-dc glcanvas}}}
    (error 'gl-run "OpenGL context failed to initialize"))
  {focus glcanvas}
  {show frame #t})