# testDrawReadPixels.tcl
#
# Tcl3D demo testing the speed of the glDrawPixels and glReadPixels functions.
# The program generates a color gradient image of a specified size.
# If the image size is greater than 256x256, the color gradient is tiled.
# This image is then drawn into the framebuffer with glDrawPixels and read
# back with glReadPixels several times.
# The time needed for drawing and reading back is reported into a text widget
# and onto stdout (for batch processing).
# The format and type of the image data can be specified for testing the
# differences in speed. 
# Currently the following formats and types are implemented:
# Formats: GL_RGB, GL_BGR, GL_RGBA, GL_BGRA.
# Types  : GL_UNSIGNED_BYTE
#
# Author: Paul Obermeier
# Date: 2009-07-16

package require tcl3d

# Font to be used in the Tk listbox.
set gDemo(listFont) {-family {Courier} -size 10}

# Determine the directory of this script
set gDemo(scriptDir) [file dirname [info script]]

# The possible formats and types.
set g_formats(GL_RGB,enum)      $::GL_RGB
set g_formats(GL_BGR,enum)      $::GL_BGR
set g_formats(GL_RGBA,enum)     $::GL_RGBA
set g_formats(GL_BGRA,enum)     $::GL_BGRA
set g_formats(GL_RGB,numChans)  3
set g_formats(GL_BGR,numChans)  3
set g_formats(GL_RGBA,numChans) 4
set g_formats(GL_BGRA,numChans) 4

set g_types(GL_UNSIGNED_BYTE,enum)     $::GL_UNSIGNED_BYTE
set g_types(GL_UNSIGNED_BYTE,numBytes) 1

foreach fmt [lsort [array names g_formats "*,enum"]] {
    lappend gOpts(formatsList) [lindex [split $fmt ","] 0]
}
foreach type [lsort [array names g_types "*,enum"]] {
    lappend gOpts(typesList) [lindex [split $type ","] 0]
}

# Default values for optional parameters.
set gOpts(curFormat) GL_RGB
set gOpts(curType)   GL_UNSIGNED_BYTE
set gOpts(imgWidth)  256
set gOpts(imgHeight) 256
set gOpts(imgSize)   [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
set gOpts(numCalls)  100
set gOpts(batch)     false

set gDemo(winWidth)   $gOpts(imgWidth)
set gDemo(winHeight)  $gOpts(imgHeight)
set gDemo(lastFormat) $gOpts(curFormat)

# 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 label widget at the bottom of the window.
proc PrintInfo { msg } {
    if { [winfo exists .fr.info] } {
        .fr.info configure -text $msg
    }
}

# Print report message into text widget at the bottom of the window.
proc PrintReport { msg } {
    global gDemo

    if { [winfo exists $gDemo(out)] } {
        $gDemo(out) insert end "$msg\n"
        $gDemo(out) see end
    }
    puts $msg
}

# Save the image stored in tcl3dVector "vec" into file "fileName".
proc SaveImg { fileName vec w h numChans } {
    set ph [image create photo -width $w -height $h]
    tcl3dVectorToPhoto $vec $ph $w $h $numChans
    set fmt [string range [file extension $fileName] 1 end]
    $ph write $fileName -format $fmt
    image delete $ph
}

# Create an image of size (w x h) with numChans channels.
proc MakeImg { w h numChans } {
    global gOpts gDemo

    if { $numChans == 3 } {
        set template [binary format ccc 1 0 0]
        for { set j 1 } { $j < $w } { incr j } { 
            append template [binary format ccc $j 0 0]
        }
    } elseif { $numChans == 4 } {
        set template [binary format cccc 1 0 0 0]
        for { set j 1 } { $j < $w } { incr j } { 
            append template [binary format cccc $j 0 0 0]
        }
    } else {
        error "Cannot make an image with $numChans channels"
    }
    set row $template
    for { set i 0 } { $i < $gOpts(imgHeight) } { incr i } {
        append img $row
        set row [string map [list [binary format c 0] [binary format c $i]] \
                            $template]
    }
    set gDemo(imgVec) [tcl3dVectorFromByteArray GLubyte $img]
}

proc NewSquareImage {} {
    global gOpts

    scan $gOpts(imgSize) "%dx%d" gOpts(imgWidth) gOpts(imgHeight)
    if { $gOpts(imgWidth) < 1 } {
        set gOpts(imgWidth) 1
    }
    if { $gOpts(imgHeight) < 1 } {
        set gOpts(imgHeight) 1
    }
    set gOpts(imgSize) [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
    NewImage
    .fr.toglwin configure -width $gOpts(imgWidth) -height $gOpts(imgHeight)
}

proc NewImage {} {
    global gOpts g_formats g_types

    Cleanup true
    set curFmt $gOpts(curFormat)

    MakeImg $gOpts(imgWidth) $gOpts(imgHeight) $g_formats($curFmt,numChans)
}

proc ReadPixels { vec w h } {
    global gOpts g_formats g_types

    set fmt  $g_formats($gOpts(curFormat),enum)
    set type $g_types($gOpts(curType),enum)
    glReadPixels 0 0 $w $h $fmt $type $vec
}

proc DrawPixels { vec w h } {
    global gOpts g_formats g_types

    set fmt  $g_formats($gOpts(curFormat),enum)
    set type $g_types($gOpts(curType),enum)
    glDrawPixels $w $h $fmt $type $vec
}

proc TimedDrawReadPixels {} {
    global gOpts gDemo g_formats

    set w $gOpts(imgWidth)
    set h $gOpts(imgHeight)
    set numChans $g_formats($gOpts(curFormat),numChans)

    set imgVec [tcl3dVector GLubyte [expr $w * $h * $numChans]]

    glPixelStorei GL_PACK_ALIGNMENT 1

    NewImage

    set measure [time {DrawPixels $gDemo(imgVec) $w $h} $gOpts(numCalls)]
    scan $measure "%f" msDraw
    
    set measure [time {ReadPixels $imgVec $w $h} $gOpts(numCalls)]
    scan $measure "%f" msRead

    set totDraw [format "%.4f" [expr $msDraw * $gOpts(numCalls) / 1000000.0]]
    set imgDraw [format "%.4f" [expr $msDraw / 1000.0]]
    set pixDraw [format "%.4f" [expr $msDraw / $w / $h]]
    set totRead [format "%.4f" [expr $msRead * $gOpts(numCalls) / 1000000.0]]
    set imgRead [format "%.4f" [expr $msRead / 1000.0]]
    set pixRead [format "%.4f" [expr $msRead / $w / $h]]

    PrintReport "Draw/Read of $gOpts(numCalls) images: $totDraw $totRead secs"
    PrintReport "Draw/Read of 1 image: $imgDraw $imgRead msecs ([expr $w*$h] pixels)"
    PrintReport "Draw/Read of 1 pixel: $pixDraw $pixRead msecs"

    # Write out the last read image.
    set fileName [format "%s-%dx%d.png" $gOpts(curFormat) $w $h]
    set filePath [file join $gDemo(scriptDir) $fileName]
    # Create a name on the file system, if running from within a Starpack.
    set imgName [tcl3dGenExtName $filePath]
    PrintReport "Saving image to [file tail $imgName]"
    SaveImg $imgName $imgVec $w $h $numChans

    $imgVec delete
}

proc CreateCallback { toglwin } {    
    glClearColor 0.0 0.0 0.0 0.0
    glShadeModel GL_FLAT
    glEnable GL_DEPTH_TEST
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    global gOpts gDemo

    set w [$toglwin width]
    set h [$toglwin height]

    glViewport 0 0 $w $h
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glOrtho 0 $gOpts(imgWidth) 0 $gOpts(imgHeight) -1.0 1.0
    glMatrixMode GL_MODELVIEW

    set gDemo(winWidth)  $w
    set gDemo(winHeight) $h
}

proc DisplayCallback { toglwin } {
    global gOpts gDemo

    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]

    glRasterPos2i 0 0
    if { $gOpts(curFormat) ne $gDemo(lastFormat) } {
        set gDemo(lastFormat) $gOpts(curFormat)
        NewImage
    }
    DrawPixels $gDemo(imgVec) $gOpts(imgWidth) $gOpts(imgHeight)
    glFlush
    $toglwin swapbuffers
}

proc ExecTest {} {
    TimedDrawReadPixels
    .fr.toglwin postredisplay
}

proc Cleanup { { imgOnly false } } {
    global gDemo

    if { [info exists gDemo(imgVec)] } {
        $gDemo(imgVec) delete
    }
    if { ! $imgOnly } {
        foreach var [info globals g_*] {
            uplevel #0 unset $var
        }
        uplevel #0 unset gDemo
        uplevel #0 unset gOpts
    }
}

proc ExitProg {} {
    exit
}


# Create the widgets and bindings.
proc CreateWindow {} {
    global gDemo gOpts

    frame .fr
    pack .fr -expand 1 -fill both
    # Create the OpenGL widget.
    togl .fr.toglwin -width $gDemo(winWidth) -height $gDemo(winHeight) \
                     -double true -depth true -alpha true \
                     -createcommand CreateCallback \
                     -reshapecommand ReshapeCallback \
                     -displaycommand DisplayCallback 

    frame .fr.frBtns
    frame .fr.frReport
    label .fr.info
    grid .fr.toglwin  -row 0 -column 0 -sticky news
    grid .fr.frBtns   -row 1 -column 0 -sticky news
    grid .fr.frReport -row 2 -column 0 -sticky news
    grid .fr.info     -row 3 -column 0 -sticky news
    grid rowconfigure .fr 0 -weight 1
    grid columnconfigure .fr 0 -weight 1
    
    wm title .  "Tcl3D demo: Speed test of glDrawPixels and glReadPixels"

    labelframe .fr.frBtns.frSett -text "Format and type"
    pack  .fr.frBtns.frSett -side left -padx 2
    set gOpts(formatsMenu) [eval {tk_optionMenu .fr.frBtns.frSett.fm \
                           gOpts(curFormat)} $gOpts(formatsList)]
    set gOpts(typesMenu) [eval {tk_optionMenu .fr.frBtns.frSett.tm \
                           gOpts(curType)} $gOpts(typesList)]
    eval pack [winfo children .fr.frBtns.frSett] -side left \
               -anchor w -expand 1 -fill x

    labelframe .fr.frBtns.frSize -text "Image size"
    pack  .fr.frBtns.frSize -side left -padx 2
    entry .fr.frBtns.frSize.size -textvariable gOpts(imgSize) -width 8
    bind .fr.frBtns.frSize.size <Key-Return> "NewSquareImage"
    tcl3dToolhelpAddBinding .fr.frBtns.frSize.size \
        "Press Enter to generate a new image. Resize the window to fit the image."
    eval pack [winfo children .fr.frBtns.frSize] -side left \
               -anchor w -expand 1 -fill x

    labelframe .fr.frBtns.frMisc -text "Num calls"
    pack  .fr.frBtns.frMisc -side left -padx 2
    entry .fr.frBtns.frMisc.numCalls -textvariable gOpts(numCalls) -width 4
    bind .fr.frBtns.frMisc.numCalls <Key-Return> "ExecTest"

    tcl3dToolhelpAddBinding .fr.frBtns.frMisc.numCalls \
        "Number of glDrawPixels and glReadPixels calls executed in test."
    eval pack [winfo children .fr.frBtns.frMisc] -side left \
               -anchor w -expand 1 -fill x

    labelframe .fr.frBtns.frCmds -text "Test"
    pack  .fr.frBtns.frCmds -side left -padx 2
    button .fr.frBtns.frCmds.exe -text "Run" -command "ExecTest"
    eval pack [winfo children .fr.frBtns.frCmds] -side left \
               -anchor w -expand 1 -fill x -padx 1

    set gDemo(out) [tcl3dCreateScrolledText .fr.frReport "" \
                    -height 5 -width 60 -borderwidth 1 -font $gDemo(listFont)]

    wm protocol . WM_DELETE_WINDOW "ExitProg"
    bind . <Key-Escape> "ExitProg"
}

set i 0
while { $i < $argc } {
    set curArg [lindex $argv $i] 
    if { $curArg eq "-help" || $curArg eq "--help" } {
        puts "Usage: $argv0 \[Options\]"
        puts "Options:"
        puts "    -size w h: Specify image width and height"
        puts "    -num n    : Specify number of draw and read calls"
        puts "    -batch    : Execute test and quit"
        puts "    -format   : Specify image format (GL_RGB, GL_BGR, ...)"
        puts "    -type     : Specify image type (GL_UNSIGNED_BYTE)"
        ExitProg
    } elseif { $curArg eq "-size" } {
        incr i
        set gOpts(imgWidth)  [lindex $argv $i]
        incr i
        set gOpts(imgHeight) [lindex $argv $i]
        set gOpts(imgSize)   [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
        set gDemo(winWidth)  $gOpts(imgWidth)
        set gDemo(winHeight) $gOpts(imgHeight)
    } elseif { $curArg eq "-num" } {
        incr i
        set gOpts(numCalls)  [lindex $argv $i]
    } elseif { $curArg eq "-format" } {
        incr i
        set gOpts(curFormat) [lindex $argv $i]
        if { [lsearch $gOpts(formatsList) $gOpts(curFormat)] < 0 } {
            puts "Unknown format $gOpts(curFormat)"
            puts "Formats available: $gOpts(formatsList)"
            ExitProg
        }
    } elseif { $curArg eq "-type" } {
        incr i
        set gOpts(curType) [lindex $argv $i]
        if { [lsearch $gOpts(typesList) $gOpts(curType)] < 0 } {
            puts "Unknown type $gOpts(curType)"
            puts "Types available: $gOpts(typesList)"
            ExitProg
        }
    } elseif { $curArg eq "-batch" } {
        set gOpts(batch) true
    } else {
        puts "Ignoring unknown option $curArg"
    }
    incr i
}

CreateWindow

NewImage

PrintInfo [tcl3dOglGetInfoString]

if { $gOpts(batch) } {
    update
    TimedDrawReadPixels
    ExitProg
}
