Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
80 lines (64 sloc) 1.98 KB
(import (rnrs)
(gl)
(glut)
(agave glamour window)
(agave glamour misc))
(define check-image-width 64)
(define check-image-height 64)
(define check-image-depth 3)
(define check-image
(make-bytevector
(* check-image-width
check-image-height
check-image-depth)))
(define (check-image-set! i j k val)
(bytevector-u8-set! check-image
(+ (* i check-image-width check-image-depth)
(* j check-image-depth)
k)
val))
(define (make-check-image)
(do ((i 0 (+ i 1)))
((>= i check-image-height))
(do ((j 0 (+ j 1)))
((>= j check-image-width))
(let ((c (* (bitwise-xor (if (= (bitwise-and i #x8) 0) 1 0)
(if (= (bitwise-and j #x8) 0) 1 0))
255)))
(check-image-set! i j 0 c)
(check-image-set! i j 1 c)
(check-image-set! i j 2 c)))))
(define zoom-factor 1.0)
(initialize-glut)
(window (size 250 250)
(title "image.sps")
(reshape (width height)))
(make-check-image)
(glPixelStorei GL_UNPACK_ALIGNMENT 1)
(buffered-display-procedure
(lambda ()
(background 0.0)
(glRasterPos2i 0 0)
(glDrawPixels check-image-width
check-image-height
GL_RGB
GL_UNSIGNED_BYTE
check-image)))
(glutMotionFunc
(let ((screen-y 0))
(lambda (x y)
(set! screen-y (- height y))
(glRasterPos2i x screen-y)
(glPixelZoom zoom-factor zoom-factor)
(glCopyPixels 0 0 check-image-width check-image-height GL_COLOR)
(glPixelZoom 1.0 1.0)
(glutSwapBuffers))))
(glutKeyboardFunc
(lambda (key x y)
(case (integer->char key)
((#\r) (set! zoom-factor 1.0))
((#\a) (set! zoom-factor (min (+ zoom-factor 0.5) 3.0)))
((#\z) (set! zoom-factor (max (- zoom-factor 0.5) 0.5)))
((#\q) (exit 0)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(glutMainLoop)