# vectormanip.tcl
#
# Tcl3D demo showing the use of the Vector manipulation functions,
# introduced in Version 0.3.2.
# The program texture maps an image generated with Tcl (the source) onto the 
# left quad. The source texture is manipulated with the vector functions
# according to the choosen method and mapped onto the right quad.
# See functions execMethod? below.
#
# Author: Paul Obermeier
# Date: 2006-08-15

package require tcl3d

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

# Create checkerboard texture
set ::g_TexWidth  256
set ::g_TexHeight 256

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

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

# Print info message into window title.
proc PrintTitle { msg } {
    set titleStr "Tcl3D demo: Manipulating image vectors"
    wm title . [format "%s (%s)" $titleStr $msg]
}

# Print info message into OpenGL canvas.
proc PrintOgl { msg x y } {
    set len [string length $msg]
    if { $len > 0 } {
        glColor3f 1.0 1.0 1.0
        glRasterPos3f $x $y 0.0
        glListBase $::FontBase
        set sa [tcl3dVectorFromString GLubyte $msg]
        glCallLists $len GL_UNSIGNED_BYTE $sa
        $sa delete
    }
}

# Execute one of the texture manipulation procedures execMethod$num.
proc Method { num } {
    if { [package vcompare [package versions tcl3d] "0.3"] <= 0 } {
        tk_messageBox -icon info -type ok -title "Info" \
                      -message "Method $num needs Tcl3D 0.3.2 or higher"
        return
    }
    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
    glFlush

    if { [info exists ::g_TexSrc] } {
        $::g_TexSrc delete
    }
    if { [info exists ::g_TexDst] } {
        $::g_TexDst delete
    }

    execMethod$num

    glPixelStorei GL_UNPACK_ALIGNMENT 1

    if { [info exists ::g_TexName] } {
        $::g_TexName delete
    }
    set ::g_TexName [tcl3dVector GLuint 2]
    glGenTextures 2 $::g_TexName

    glBindTexture GL_TEXTURE_2D [$::g_TexName get 0]
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
    glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA \
                 $::g_TexWidth $::g_TexHeight \
                 0 $::g_TexType GL_UNSIGNED_BYTE $::g_TexSrc

    glBindTexture GL_TEXTURE_2D [$::g_TexName get 1]
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
    glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA \
                 $::g_TexWidth $::g_TexHeight \
                 0 $::g_TexType GL_UNSIGNED_BYTE $::g_TexDst

    .fr.toglwin postredisplay
}

# Utility function to create a GLubyte vector with numChans channels.
proc createVector { numChans } {
    return [tcl3dVector GLubyte [expr $::g_TexWidth * $::g_TexHeight * $numChans]]
}

# Create a gray-scale gradient: Generate a binary Tcl string for only one row.
# Transfer this row data with several calls to low-level function
# tcl3dByteArray2Vector while incrementing the destination offset.
proc makeTexture1Chan {} {
    set tex [createVector 1]
    set ::g_TexType $::GL_LUMINANCE

    for { set j 0 } { $j < $::g_TexWidth } { incr j } { 
        append imgRow [binary format c $j]
    }
    for { set i 0 } { $i < $::g_TexHeight } { incr i } {
        set off [expr {$i * $::g_TexWidth}]
        tcl3dByteArray2Vector $imgRow $tex [string length $imgRow] 0 $off
    }
    return $tex
}

# Create a color gradient with tcl3dVectorFromByteArray.
proc makeTexture3Chan {} {
    set ::g_TexType $::GL_RGB

    set template [binary format ccc 1 0 0]
    for { set j 1 } { $j < $::g_TexWidth } { incr j } { 
        append template [binary format ccc $j 0 0]
    }
    set row $template
    for { set i 0 } { $i < $::g_TexHeight } { incr i } {
        append img $row
        set row [string map [list [binary format c 0] [binary format c $i]] \
                            $template]
    }
    set tex [tcl3dVectorFromByteArray GLubyte $img]
    return $tex
}

proc createTexture { numChans } {
    if { $numChans == 1 } {
        return [makeTexture1Chan]
    } elseif { $numChans == 3 } {
        return [makeTexture3Chan]
    }
    return ""
}

# Test of function tcl3dVectorCopy with 1 channel.
# Copy the source image vector into the destination vector. 
proc execMethod1 {} {
    set ::g_TexSrc [createTexture 1]
    set ::g_TexDst [createVector  1]
    tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 1
    PrintTitle "Test 1"
}

# Test of function tcl3dVectorCopy with 3 channels.
# Copy the source image vector into the destination vector. 
proc execMethod2 {} {
    set ::g_TexSrc [createTexture 3]
    set ::g_TexDst [createVector  3]
    tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 3
    PrintTitle "Test 2"
}

# Test of function tcl3dVectorManip with 1 channel.
# Invert the image, i.e. scale by -1 and offset by 255.
proc execMethod3 {} {
    set ::g_TexSrc [createTexture 1]
    set ::g_TexDst [createVector  1]
    tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 1
    tcl3dVectorManip $::g_TexDst $::g_TexWidth $::g_TexHeight 1 -1 255
    PrintTitle "Test 3"
}

# Test of function tcl3dVectorManip with 3 channels.
# Invert the image, i.e. scale by -1 and offset by 255.
proc execMethod4 {} {
    set ::g_TexSrc [createTexture 3]
    set ::g_TexDst [createVector  3]
    tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 3
    tcl3dVectorManip $::g_TexDst $::g_TexWidth $::g_TexHeight 3 -1 255
    PrintTitle "Test 4"
}

# Test of function tcl3dVectorCopyChannel with 3 channels.
# Swap red and green channels.
proc execMethod5 {} {
    set ::g_TexSrc [createTexture 3]
    set ::g_TexDst [createVector  3]
    tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 0 1 $::g_TexWidth $::g_TexHeight 3 3
    tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 1 0 $::g_TexWidth $::g_TexHeight 3 3
    tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 2 2 $::g_TexWidth $::g_TexHeight 3 3
    PrintTitle "Test 5"
}

proc CreateCallback { toglwin } {    
    glClearColor 0.5 0.5 0.5 0.0
    glShadeModel GL_FLAT
    glEnable GL_DEPTH_TEST
    set ::FontBase [$toglwin loadbitmapfont]
}

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]

    # First quad showing the original texture.
    if { [info exists ::g_TexName] } {
        glEnable GL_TEXTURE_2D
        glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL
        glBindTexture GL_TEXTURE_2D [$::g_TexName get 0]
    }
    glBegin GL_QUADS
        glTexCoord2f 0.0 0.0 ; glVertex3f -2.1 -1.0 0.0
        glTexCoord2f 0.0 1.0 ; glVertex3f -2.1  1.0 0.0
        glTexCoord2f 1.0 1.0 ; glVertex3f -0.1  1.0 0.0
        glTexCoord2f 1.0 0.0 ; glVertex3f -0.1 -1.0 0.0
    glEnd

    # Second quad showing the modified texture.
    if { [info exists ::g_TexName] } {
        glEnable GL_TEXTURE_2D
        glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL
        glBindTexture GL_TEXTURE_2D [$::g_TexName get 1]
    }
    glBegin GL_QUADS
        glTexCoord2f 0.0 0.0 ; glVertex3f 0.1 -1.0 0.0
        glTexCoord2f 0.0 1.0 ; glVertex3f 0.1  1.0 0.0
        glTexCoord2f 1.0 1.0 ; glVertex3f 2.1  1.0 0.0
        glTexCoord2f 1.0 0.0 ; glVertex3f 2.1 -1.0 0.0
    glEnd

    glDisable GL_TEXTURE_2D

    PrintOgl "Source texture"     -2.1 -1.2
    PrintOgl "Destination texture" 0.1 -1.2

    glFlush
    $toglwin swapbuffers
}

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

    set fov [expr (2.0 * atan2 (4.5/2.0, 2.0)) * 180.0 / 3.14159]
    glViewport 0 0 $w $h
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective $fov [expr double($w)/double($h)] 1.0 30.0
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 -2.0
}

proc Cleanup {} {
    if { [info exists ::g_TexName] } {
        $::g_TexName delete
    }
    if { [info exists ::g_TexSrc] } {
        $::g_TexSrc delete
    }
    if { [info exists ::g_TexDst] } {
        $::g_TexDst delete
    }
    foreach var [info globals g_*] {
        uplevel #0 unset $var
    }
}

# Put all exit related code here.
proc ExitProg {} {
    exit
}

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width 640 -height 500 \
                 -double true -depth true \
                 -createcommand CreateCallback \
                 -reshapecommand ReshapeCallback \
                 -displaycommand DisplayCallback 
listbox .fr.usage -height 6 -font $g_ListFont
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

bind . <Key-1> "Method 1"
bind . <Key-2> "Method 2"
bind . <Key-3> "Method 3"
bind . <Key-4> "Method 4"
bind . <Key-5> "Method 5"
bind . <Key-Escape> "ExitProg"

.fr.usage insert end "Key-1:      Copy:  Dest(bw)    = Src(bw)"
.fr.usage insert end "Key-2:      Copy:  Dest(r,g,b) = Src(r,g,b)"
.fr.usage insert end "Key-3:      Manip: Dest(bw)    = -1 * Src(bw)    + 255"
.fr.usage insert end "Key-4:      Manip: Dest(r,g,b) = -1 * Src(r,g,b) + 255"
.fr.usage insert end "Key-5:      Swap : Dest(r,g,b) = Src(g,r,b)"
.fr.usage insert end "Key-Escape: Exit"
.fr.usage configure -state disabled

Method 1
PrintInfo [tcl3dOglGetInfoString]
