#!/usr/bin/newlisp

#  Description: Interactive 3D graphics, Assignment #1
#               Miniature Steam Engine Simulation.
#  Author:      Troy Robinette
#  Date:        29/9/95
#  Email:       troyr@yallara.cs.rmit.edu.au
#  Notes:       - Transparence doesn't quite work. The color of the
#                 underlying object doesn't show through. 
#	       - Also only the front side of the transparent objects are
#		 transparent.
#-------------------------------------------------------------------
# Ported to newLisp by Peter van Eerten.
#
# This is a 1-to-1 port of the original program.
# October 16, 2005.
# Adapted for newLisp 10, january 6 2009 - PvE.
#-------------------------------------------------------------------

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

(constant 'TRUE  1)
(constant 'FALSE 0)

# Dimensions of texture image.
(constant 'IMAGE_WIDTH  64)
(constant 'IMAGE_HEIGHT 64)

# Step to be taken for each rotation.
(constant 'ANGLE_STEP 10)

# Magic numbers for relationship b/w cylinder head and crankshaft.
(constant 'MAGNITUDE  120)
(constant 'PHASE      270.112)
(constant 'FREQ_DIV   58)
(constant 'ARC_LENGHT 2.7)
(constant 'ARC_RADIUS 0.15)

# Rotation angles
(set 'view_h (float 270))
(set 'view_v (float 0))
(set 'head_angle (float 0))
(set 'crank_angle 0)

# Crank rotation step.
(set 'crank_step (float 5))

# Toggles
(set 'shaded TRUE)
(set 'anim FALSE)
(set 'texture FALSE)
(set 'transparent FALSE)
(set 'light1 TRUE)
(set 'light2 FALSE)

# Storage for the angle look up table and the texture map
(set 'head_look_up_table (array 361))
(set 'image "")

# Indentifiers for each Display list
(set 'list_piston_shaded 1)
(set 'list_piston_texture 2)
(set 'list_flywheel_shaded 4)
(set 'list_flywheel_texture 8)

# Variable used in the creaton of glu objects
(set 'object:var (GLU:gluNewQuadric))

# Draws a box by scaling a glut cube of size 1. Also checks the shaded 
#   toggle to see which rendering style to use. NB Texture doesn't work
#   correctly due to the cube being scaled.
(define (myBox x y z)
	(GL:glPushMatrix)
	(GL:glScalef (flt x) (flt y) (flt z))
	(if (= shaded TRUE)
		(GLUT:glutSolidCube (float 1))
		(GLUT:glutWireCube (float 1))
	)
	(GL:glPopMatrix)
)

# Draws a cylinder using glu function, drawing flat disc's at each end,
#   to give the appearence of it being solid.
(define (myCylinder obj outerRadius innerRadius lenght)
	(GL:glPushMatrix)
	(GLU:gluCylinder obj:var (float outerRadius) (float outerRadius) (float lenght) 20 1)
	(GL:glPushMatrix)
	(GL:glRotatef (flt 180.0) (flt 0.0) (flt 1.0) (flt 0.0))
	(GLU:gluDisk obj:var (float innerRadius) (float outerRadius) 20 1)
	(GL:glPopMatrix)
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt lenght))
	(GLU:gluDisk obj:var (float innerRadius) (float outerRadius) 20 1)
	(GL:glPopMatrix)
)

# Draws a piston.
(define (draw_piston)
	(GL:glPushMatrix)
	(GL:glColor4f (flt 0.3) (flt 0.6) (flt 0.9) (flt 1.0))

	(GL:glPushMatrix)
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt -0.07))
	(myCylinder object 0.125 0.06 0.12)
	(GL:glPopMatrix)

	(GL:glRotatef (flt -90) (flt 1.0) (flt 0.0) (flt 0.0))
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt 0.05))
	(myCylinder object 0.06 0.0 0.6)
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt 0.6))
	(myCylinder object 0.2 0.0 0.5)
	(GL:glPopMatrix)
)

# Draws the engine pole and the pivot pole for the cylinder head.
(define (draw_engine_pole)
	(GL:glPushMatrix)
	(GL:glColor4f (flt 0.9) (flt 0.9) (flt 0.9) (flt 1.0))
	(myBox 0.5 3.0 0.5)

	(GL:glColor3f (flt 0.5) (flt 0.1) (flt 0.5))
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(GL:glTranslatef (flt 0.0) (flt 0.9) (flt -0.4))
	(myCylinder object 0.1 0.0 2)
	(GL:glPopMatrix)
)

# Draws the cylinder head at the appropreate angle, doing the necesary 
#   translations for the rotation.
(define (draw_cylinder_head)
	(GL:glPushMatrix)
	(GL:glColor4f (flt 0.5) (flt 1.0) (flt 0.5) (flt 0.1))
	(GL:glRotatef (flt 90) (flt 1.0) (flt 0.0) (flt 0.0))
	(GL:glTranslatef (flt 0) (flt 0.0) (flt 0.4))
	(GL:glRotatef (flt head_angle) (flt 1) (flt 0) (flt 0))
	(GL:glTranslatef (flt 0) (flt 0.0) (flt -0.4))
	(myCylinder object 0.23 0.21 1.6)
	(GL:glRotatef (flt 180) (flt 1.0) (flt 0.0) (flt 0.0))
	(GLU:gluDisk object:var 0 0.23 20 1)
	(GL:glPopMatrix)
)

# Draws the flywheel.
(define (draw_flywheel)
	(GL:glPushMatrix)
	(GL:glColor4f (flt 0.5) (flt 0.5) (flt 1.0) (flt 1.0))
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(myCylinder object 0.625 0.08 0.5)
	(GL:glPopMatrix)
)

# Draws the crank bell, and the pivot pin for the piston. Also calls the
#   appropreate display list of a piston doing the nesacary rotations before
#   hand.
(define (draw_crankbell)
	(GL:glPushMatrix)
	(GL:glColor4f (flt 1.0) (flt 0.5) (flt 0.5) (flt 1.0))
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(myCylinder object 0.3 0.08 0.12)

	(GL:glColor4f (flt 0.5) (flt 0.1) (flt 0.5) (flt 1.0))
	(GL:glTranslatef (flt 0.0) (flt 0.2) (flt 0.0))
	(myCylinder object 0.06 0.0 0.34)

	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt 0.22))
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(GL:glRotatef (flt (sub crank_angle head_angle)) (flt 1.0) (flt 0.0) (flt 0.0))
	(if (= shaded TRUE)
		(begin
			(if (!= texture 0)
				(GL:glCallList list_piston_texture)
				(GL:glCallList list_piston_shaded)
			)
		)
		(draw_piston)
	)
	(GL:glPopMatrix)
)

# Draws the complete crank. Piston also gets drawn through the crank bell
#   function.
(define (draw_crank)
	(GL:glPushMatrix)
	(GL:glRotatef (flt crank_angle) (flt 1.0) (flt 0.0) (flt 0.0))

	(GL:glPushMatrix)
	(GL:glRotatef (flt 90) (flt 0.0) (flt 1.0) (flt 0.0))
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt -1.0))
	(myCylinder object 0.08 0.0 1.4)
	(GL:glPopMatrix)

	(GL:glPushMatrix)
	(GL:glTranslatef (flt 0.28) (flt 0.0) (flt 0.0))
	(draw_crankbell)
	(GL:glPopMatrix)

	(GL:glPushMatrix)
	(GL:glTranslatef (flt -0.77) (flt 0.0) (flt 0.0))
	(if (= shaded TRUE)
		(begin
			(if (!= texture 0)
				(GL:glCallList list_flywheel_texture)
				(GL:glCallList list_flywheel_shaded)
			)
			(draw_flywheel)
		)
	)
	(GL:glPopMatrix)
	(GL:glPopMatrix)
)

# Main display routine. Clears the drawing buffer and if transparency is
#   set, displays the model twice, 1st time accepting those fragments with 
#   a ALPHA value of 1 only, then with DEPTH_BUFFER writing disabled for 
#   those with other values. */
(define (display)

	(GL:glClear (| GL:GL_COLOR_BUFFER_BIT GL:GL_DEPTH_BUFFER_BIT))

	(GL:glPushMatrix)
	(if (= transparent TRUE)
		(begin
			(GL:glEnable GL:GL_ALPHA_TEST)
			(set 'pass 2)
		)
		(begin
			(GL:glDisable GL:GL_ALPHA_TEST)
			(set 'pass 0)
		)
	)

	# Rotate the whole model
	(GL:glRotatef (flt view_h) (flt 0) (flt 1) (flt 0))
	(GL:glRotatef (flt view_v) (flt 1) (flt 0) (flt 0))

	(do-while (> pass 0)
		(if (= pass 2)
			(begin
				(GL:glAlphaFunc GL:GL_EQUAL 1)
				(GL:glDepthMask GL:GL_TRUE)
				(dec pass)
			)
			(begin
				(if (!= pass 0)
					(begin
						(GL:glAlphaFunc GL:GL_NOTEQUAL 1)
						(GL:glDepthMask GL:GL_FALSE)
						(dec pass)
					)
				)
			)
		)
		(draw_engine_pole)

		(GL:glPushMatrix)
		(GL:glTranslatef (flt 0.5) (flt 1.4) (flt 0.0))
		(draw_cylinder_head)
		(GL:glPopMatrix)

		(GL:glPushMatrix)
		(GL:glTranslatef (flt 0.0) (flt -0.8) (flt 0.0))
		(draw_crank)
		(GL:glPopMatrix)
	)
	(GL:glDepthMask GL:GL_TRUE)
	(GLUT:glutSwapBuffers)
	(GL:glPopMatrix)
)

# Called when the window is idle. When called increments the crank angle
#   by ANGLE_STEP, updates the head angle and notifies the system that
#   the screen needs to be updated.
(define (animation)
	(set 'crank_angle (add crank_angle crank_step))
	(if (>= crank_angle 360)
		(set 'crank_angle 0))
	(set 'head_angle (nth crank_angle head_look_up_table))
	(GLUT:glutPostRedisplay)
)

# Called when a key is pressed. Checks if it reconises the key and if so
#   acts on it, updateing the screen.
# ARGSUSED1
(define (keyboard key x y)
	(case key
		(115:		# 's'
			(if (= shaded FALSE)
				(begin
					(set 'shaded TRUE)
					(GL:glShadeModel GL:GL_SMOOTH)
					(GL:glEnable GL:GL_LIGHTING)
					(GL:glEnable GL:GL_DEPTH_TEST)
					(GL:glEnable GL:GL_COLOR_MATERIAL)
					(GLU:gluQuadricNormals object:var GLU:GLU_SMOOTH)
					(GLU:gluQuadricDrawStyle object:var GLU:GLU_FILL)
				)
				(begin
					(set 'shaded FALSE)
					(GL:glShadeModel GL:GL_FLAT)
					(GL:glDisable GL:GL_LIGHTING)
					(GL:glDisable GL:GL_DEPTH_TEST)
					(GL:glDisable GL:GL_COLOR_MATERIAL)
					(GLU:gluQuadricNormals object:var GLU:GLU_NONE)
					(GLU:gluQuadricDrawStyle object:var GLU:GLU_LINE)
					(GLU:gluQuadricTexture object:var GL:GL_FALSE)
				)
			)
		)
		(116:		# 't'
			(if (= texture FALSE)
				(begin
					(set 'texture TRUE)
					(GL:glEnable GL:GL_TEXTURE_2D)
					(GLU:gluQuadricTexture object:var GL:GL_TRUE)
				)
				(begin
					(set 'texture FALSE)
					(GL:glDisable GL:GL_TEXTURE_2D)
					(GLU:gluQuadricTexture object:var GL:GL_FALSE)
				)
			)
		)
		(111:		# 'o'
			(if (= transparent FALSE)
				(set 'transparent TRUE)
				(set 'transparent FALSE)
			)
		)
		(97:		# 'a'
			(set 'crank_angle (add crank_angle crank_step))
			(if (>= crank_angle 360)
				(set 'crank_angle 0)
			)
			(set 'head_angle (nth crank_angle head_look_up_table))
		)
		(122:		# 'z'
			(set 'crank_angle (sub crank_angle crank_step))
			(if (<= crank_angle 0)
				(set 'crank_angle 360)
			)
			(set 'head_angle (nth crank_angle head_look_up_table))
		)
		(48:		# '0'
			(if (= light1 TRUE)
				(begin
					(GL:glDisable GL:GL_LIGHT0)
					(set 'light1 FALSE)
				)
				(begin
					(GL:glEnable GL:GL_LIGHT0)
					(set 'light1 TRUE)
				)
			)
		)
		(49:		# '1'
    		(if (= light2 TRUE)
				(begin
					(GL:glDisable GL_LIGHT1)
					(set 'light2 FALSE)
				)
				(begin
					(GL:glEnable GL:GL_LIGHT1)
					(set 'light2 TRUE)
				)
			)
		)
		(52:		# '4'
			(set 'view_h (sub view_h ANGLE_STEP))
			(if (<= view_h 0)
				(set 'view_h 360)
			)
		)
		(54:		#'6'
			(set 'view_h (add view_h ANGLE_STEP))
			(if (>= view_h 360)
				(set 'view_h 0)
			)
		)
		(56:		# '8'
			(set 'view_v (add view_v ANGLE_STEP))
			(if (>= view_v 360)
				(set 'view_v 0)
			)
		)
		(50:		# '2'
			(set 'view_v (sub view_v ANGLE_STEP))
			(if (<= view_v 0)
				(set 'view_v 360)
			)
		)
		(32:		# ' '
			(if (!= anim 0)
				(begin
					(GLUT:glutIdleFunc 'NULL)
					(set 'anim FALSE)
				)
				(begin
					(GLUT:glutIdleFunc 'animation)
					(set 'anim TRUE)
				)
			)
		)
		(43:		# '+'
			(set 'crank_step (add crank_step 1.0))
			(if (> crank_step 45)
				(set 'crank_step (float 45))
			)
		)
		(45:		# '-'
			(set 'crank_step (sub crank_step 1.0))
			(if (<= crank_step 0)
				(set 'crank_step (float 0))
			)
		)
	)
	(GLUT:glutPostRedisplay)
)

# ARGSUSED1
(define (special key x y)
	(case key
		(0x0064:		#GLUT_KEY_LEFT
			(set 'view_h (sub view_h ANGLE_STEP))
			(if (<= view_h 0)
				(set 'view_h 360)
			)
		)
		(0x0066:		#GLUT_KEY_RIGHT
			(set 'view_h (add view_h ANGLE_STEP))
			(if (>= view_h 360)
				(set 'view_h 0)
			)
		)
		(0x0065:		#GLUT_KEY_UP
			(set 'view_v (add view_v ANGLE_STEP))
			(if (>= view_v 360)
				(set 'view_v 0)
			)
		)
		(0x0067:		#GLUT_KEY_DOWN
			(set 'view_v (sub view_v ANGLE_STEP))
			(if (<= view_v 0)
				(set 'view_v 360)
			)
		)
	)
	(GLUT:glutPostRedisplay)
)

# Called when a menu option has been selected. Translates the menu item
#   identifier into a keystroke, then call's the keyboard function.
(define (menu val)
	(case val
		(1: (set 'key 115))		# 's'
		(2: (set 'key 32))		# ' '
		(3: (set 'key 116))		# 't'
		(4: (set 'key 111))		# 'o'
		(5: (set 'key 48))		# '0'
		(6: (set 'key 49))		# '1'
		(7: (set 'key 43))		# '+'
		(8: (set 'key 45))		# '-'
	)
	(keyboard key 0 0)
)

# Initialises the menu of toggles.
(define (create_menu)
	(GLUT:glutCreateMenu 'menu)
	(GLUT:glutAttachMenu GLUT:GLUT_LEFT_BUTTON)
	(GLUT:glutAttachMenu GLUT:GLUT_RIGHT_BUTTON)
	(GLUT:glutAddMenuEntry "Shaded" 1)
	(GLUT:glutAddMenuEntry "Animation" 2)
	(GLUT:glutAddMenuEntry "Texture" 3)
	(GLUT:glutAddMenuEntry "Transparency" 4)
	(GLUT:glutAddMenuEntry "Right Light (0)" 5)
	(GLUT:glutAddMenuEntry "Left Light (1)" 6)
	(GLUT:glutAddMenuEntry "Speed UP" 7)
	(GLUT:glutAddMenuEntry "Slow Down" 8)
)

# Makes a simple check pattern image. (Copied from the redbook example
#   "checker.c".)
(define (make_image)
	(for (i 0 (- IMAGE_WIDTH 1))
		(for (j 0 (- IMAGE_HEIGHT 1))
			(if (= (& i 0x8) 0) (set 'n 1) (set 'n 0))
			(if (= (& j 0x8) 0) (set 'm 1) (set 'm 0))
			(set 'c (* (^ n m) 255) )
			(set 'image (append image (pack "c c c" c c c)))
		)
	)
)

# Makes the head look up table for all possible crank angles. */
(define (make_table)
	(for (i 0 360)
		(setf (head_look_up_table i) (mul MAGNITUDE (atan (div (mul ARC_RADIUS (sin (sub (div i FREQ_DIV)) PHASE))    
			(sub ARC_LENGHT (mul ARC_RADIUS (cos (sub PHASE (div i FREQ_DIV)))))  )  ))   )
	)
)

# Initialises texturing, lighting, display lists, and everything else 
#   associated with the model.
(define (myinit)
	(set 'mat_specular (pack "ffff" 1.0 1.0 1.0 1.0))
	(set 'mat_shininess (pack "f" 50.0))
	(set 'light_position1 (pack "ffff" 1.0 1.0 1.0 0.0))
	(set 'light_position2 (pack "ffff" -1.0 1.0 1.0 0.0))

	(GL:glClearColor (flt 0.0) (flt 0.0) (flt 0.0) (flt 0.0))

	(make_table)
	(make_image)

	# Set up Texturing
	(GL:glPixelStorei GL:GL_UNPACK_ALIGNMENT 1)
	(GL:glTexImage2D GL:GL_TEXTURE_2D 0 3 IMAGE_WIDTH IMAGE_HEIGHT 0 GL:GL_RGB GL:GL_UNSIGNED_BYTE image)
	(GL:glTexParameterf GL:GL_TEXTURE_2D GL:GL_TEXTURE_WRAP_S (flt GL:GL_CLAMP))
	(GL:glTexParameterf GL:GL_TEXTURE_2D GL:GL_TEXTURE_WRAP_T (flt GL:GL_CLAMP))
	(GL:glTexParameterf GL:GL_TEXTURE_2D GL:GL_TEXTURE_MAG_FILTER (flt GL:GL_NEAREST))
	(GL:glTexParameterf GL:GL_TEXTURE_2D GL:GL_TEXTURE_MIN_FILTER (flt GL:GL_NEAREST))
	(GL:glTexEnvf GL:GL_TEXTURE_ENV GL:GL_TEXTURE_ENV_MODE (flt GL:GL_MODULATE))

	# Set up Lighting
	(GL:glMaterialfv GL:GL_FRONT GL:GL_SPECULAR mat_specular)
	(GL:glMaterialfv GL:GL_FRONT GL:GL_SHININESS mat_shininess)
	(GL:glLightfv GL:GL_LIGHT0 GL:GL_POSITION light_position1)
	(GL:glLightfv GL:GL_LIGHT1 GL:GL_POSITION light_position2)

	# Initial render mode is with full shading and LIGHT 0 enabled.
	(GL:glEnable GL:GL_LIGHTING)
	(GL:glEnable GL:GL_LIGHT0)
	(GL:glDepthFunc GL:GL_LEQUAL)
	(GL:glEnable GL:GL_DEPTH_TEST)
	(GL:glDisable GL:GL_ALPHA_TEST)

	(GL:glColorMaterial GL:GL_FRONT_AND_BACK GL:GL_DIFFUSE)
	(GL:glEnable GL:GL_COLOR_MATERIAL)
	(GL:glShadeModel GL:GL_SMOOTH)

	# Initialise display lists
	(GL:glNewList list_piston_shaded GL:GL_COMPILE)
	(draw_piston)
	(GL:glEndList)
	(GL:glNewList list_flywheel_shaded GL:GL_COMPILE)
	(draw_flywheel)
	(GL:glEndList)

	(GLU:gluQuadricTexture object:var GL:GL_TRUE)
	(GL:glNewList list_piston_texture GL:GL_COMPILE)
	(draw_piston)
	(GL:glEndList)
	(GL:glNewList list_flywheel_texture GL:GL_COMPILE)
	(draw_flywheel)
	(GL:glEndList)
	(GLU:gluQuadricTexture object:var GL:GL_FALSE)
)

# Called when the model's window has been reshaped.
(define (myReshape w h)
	(GL:glViewport 0 0 w h)
	(GL:glMatrixMode GL:GL_PROJECTION)
	(GL:glLoadIdentity)
	(GLU:gluPerspective 65.0 (div w h) 1.0 20.0)
	(GL:glMatrixMode GL:GL_MODELVIEW)
	(GL:glLoadIdentity)
	(GL:glTranslatef (flt 0.0) (flt 0.0) (flt -5.0))  # viewing transform
	(GL:glScalef (flt 1.5) (flt 1.5) (flt 1.5))
)

# Main program. An interactive model of a miniture steam engine.
#   Sets system in Double Buffered mode and initialises all the call-back
#   functions.
(define (main argc argv)
	(println "Miniature Steam Engine                    Troy Robinette\n")

	(println "Keypad Arrow keys (with NUM_LOCK on) rotates object.")
	(println "Rotate crank: 'a' = anti-clock wise 'z' = clock wise")
	(println "Crank Speed : '+' = Speed up by 1   '-' = Slow Down by 1")
	(println "Toggle      : 's' = Shading         't' = Texture")
	(println "            : ' ' = Animation       'o' = Transparency")
	(println "            : '0' = Right Light     '1' = Left Light")
	(println " Alternatively a pop up menu with all toggles is attached")
	(println "   to the left mouse button.\n")

	(GLUT:glutInitWindowSize 400 400)
	(GLUT:glutInit (address argc) (address argv))

	# Transperancy won't work properly without GLUT_ALPHA
	(GLUT:glutInitDisplayMode (| GLUT:GLUT_DOUBLE GLUT:GLUT_RGBA GLUT:GLUT_DEPTH GLUT:GLUT_MULTISAMPLE))
	(GLUT:glutCreateWindow "Miniature Steam Engine by Troy Robinette")

	(GLUT:glutDisplayFunc 'display)
	(GLUT:glutKeyboardFunc 'keyboard)
	(GLUT:glutSpecialFunc 'special)
	(create_menu)

	(myinit)

	(GLUT:glutReshapeFunc 'myReshape)
	(GLUT:glutMainLoop)
)

(main 0 0)
(exit)