Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

80 lines (64 sloc) 2.031 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)
Jump to Line
Something went wrong with that request. Please try again.