# This program demonstrates how one would go about doing a projected texture.
# The sample here shows how a projected texture technique can be used to produce a light map.
# The point is that even though you have very few vertices available for the fixed function
# pipeline lighting solution, you can achieve nice per pixel lighting even though the surface 
# has only a handful of vertices.
# This sample draws a cube, only allowing the inside being visible via culling front facing polys,
# and then projects the light map texture on the second texture stage all through the fixed
# function pipeline.
# The left mouse button will move the cube around and the right mouse button will move the
# projected # light map around.

# Original C++ code by Steve Butrimas 06/06/26
# See www.codesampler.com for the original files
# User Submitted Source page 6: Texture Projection
# http://www.codesampler.com/usersrc/usersrc_6.htm#oglu_projtexture
#
# Modified for Tcl3D by Paul Obermeier 2007/03/01
# See www.tcl3d.org for the Tcl3D extension.

package require Tk
package require Img
package require tcl3d

# Font to be used in the Tk listbox.
set g_listFont {-family {Courier} -size 10}

# Determine the directory of this script.
set g_scriptDir [file dirname [info script]]

set g_WinWidth  640
set g_WinHeight 480

set g_rotateObjectX  0.0
set g_rotateObjectY  0.0
set g_rotateTextureX 0.0
set g_rotateTextureY 0.0

set g_objectMove 0

set g_textureTransform [tcl3dVector GLfloat 16]
set g_objectTransform  [tcl3dVector GLfloat 16]
tcl3dMatfIdentity $g_textureTransform
tcl3dMatfIdentity $g_objectTransform

set g_CubeData [tcl3dVectorFromArgs GLfloat \
    1.0 0.0    1.0 1.0 1.0 1.0     0.0 0.0 1.0     -0.5 -0.5  0.5 \
    0.0 0.0    1.0 1.0 1.0 1.0     0.0 0.0 1.0      0.5 -0.5  0.5 \
    0.0 1.0    1.0 1.0 1.0 1.0     0.0 0.0 1.0      0.5  0.5  0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     0.0 0.0 1.0     -0.5  0.5  0.5 \
\
    1.0 0.0    1.0 1.0 1.0 1.0     1.0 0.0 0.0      0.5 -0.5  0.5 \
    0.0 0.0    1.0 1.0 1.0 1.0     1.0 0.0 0.0      0.5 -0.5 -0.5 \
    0.0 1.0    1.0 1.0 1.0 1.0     1.0 0.0 0.0      0.5  0.5 -0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     1.0 0.0 0.0      0.5  0.5  0.5 \
\
    0.0 0.0    1.0 1.0 1.0 1.0     0.0 0.0 -1.0    -0.5 -0.5 -0.5 \
    0.0 1.0    1.0 1.0 1.0 1.0     0.0 0.0 -1.0    -0.5  0.5 -0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     0.0 0.0 -1.0     0.5  0.5 -0.5 \
    1.0 0.0    1.0 1.0 1.0 1.0     0.0 0.0 -1.0     0.5 -0.5 -0.5 \
\
    1.0 0.0    1.0 1.0 1.0 1.0     -1.0 0.0 0.0    -0.5 -0.5 -0.5 \
    0.0 0.0    1.0 1.0 1.0 1.0     -1.0 0.0 0.0    -0.5 -0.5  0.5 \
    0.0 1.0    1.0 1.0 1.0 1.0     -1.0 0.0 0.0    -0.5  0.5  0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     -1.0 0.0 0.0    -0.5  0.5 -0.5 \
\
    0.0 1.0    1.0 1.0 1.0 1.0     0.0 -1.0 0.0    -0.5 -0.5 -0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     0.0 -1.0 0.0     0.5 -0.5 -0.5 \
    1.0 0.0    1.0 1.0 1.0 1.0     0.0 -1.0 0.0     0.5 -0.5  0.5 \
    0.0 0.0    1.0 1.0 1.0 1.0     0.0 -1.0 0.0    -0.5 -0.5  0.5 \
\
    0.0 0.0    1.0 1.0 1.0 1.0     0.0 1.0 0.0     -0.5  0.5 -0.5 \
    0.0 1.0    1.0 1.0 1.0 1.0     0.0 1.0 0.0     -0.5  0.5  0.5 \
    1.0 1.0    1.0 1.0 1.0 1.0     0.0 1.0 0.0      0.5  0.5  0.5 \
    1.0 0.0    1.0 1.0 1.0 1.0     0.0 1.0 0.0      0.5  0.5 -0.5 \
]

# All procs and variables prefixed with TexProj are originally located in a separate class.
# They have been inserted here, so the demo consists of a single file only.

set TexProj_texObject   [tcl3dVector GLuint 1]
set TexProj_projTexture [tcl3dVector GLuint 1]

proc TexProj_Cleanup {} {
    if { [info exists ::TexProj_texObject] } {
        glDeleteTextures 1 [$::TexProj_texObject get 0]
        $::TexProj_texObject delete
    }
    if { [info exists ::TexProj_projTexture] } {
        glDeleteTextures 1 [$::TexProj_projTexture get 0]
        $::TexProj_projTexture delete
    }
}

proc TexProj_LoadImage { imgName } {
    set texName [file join $::g_scriptDir $imgName]
    set retVal [catch {set phImg [image create photo -file $texName]} err1]
    if { $retVal != 0 } {
        error "Error reading image $texName ($err1)"
    } else {
        set w [image width  $phImg]
        set h [image height $phImg]
        set numChans [tcl3dPhotoChans $phImg]
        set texImg [tcl3dVectorFromPhoto $phImg $numChans]
        image delete $phImg
    }
    if { $numChans == 3 } {
        set type $::GL_RGB
    } else {
        set type $::GL_RGBA
    }
    return [list $texImg $w $h $type]
}

proc TexProj_LoadTexture { name } {
    global TexProj_texObject

    set imgInfo [TexProj_LoadImage $name]
    set imgData   [lindex $imgInfo 0]
    set imgWidth  [lindex $imgInfo 1]
    set imgHeight [lindex $imgInfo 2]
    set imgType   [lindex $imgInfo 3]

    glGenTextures 1 $TexProj_texObject
    TexProj_BindProjectiveTexture false

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR_MIPMAP_LINEAR
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
    gluBuild2DMipmaps GL_TEXTURE_2D $imgType $imgWidth $imgHeight \
                      $imgType GL_UNSIGNED_BYTE $imgData

    # Delete the image data vector.
    $imgData delete                 
}

proc TexProj_LoadLightMapTexture { name } {
    global TexProj_projTexture

    set eyePlaneS   {1.0 0.0 0.0 0.0 }
    set eyePlaneT   {0.0 1.0 0.0 0.0 }
    set eyePlaneR   {0.0 0.0 1.0 0.0 }
    set eyePlaneQ   {0.0 0.0 0.0 1.0 }
    set borderColor {0.6 0.6 0.6 1.0 }

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP
    glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_MODULATE

    # set up texture generation mode and set the corresponding planes
    glTexGeni  GL_S GL_TEXTURE_GEN_MODE $::GL_EYE_LINEAR
    glTexGenfv GL_S GL_EYE_PLANE $eyePlaneS
    glTexGeni  GL_T GL_TEXTURE_GEN_MODE $::GL_EYE_LINEAR
    glTexGenfv GL_T GL_EYE_PLANE $eyePlaneT
    glTexGeni  GL_R GL_TEXTURE_GEN_MODE $::GL_EYE_LINEAR
    glTexGenfv GL_R GL_EYE_PLANE $eyePlaneR
    glTexGeni  GL_Q GL_TEXTURE_GEN_MODE $::GL_EYE_LINEAR
    glTexGenfv GL_Q GL_EYE_PLANE $eyePlaneQ

    glEnable GL_TEXTURE_GEN_S
    glEnable GL_TEXTURE_GEN_T
    glEnable GL_TEXTURE_GEN_R
    glEnable GL_TEXTURE_GEN_Q

    set imgInfo [TexProj_LoadImage $name]
    set imgData   [lindex $imgInfo 0]
    set imgWidth  [lindex $imgInfo 1]
    set imgHeight [lindex $imgInfo 2]
    set imgType   [lindex $imgInfo 3]

    glGenTextures 1 $TexProj_projTexture

    glTexParameteri  GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR_MIPMAP_LINEAR
    glTexParameteri  GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
    glTexParameterfv GL_TEXTURE_2D GL_TEXTURE_BORDER_COLOR $borderColor

    gluBuild2DMipmaps GL_TEXTURE_2D $imgType $imgWidth $imgHeight \
                      $imgType GL_UNSIGNED_BYTE $imgData

    # Delete the image data vector.
    $imgData delete                 
}

proc TexProj_TextureProjection { mv } {
    set inverseMV [tcl3dVector GLfloat 16]
    tcl3dMatfInvert $mv $inverseMV

    # here is where we do the transformations on the texture matrix for the lightmap
    # the basic equation here is M = Bias * Scale * ModelView for light map * Inverse Modelview 
    glMatrixMode GL_TEXTURE
    glLoadIdentity
    glTranslatef 0.5 0.5 0.0                    ; # Bias
    glScalef 0.5 0.5 1.0                        ; # Scale
    glFrustum -0.035 0.035 -0.035 0.035 0.1 1.9 ; # MV for light map
    glTranslatef 0.0 0.0 -1.0
    set matrixAsList [tcl3dVectorToList $inverseMV 16]
    glMultMatrixf $matrixAsList                 ; # Inverse ModelView
    glMatrixMode GL_MODELVIEW

    $inverseMV delete
}

proc TexProj_BindProjectiveTexture { exp } {
    global TexProj_projTexture 
    global TexProj_texObject

    if { $exp } {
        glBindTexture GL_TEXTURE_2D [$TexProj_projTexture get 0]
    } else {
        glBindTexture GL_TEXTURE_2D [$TexProj_texObject get 0]
    }
}

# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
    tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
    exit
}

# Print info message into widget a the bottom of the window.
proc PrintInfo { msg } {
    if { [winfo exists .fr.info] } {
        .fr.info configure -text $msg
    }
}

proc SetMouseInput { btn x y } {
    set ::g_LastMousePosX(1) $x
    set ::g_LastMousePosY(1) $y
    if { $btn == 1 } {
        set ::g_objectMove 1
    } else {
        set ::g_objectMove 0
    }
}

proc GetMouseInput { btn x y } {
    set nXDiff [expr ($x - $::g_LastMousePosX(1))]
    set nYDiff [expr ($y - $::g_LastMousePosY(1))]
        
    if { $btn == 1 } {
        set ::g_rotateObjectY [expr $::g_rotateObjectY - $nXDiff]
        set ::g_rotateObjectX [expr $::g_rotateObjectX - $nYDiff]
    } else {
        set ::g_rotateTextureY [expr $::g_rotateTextureY - $nXDiff]
        set ::g_rotateTextureX [expr $::g_rotateTextureX - $nYDiff]
    }

    set ::g_LastMousePosX(1) $x
    set ::g_LastMousePosY(1) $y
    .fr.toglwin postredisplay
}

proc checkExtProc { extProc } {
    if { ![tcl3dOglHaveFunc $extProc] } {
        error "Extension proc $extProc not available"
    }
}

proc CreateCallback { toglwin } {
    set light0Pos {0.0 0.0 0.2 1.0}
    set matAmb    {0.2 0.2 0.2 1.0}
    set matDiff   {0.85 0.85 0.85 1.0}
    set matSpec   {0.30 0.30 0.30 1.0}
    set matShine  35.0

    # Check for needed ARB functions.
    checkExtProc "glMultiTexCoord2fARB"
    checkExtProc "glActiveTextureARB"

    # Enable front face culling so we can see into the box
    glEnable GL_CULL_FACE
    glCullFace GL_FRONT
    glEnable GL_LIGHTING
    glEnable GL_LIGHT0
    glEnable GL_COLOR_MATERIAL
    glEnable GL_DEPTH_TEST
    glDepthFunc GL_LEQUAL
    glHint GL_POLYGON_SMOOTH_HINT GL_NICEST
    glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST
    glClearColor 0.0 0.0 0.0 1.0

    # apply color tracking for material properties
    glColorMaterial GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE
    glMaterialfv GL_FRONT_AND_BACK GL_SPECULAR $matSpec
    glMaterialf GL_FRONT_AND_BACK GL_SHININESS $matShine

    # set up lighting so we have a dark scene
    glLightfv GL_LIGHT0 GL_POSITION $light0Pos
    glLightfv GL_LIGHT0 GL_AMBIENT $matAmb
    glLightfv GL_LIGHT0 GL_DIFFUSE $matDiff
    glLightfv GL_LIGHT0 GL_SPECULAR $matSpec
    glLightModeli GL_LIGHT_MODEL_TWO_SIDE $::GL_TRUE

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glFrustum -0.5 0.5 -0.5 0.5 1.0 15.0
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    gluLookAt 0.0 0.0 2.0 0.0 0.0 0.0 0.0 1.0 0.0

    # activate and load base texture on stage_0
    glActiveTextureARB GL_TEXTURE0_ARB
    glEnable GL_TEXTURE_2D
    TexProj_LoadTexture "stone_wall.bmp"

    # activate and load lightmap on stage_1
    glActiveTextureARB GL_TEXTURE1_ARB
    glEnable GL_TEXTURE_2D
    TexProj_LoadLightMapTexture "lightmap.bmp"
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    set w [$toglwin width]
    set h [$toglwin height]

    glViewport 0 0 $w $h

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr double($w)/double($h)] 0.1 100.0
}

proc DisplayCallback { toglwin } {
    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]

    # Viewport command is not really needed, but has been inserted for
    # Mac OSX. Presentation framework (Tk) does not send a reshape event,
    # when switching from one demo to another.
    glViewport 0 0 [$toglwin width] [$toglwin height]

    # control the movement of the projected texture
    glPushMatrix
    glLoadIdentity
    glRotatef [expr {$::g_rotateTextureX - $::g_rotateObjectX}] 1.0 0.0 0.0
    glRotatef [expr {$::g_rotateTextureY - $::g_rotateObjectY}] 0.0 1.0 0.0
    glGetFloatv GL_MODELVIEW_MATRIX $::g_textureTransform
    glPopMatrix
    TexProj_TextureProjection $::g_textureTransform

    if { $::g_objectMove } {
        # move the box itself
        glPushMatrix
        glLoadIdentity
        glRotatef $::g_rotateObjectX -1.0  0.0 0.0
        glRotatef $::g_rotateObjectY  0.0 -1.0 0.0
        glGetFloatv GL_MODELVIEW_MATRIX $::g_objectTransform
        glPopMatrix
    }

    # apply transformation on box and draw it
    glPushMatrix
    set matrixAsList [tcl3dVectorToList $::g_objectTransform 16]
    glMultMatrixf $matrixAsList
    glInterleavedArrays GL_T2F_C4F_N3F_V3F 0 $::g_CubeData
    glDrawArrays GL_QUADS 0 24
    glPopMatrix

    glFlush
    $toglwin swapbuffers
}

proc Cleanup {} {
    TexProj_Cleanup
    $::g_textureTransform delete
    $::g_objectTransform  delete
    $::g_CubeData delete

    foreach var [info globals g_*] {
        uplevel #0 unset $var
    }
}

proc ExitProg {} {
    exit
}

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width $g_WinWidth -height $g_WinHeight \
                 -double true -depth true \
                 -createcommand CreateCallback \
                 -reshapecommand ReshapeCallback \
                 -displaycommand DisplayCallback 
listbox .fr.usage -font $::g_listFont -height 3
label   .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.usage   -row 1 -column 0 -sticky news
grid .fr.info    -row 2 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1

set appTitle "Tcl3D demo: CodeSampler's Projected Texture"
wm title . $appTitle

# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"

bind .fr.toglwin <1>         "SetMouseInput 1 %x %y"
bind .fr.toglwin <B1-Motion> "GetMouseInput 1 %x %y"
bind .fr.toglwin <2>         "SetMouseInput 2 %x %y"
bind .fr.toglwin <B2-Motion> "GetMouseInput 2 %x %y"
bind .fr.toglwin <3>         "SetMouseInput 2 %x %y"
bind .fr.toglwin <B3-Motion> "GetMouseInput 2 %x %y"

.fr.usage insert end "Key-Escape Exit"
.fr.usage insert end "Mouse-L    Rotate cube"
.fr.usage insert end "Mouse-MR   Rotate light"
.fr.usage configure -state disabled

PrintInfo [tcl3dOglGetInfoString]
DisplayCallback .fr.toglwin
