# tcl3dTexture.tcl
#
# Togl texture map demo
#
# This is a version of the original Togl texture demo written entirely in Tcl
# with the help of the Tcl3D package.
#
# Copyright (C) 1996 Brian Paul and Ben Bederson (Original C/Tcl version)
# Copyright (C) 2005-2025 Paul Obermeier (Tcl3D version)
# See the LICENSE file for copyright details.
#
# Original sources available at: http://sourceforge.net/projects/togl/

package require Img
package require tcl3d

set CHECKER 0
set FACE 1
set TREE 2

set blend $::GL_FALSE

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

# 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 ReadImg { imgName } {
    global gPo

    if { [info exists ::vecImg] } {
        $::vecImg delete
    }
    set texName [file join $::g_scriptDir $imgName]
    set retVal [catch {set phImg [image create photo -file $texName]} err1]
    if { $retVal != 0 } {
        error "Failure reading image $texName"
    } else {
        set w [image width  $phImg]
        set h [image height $phImg]
        set z [tcl3dPhotoChans $phImg]
        set ::vecImg [tcl3dVectorFromPhoto $phImg]
        image delete $phImg

        glEnable GL_TEXTURE_2D
        glPixelStorei GL_UNPACK_ALIGNMENT 1
        if { $z == 3 } {
            set type $::GL_RGB
        } else {
           set type $::GL_RGBA
        }
        gluBuild2DMipmaps GL_TEXTURE_2D $z $w $h \
                $type GL_UNSIGNED_BYTE $::vecImg
    }
}

# 
# Load a texture image.  n is one of CHECKER, FACE or TREE.
#
proc TextureImage { n } {
    if { $n == $::CHECKER } {
        set WIDTH  64
        set HEIGHT 64
        set teximage [tcl3dVector GLubyte [expr $WIDTH*$HEIGHT*4]]

        for { set i 0 } { $i < $HEIGHT } { incr i } {
            for { set j 0 } { $j < $WIDTH } { incr j } { 
                set c [expr ($i / 4 + $j / 4) % 2]
                if { $c } {
                    set value 0xff
                } else {
                    set value 0x00
                }
                $teximage set [expr ($i * $WIDTH + $j)*4 + 0] $value
                $teximage set [expr ($i * $WIDTH + $j)*4 + 1] $value
                $teximage set [expr ($i * $WIDTH + $j)*4 + 2] $value
                $teximage set [expr ($i * $WIDTH + $j)*4 + 3] $value
            }
        }

        glEnable GL_TEXTURE_2D
        gluBuild2DMipmaps GL_TEXTURE_2D 4 $WIDTH $HEIGHT \
                          GL_RGBA GL_UNSIGNED_BYTE $teximage
        set ::blend $::GL_FALSE

    } elseif { $n == $::FACE } {
        ReadImg "ben.rgb"
        set ::blend $::GL_TRUE

    } elseif { $n == $::TREE } {
        ReadImg "tree2.rgba"
        set ::blend $::GL_TRUE
    } else {
        error "Wrong texture image number $n"
    }
}

# 
# Togl widget create callback.  This is called by Tcl/Tk when the widget has
# been realized.  Here's where one may do some one-time context setup or
# initializations.
#
proc CreateCallback { toglwin } {
    glEnable GL_DEPTH_TEST

    TextureImage $::CHECKER

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::magfilter
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::minfilter
}

# 
# Togl widget reshape callback. This is called by Tcl/Tk when the widget
# has been resized. Typically, we call glViewport and perhaps setup the
# projection matrix.
#
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    set w [$toglwin width]
    set h [$toglwin height]

    glViewport 0 0 $w $h
}

proc CheckError { where } {
    set errMsg [tcl3dOglGetError]
    if { $errMsg eq "" } {
        return
    }
    error [format "OpenGL error in proc %s: %s\n" $where $errMsg]
}

# 
# Togl widget display callback.  This is called by Tcl/Tk when the widget's
# contents have to be redrawn.  Typically, we clear the color and depth
# buffers, render our objects, then swap the front/back color buffers.
#
proc DisplayCallback { toglwin } {
    set aspect [expr double ([$toglwin width]) / double ([$toglwin height])]

    CheckError "DisplayCallback"

    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glMatrixMode GL_MODELVIEW
    glLoadIdentity

    glDisable GL_TEXTURE_2D
    glDisable GL_DEPTH_TEST
    glBegin GL_POLYGON
    glColor3f 0.0 0.0 0.3
    glVertex2f -1.0 -1.0
    glColor3f 0.0 0.0 0.3
    glVertex2f 1.0 -1.0
    glColor3f 0.0 0.0 0.9
    glVertex2f 1.0 1.0
    glColor3f 0.0 0.0 0.9
    glVertex2f -1.0 1.0
    glEnd

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glFrustum [expr -1.0 * $aspect] $aspect -1.0 1.0 2.0 10.0
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 -5.0
    glScalef $::scale $::scale $::scale
    glRotatef $::xangle 0.0 1.0 0.0
    glRotatef $::yangle 1.0 0.0 0.0

    glEnable GL_DEPTH_TEST
    glEnable GL_TEXTURE_2D
    glColor4ubv $::polycolor

    if {$::blend == $::GL_TRUE} {
        glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
        glEnable GL_BLEND
    }

    glBegin GL_POLYGON
    glTexCoord2f 0.0 0.0
    glVertex2f -1.0 -1.0
    glTexCoord2f $::coord_scale 0.0
    glVertex2f 1.0 -1.0
    glTexCoord2f $::coord_scale $::coord_scale
    glVertex2f 1.0 1.0
    glTexCoord2f 0.0 $::coord_scale
    glVertex2f -1.0 1.0
    glEnd

    glDisable GL_BLEND

    $toglwin swapbuffers
}

# Called magnification filter changes
proc NewMagFilter {} {
    global magfilter
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $magfilter
    .fr.f1.view postredisplay
}


# Called minification filter changes
proc NewMinFilter {} {
    global minfilter
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $minfilter
    .fr.f1.view postredisplay
}


# Called when texture image radio button changes
proc NewImage {} {
    global teximage
    TextureImage $teximage
    .fr.f1.view postredisplay
}


# Called when texture S wrap button changes
proc NewWrapS {} {
    global swrap
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $swrap
    .fr.f1.view postredisplay
}


# Called when texture T wrap button changes
proc NewWrapT {} {
    global twrap
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $twrap
    .fr.f1.view postredisplay
}


# Called when texture environment radio button selected
proc NewEnv {} {
    global envmode
    glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $envmode
    .fr.f1.view postredisplay
}


# Called when polygon color sliders change
proc NewColor { foo } {
    global poly_red poly_green poly_blue
    set ::polycolor [list $poly_red $poly_green $poly_blue 255]
    .fr.f1.view postredisplay
}


proc NewCoordScale { name element op } {
    global coord_scale

    if { $coord_scale eq "" || ! [string is double $coord_scale] } {
        set coord_scale 1.0
    }
    .fr.f1.view postredisplay
}

# Make the widgets
proc CreateWindows {} {
    global magfilter
    global minfilter
    global teximage
    global swrap
    global twrap
    global envmode
    global poly_red
    global poly_green
    global poly_blue
    global polycolor
    global coord_scale
    global startx starty         # location of mouse when button pressed
    global xangle yangle
    global xangle0 yangle0
    global scale scale0

    # set default values
    set minfilter $::GL_NEAREST_MIPMAP_LINEAR
    set magfilter $::GL_LINEAR
    set swrap $::GL_REPEAT
    set twrap $::GL_REPEAT
    set envmode $::GL_MODULATE
    set teximage $::CHECKER
    set poly_red 255
    set poly_green 255
    set poly_blue 255
    set polycolor [list $poly_red $poly_green $poly_blue 255]
    set coord_scale 1.0

    set xangle 0.0
    set yangle 0.0
    set scale 1.0

    wm title . "Tcl3D demo: Texture Map Options"

    # Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
    frame .fr
    pack .fr -expand 1 -fill both

    ### Two frames:  top half and bottom half
    frame .fr.f1
    frame .fr.f2

    ### The OpenGL window
    togl .fr.f1.view -width 250 -height 250 \
        -rgba true -double true -depth true \
        -createcommand  CreateCallback \
        -displaycommand DisplayCallback \
        -reshapecommand ReshapeCallback

    ### Filter radio buttons
    frame .fr.f1.filter -relief ridge -borderwidth 3

    frame .fr.f1.filter.mag -relief ridge -borderwidth 2

    label .fr.f1.filter.mag.label -text "Magnification Filter" -anchor w
    radiobutton .fr.f1.filter.mag.nearest -text GL_NEAREST -anchor w \
                -variable magfilter -value $::GL_NEAREST -command NewMagFilter
    radiobutton .fr.f1.filter.mag.linear -text GL_LINEAR -anchor w \
                -variable magfilter -value $::GL_LINEAR -command NewMagFilter

    frame .fr.f1.filter.min -relief ridge -borderwidth 2

    label .fr.f1.filter.min.label -text "Minification Filter" -anchor w
    radiobutton .fr.f1.filter.min.nearest -text GL_NEAREST -anchor w \
                -variable minfilter -value $::GL_NEAREST -command NewMinFilter
    radiobutton .fr.f1.filter.min.linear -text GL_LINEAR -anchor w \
                -variable minfilter -value $::GL_LINEAR -command NewMinFilter
    radiobutton .fr.f1.filter.min.nearest_mipmap_nearest -text GL_NEAREST_MIPMAP_NEAREST -anchor w \
                -variable minfilter -value $::GL_NEAREST_MIPMAP_NEAREST -command NewMinFilter
    radiobutton .fr.f1.filter.min.linear_mipmap_nearest -text GL_LINEAR_MIPMAP_NEAREST -anchor w \
                -variable minfilter -value $::GL_LINEAR_MIPMAP_NEAREST -command NewMinFilter
    radiobutton .fr.f1.filter.min.nearest_mipmap_linear -text GL_NEAREST_MIPMAP_LINEAR -anchor w \
                -variable minfilter -value $::GL_NEAREST_MIPMAP_LINEAR -command NewMinFilter
    radiobutton .fr.f1.filter.min.linear_mipmap_linear -text GL_LINEAR_MIPMAP_LINEAR -anchor w \
                -variable minfilter -value $::GL_LINEAR_MIPMAP_LINEAR -command NewMinFilter

    pack .fr.f1.filter.mag -fill x
    pack .fr.f1.filter.mag.label -fill x
    pack .fr.f1.filter.mag.nearest -side top -fill x
    pack .fr.f1.filter.mag.linear -side top -fill x

    pack .fr.f1.filter.min -fill both -expand true
    pack .fr.f1.filter.min.label -side top -fill x
    pack .fr.f1.filter.min.nearest -side top -fill x
    pack .fr.f1.filter.min.linear -side top -fill x 
    pack .fr.f1.filter.min.nearest_mipmap_nearest  -side top -fill x
    pack .fr.f1.filter.min.linear_mipmap_nearest  -side top -fill x
    pack .fr.f1.filter.min.nearest_mipmap_linear  -side top -fill x
    pack .fr.f1.filter.min.linear_mipmap_linear  -side top -fill x

    ### Texture coordinate scale and wrapping
    frame .fr.f2.coord -relief ridge -borderwidth 3
    frame .fr.f2.coord.scale -relief ridge -borderwidth 2
    label .fr.f2.coord.scale.label -text "Max Texture Coord" -anchor w
    entry .fr.f2.coord.scale.entry -textvariable coord_scale -exportselection 0

    frame .fr.f2.coord.s -relief ridge -borderwidth 2
    label .fr.f2.coord.s.label -text "GL_TEXTURE_WRAP_S" -anchor w
    radiobutton .fr.f2.coord.s.repeat -text "GL_REPEAT" -anchor w -variable swrap \
                -value $::GL_REPEAT -command NewWrapS
    radiobutton .fr.f2.coord.s.clamp -text "GL_CLAMP" -anchor w -variable swrap \
                -value $::GL_CLAMP -command NewWrapS

    frame .fr.f2.coord.t -relief ridge -borderwidth 2
    label .fr.f2.coord.t.label -text "GL_TEXTURE_WRAP_T" -anchor w
    radiobutton .fr.f2.coord.t.repeat -text "GL_REPEAT" -anchor w -variable twrap \
                -value $::GL_REPEAT -command NewWrapT
    radiobutton .fr.f2.coord.t.clamp -text "GL_CLAMP" -anchor w -variable twrap \
                -value $::GL_CLAMP -command NewWrapT

    pack .fr.f2.coord.scale -fill both -expand true
    pack .fr.f2.coord.scale.label -side top -fill x
    pack .fr.f2.coord.scale.entry -side top -fill x

    pack .fr.f2.coord.s -fill x
    pack .fr.f2.coord.s.label -side top -fill x
    pack .fr.f2.coord.s.repeat -side top -fill x
    pack .fr.f2.coord.s.clamp -side top -fill x

    pack .fr.f2.coord.t -fill x
    pack .fr.f2.coord.t.label -side top -fill x
    pack .fr.f2.coord.t.repeat -side top -fill x
    pack .fr.f2.coord.t.clamp -side top -fill x

    ### Texture image radio buttons (just happens to fit into the coord frame)
    frame .fr.f2.env -relief ridge -borderwidth 3
    frame .fr.f2.env.image -relief ridge -borderwidth 2
    label .fr.f2.env.image.label -text "Texture Image" -anchor w
    radiobutton .fr.f2.env.image.checker -text "Checker" -anchor w \
                -variable teximage -value $::CHECKER -command NewImage
    radiobutton .fr.f2.env.image.tree -text "Tree" -anchor w \
                -variable teximage -value $::TREE -command NewImage
    radiobutton .fr.f2.env.image.face -text "Face" -anchor w \
                -variable teximage -value $::FACE -command NewImage
    pack .fr.f2.env.image  -fill x
    pack .fr.f2.env.image.label -side top -fill x
    pack .fr.f2.env.image.checker -side top -fill x
    pack .fr.f2.env.image.tree -side top -fill x
    pack .fr.f2.env.image.face -side top -fill x

    ### Texture Environment
    label .fr.f2.env.label -text "GL_TEXTURE_ENV_MODE" -anchor w
    radiobutton .fr.f2.env.modulate -text "GL_MODULATE" -anchor w \
                -variable envmode -value $::GL_MODULATE -command NewEnv
    radiobutton .fr.f2.env.decal -text "GL_DECAL" -anchor w \
                -variable envmode -value $::GL_DECAL -command NewEnv
    radiobutton .fr.f2.env.blend -text "GL_BLEND" -anchor w \
                -variable envmode -value $::GL_BLEND -command NewEnv
    pack .fr.f2.env.label -fill x
    pack .fr.f2.env.modulate -side top -fill x
    pack .fr.f2.env.decal -side top -fill x
    pack .fr.f2.env.blend -side top -fill x

    ### Polygon color
    frame .fr.f2.color -relief ridge -borderwidth 3
    label .fr.f2.color.label -text "Polygon color" -anchor w
    scale .fr.f2.color.red -label Red -from 0 -to 255 -orient horizontal \
          -variable poly_red -command NewColor
    scale .fr.f2.color.green -label Green -from 0 -to 255 -orient horizontal \
          -variable poly_green -command NewColor
    scale .fr.f2.color.blue -label Blue -from 0 -to 255 -orient horizontal \
          -variable poly_blue -command NewColor
    pack .fr.f2.color.label -fill x
    pack .fr.f2.color.red -side top -fill x
    pack .fr.f2.color.green -side top -fill x
    pack .fr.f2.color.blue -side top -fill x


    ### Main widgets
    pack .fr.f1.view -side left -fill both -expand true
    pack .fr.f1.filter -side left -fill y
    pack .fr.f1 -side top -fill both -expand true

    pack .fr.f2.coord .fr.f2.env -side left -fill both
    pack .fr.f2.color -fill x
    pack .fr.f2 -side top -fill x

    label .fr.info
    pack .fr.info -expand false

    trace add variable coord_scale write NewCoordScale

    bind .fr.f1.view <ButtonPress-1> {
        set startx %x
        set starty %y
        set xangle0 $xangle
        set yangle0 $yangle
    }

    bind .fr.f1.view <B1-Motion> {
        set xangle [expr $xangle0 + (%x - $startx) / 3.0 ]
        set yangle [expr $yangle0 + (%y - $starty) / 3.0 ]
        .fr.f1.view postredisplay
    }

    bind .fr.f1.view <ButtonPress-2> {
        set startx %x
        set starty %y
        set scale0 $scale
    }

    bind .fr.f1.view <B2-Motion> {
        set q [ expr ($starty - %y) / 400.0 ]
        set scale [expr $scale0 * exp($q)]
        .fr.f1.view postredisplay
    }
    bind . <Key-Escape> "exit"
}

proc Cleanup {} {
    global coord_scale

    trace remove variable coord_scale write NewCoordScale 
}

CreateWindows

PrintInfo [tcl3dOglGetInfoString]
