#!/usr/bin/newlisp
#
# gamma.c

# Draw test patterns to help determine correct gamma value for a display.
#   When the intensities in the top row nearly match the intensities in
#   the bottom row you've found the right gamma value.
#
#   For more info about gamma correction see:
#   http://www.inforamp.net/~poynton/notes/colour_and_gamma/GammaFAQ.html
#
#   This program is in the public domain
#
#   Brian Paul  19 Oct 1995
#
# Conversion to GLUT by Mark J. Kilgard
#-------------------------------------------------------------------
# Ported to newLisp by Peter van Eerten.
#
# This is a 1-to-1 port of the original program.
# November 15, 2005.
#-------------------------------------------------------------------

(load "GL.lsp" "freeglut.lsp")

(define (Reshape width height)

	(GL:glViewport 0 0 width height)

	(GL:glMatrixMode GL:GL_PROJECTION)
	(GL:glLoadIdentity)
	(GL:glOrtho -1.0 1.0 -1.0 1.0 -1.0 1.0)
	(GL:glMatrixMode GL:GL_MODELVIEW)
)

# ARGSUSED1
(define (key_esc key x y)

	(if (= key 27) (exit))  # Exit on Escape
)

(set 'p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))
(set 'p25 (append p25 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x00 0x00 0x00 0x00)))

(set 'p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))
(set 'p50 (append p50 (pack "bbbbbbbb "0xaa 0xaa 0xaa 0xaa 0x55 0x55 0x55 0x55)))

(set 'p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))
(set 'p75 (append p75 (pack "bbbbbbbb" 0xaa 0xaa 0xaa 0xaa 0xff 0xff 0xff 0xff)))

(define (display)

	(GL:glClear GL:GL_COLOR_BUFFER_BIT)

	# DITHERED ROW

	# solid black

	# 25% white
	(GL:glEnable GL:GL_POLYGON_STIPPLE)
	(GL:glColor3f (flt 1.0) (flt 1.0) (flt 1.0))
	(GL:glPolygonStipple p25)
	(GL:glRectf (flt -0.6) (flt 1.0) (flt -0.2) (flt 0.01))

	# 50% white
	(GL:glPolygonStipple p50)
	(GL:glRectf (flt -0.2) (flt 1.0) (flt 0.2) (flt 0.01))

	# 75% white
	(GL:glPolygonStipple p75)
	(GL:glRectf (flt 0.2) (flt 1.0) (flt 0.6) (flt 0.01))

	# 100% white
	(GL:glDisable GL:GL_POLYGON_STIPPLE)
	(GL:glRectf (flt 0.6) (flt 1.0) (flt 1.0) (flt 0.01))

	#*** GRAY ROW ***

	# solid black

	# 25% white
	(GL:glColor3f (flt 0.25) (flt 0.25) (flt 0.25))
	(GL:glRectf (flt -0.6) (flt -0.01) (flt -0.2) (flt -1.0))

	# 50% white
	(GL:glColor3f (flt 0.5) (flt 0.5) (flt 0.5))
	(GL:glRectf (flt -0.2) (flt -0.01) (flt 0.2) (flt -1.0))

	# 75% white
	(GL:glColor3f (flt 0.75) (flt 0.75) (flt 0.75))
	(GL:glRectf (flt 0.2) (flt -0.01) (flt 0.6) (flt -1.0))

	# 100% white
	(GL:glColor3f (flt 1.0) (flt 1.0) (flt 1.0))
	(GL:glRectf (flt 0.6) (flt -0.01) (flt 1.0) (flt -1.0))

	(GL:glFlush)
)

(define (main argc argv)

	(GLUT:glutInit (address argc) (address argv))
	(GLUT:glutInitDisplayMode (| GLUT:GLUT_RGB GLUT:GLUT_SINGLE))

	(GLUT:glutInitWindowPosition 50 50)
	(GLUT:glutInitWindowSize 400 200)

	(GLUT:glutCreateWindow "gamma test patterns")
	(GLUT:glutReshapeFunc 'Reshape)
	(GLUT:glutDisplayFunc 'display)
	(GLUT:glutKeyboardFunc 'key_esc)

	(GLUT:glutMainLoop)
)

(main 0 0)
(exit)