;; Example 8-3 Use of glDrawPixels (use gl) (use gl.glut) (use gauche.uvector) ;; Create checkerboard image (define-constant *check-image-width* 64) (define-constant *check-image-height* 64) (define *check-image* (make-u8vector (* *check-image-height* *check-image-width* 3))) (define *zoom-factor* 1.0) (define *height* 0) (define (make-check-image) ;; NB: this must be easier once uniform array is implemented. (dotimes (i *check-image-height*) (dotimes (j *check-image-width*) (let ((ij (* (+ (* i *check-image-width*) j) 3)) (c (if (or (and (zero? (logand i #x08)) (zero? (logand j #x08))) (and (not (zero? (logand i #x08))) (not (zero? (logand j #x08))))) 0 255))) (set! (ref *check-image* ij) c) (set! (ref *check-image* (+ ij 1)) c) (set! (ref *check-image* (+ ij 2)) c)))) ) (define (init) (gl-clear-color 0 0 0 0) (gl-shade-model GL_FLAT) (make-check-image) (gl-pixel-store GL_UNPACK_ALIGNMENT 1) ) (define (disp) (gl-clear GL_COLOR_BUFFER_BIT) (gl-raster-pos 0 0) (gl-draw-pixels *check-image-width* *check-image-height* GL_RGB GL_UNSIGNED_BYTE *check-image*) (gl-flush) ) (define (reshape w h) (gl-viewport 0 0 w h) (set! *height* h) (gl-matrix-mode GL_PROJECTION) (gl-load-identity) (glu-ortho-2d 0.0 w 0.0 h) (gl-matrix-mode GL_MODELVIEW) (gl-load-identity) ) (define (motion x y) (let1 screen-y (- *height* y) (gl-raster-pos x screen-y) (gl-pixel-zoom *zoom-factor* *zoom-factor*) (gl-copy-pixels 0 0 *check-image-width* *check-image-height* GL_COLOR) (gl-pixel-zoom 1.0 1.0) (gl-flush))) (define (keyboard key x y) (cond ((or (= key (char->integer #\r)) (= key (char->integer #\R))) (set! *zoom-factor* 1.0) (glut-post-redisplay) (format #t "zoomFactor reset to 1.0\n") ) ((= key (char->integer #\z)) (inc! *zoom-factor* 0.5) (when (>= *zoom-factor* 3.0) (set! *zoom-factor* 3.0)) (format #t "zoomFactor is now ~a\n" *zoom-factor*) ) ((= key (char->integer #\Z)) (dec! *zoom-factor* 0.5) (when (<= *zoom-factor* 0.5) (set! *zoom-factor* 0.5)) (format #t "zoomFactor is now ~a\n" *zoom-factor*) ) ((= key 27) ;ESC (exit 0))) ) (define (main args) (glut-init args) (glut-init-display-mode (logior GLUT_SINGLE GLUT_RGB)) (glut-init-window-size 250 250) (glut-init-window-position 100 100) (glut-create-window (car args)) (init) (glut-reshape-func reshape) (glut-keyboard-func keyboard) (glut-display-func disp) (glut-motion-func motion) (glut-main-loop) 0)