# Copyright:      2005-2024 Paul Obermeier (obermeier@tcl3d.org)
#
#                 See the file "Tcl3D_License.txt" for information on 
#                 usage and redistribution of this file, and for a
#                 DISCLAIMER OF ALL WARRANTIES.
#
# Module:         Tcl3D
# Filename:       imgViewer.tcl
#
# Author:         Paul Obermeier
#
# Description:    Tcl program to display images and stretch them in 
#                 realtime with the use of OpenGL textures.
#                 The images can be read from files in all formats supported by
#                 the Img extension. The stretched image may also be written
#                 out to an image file.

proc InitPackages { args } {
    global gPo

    foreach pkg $args {
        set retVal [catch {package require $pkg} gPo(ext,$pkg,version)]
        set gPo(ext,$pkg,avail) [expr !$retVal]
    }
}

InitPackages Img tcl3d

proc bgerror { msg } {
    tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
    exit
}

proc GetPackageInfo {} {
    global gPo

    set msgList {}
    foreach name [lsort [array names gPo "ext,*,avail"]] {
        set pkg [lindex [split $name ","] 1]
        lappend msgList [list $pkg $gPo(ext,$pkg,avail) $gPo(ext,$pkg,version)]
    }
    return $msgList
}

proc PkgInfo {} {
    set tw .tcl3dImgView:PkgInfoWin
    catch { destroy $tw }

    toplevel $tw
    wm title $tw "Package Information"
    wm resizable $tw true true

    frame $tw.fr0 -relief sunken -borderwidth 1
    grid  $tw.fr0 -row 0 -column 0 -sticky nwse
    set textId [tcl3dCreateScrolledText $tw.fr0 "" -wrap word -height 6]

    $textId insert end "Tcl version: [info patchlevel]\n" avail
    foreach pkgInfo [GetPackageInfo] {
        set msgStr "Package [lindex $pkgInfo 0]: [lindex $pkgInfo 2]\n"
        if { [lindex $pkgInfo 1] == 1} {
            set tag avail
        } else {
            set tag unavail
        }
        $textId insert end $msgStr $tag
    }
    $textId tag configure avail   -background lightgreen
    $textId tag configure unavail -background red
    $textId configure -state disabled

    # Create OK button
    frame $tw.fr1 -relief sunken -borderwidth 1
    grid  $tw.fr1 -row 1 -column 0 -sticky nwse
    button $tw.fr1.b -text "OK" -command "destroy $tw" -default active
    bind $tw.fr1.b <KeyPress-Return> "destroy $tw"
    pack $tw.fr1.b -side left -fill x -padx 2 -expand 1

    grid columnconfigure $tw 0 -weight 1
    grid rowconfigure    $tw 0 -weight 1

    bind $tw <Escape> "destroy $tw"
    bind $tw <Return> "destroy $tw"
    focus $tw
}

proc GLInfo {} {
    global gPo

    set tw .tcl3dImgView:GLInfoWin
    catch { destroy $tw }

    toplevel $tw
    wm title $tw "OpenGL Information"
    wm resizable $tw true true

    frame $tw.fr0 -relief sunken -borderwidth 1
    grid  $tw.fr0 -row 0 -column 0 -sticky nwse
    set textId [tcl3dCreateScrolledText $tw.fr0 "" -wrap word -height 5]

    foreach glInfo [tcl3dOglGetVersions gPo(toglWin)] {
        set msgStr "[lindex $glInfo 0]: [lindex $glInfo 1]\n"
        $textId insert end $msgStr avail
    }
    $textId tag configure avail -background lightgreen
    $textId configure -state disabled

    # Create OK button
    frame $tw.fr1 -relief sunken -borderwidth 1
    grid  $tw.fr1 -row 1 -column 0 -sticky nwse
    button $tw.fr1.b -text "OK" -command "destroy $tw" -default active
    bind $tw.fr1.b <KeyPress-Return> "destroy $tw"
    pack $tw.fr1.b -side left -fill x -padx 2 -expand 1

    grid columnconfigure $tw 0 -weight 1
    grid rowconfigure    $tw 0 -weight 1

    bind $tw <Escape> "destroy $tw"
    bind $tw <Return> "destroy $tw"
    focus $tw
}

proc CreateCallback { toglwin } {
    glClearColor 0.0 0.0 0.0 0.0
    glShadeModel GL_FLAT
    glEnable GL_DEPTH_TEST
 
    glPixelStorei GL_UNPACK_ALIGNMENT 1
 
    set ::texName [tcl3dVector GLuint 1]
    glGenTextures 1 $::texName
    glBindTexture GL_TEXTURE_2D [$::texName get 0]
}

proc DisplayCallback { toglwin } {
    global gPo

    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]

    if { ! [info exists ::vecImg] } {
        glFlush
        $::gPo(toglWin) swapbuffers
        return
    }
    glEnable GL_TEXTURE_2D
    glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL
    glBindTexture GL_TEXTURE_2D [$::texName get 0]

    set pw2 [expr $gPo(toglWidth)  * 0.5]
    set ph2 [expr $gPo(toglHeight) * 0.5]
    set nw2 [expr -1.0 * $pw2]
    set nh2 [expr -1.0 * $ph2]
    glBegin GL_QUADS
        glTexCoord2f 0.0 0.0 ; glVertex3f $nw2 $nh2  0.0
        glTexCoord2f 0.0 $gPo(texScaleT) ; glVertex3f $nw2 $ph2  0.0
        glTexCoord2f $gPo(texScaleS) $gPo(texScaleT) ; glVertex3f $pw2 $ph2  0.0
        glTexCoord2f $gPo(texScaleS) 0.0 ; glVertex3f $pw2 $nh2  0.0
    glEnd

    glFlush
    glDisable GL_TEXTURE_2D
    $::gPo(toglWin) swapbuffers
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    global gPo

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

    set gPo(toglWidth)  $w
    set gPo(toglHeight) $h
    set tz [expr -0.5 * $h / tan (30.0 /180.0 * 3.1415926535)]
    glViewport 0 0 $w $h
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 60.0 [expr double($w)/double($h)] 1.0 [expr -1.0 * $tz + 1.0]
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 $tz
    ImgInfo
}

proc poBmpData:hundred {} {
return {
#define hundred_width 16
#define hundred_height 16
static unsigned char hundred_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0xcc, 0x71, 0x2a, 0x8a, 0x29, 0x8a, 0x28, 0x8a,
   0x28, 0x8a, 0x28, 0x8a, 0x28, 0x8a, 0x28, 0x8a, 0x28, 0x8a, 0x28, 0x8a,
   0x28, 0x8a, 0xc8, 0x71, 0x00, 0x00, 0x00, 0x00};
}
} ; # End of proc poBmpData:hundred

proc poBmpData:open {} {
return {
#define open_width 16
#define open_height 16
static unsigned char open_bits[] = {
   0x00, 0x00, 0x00, 0x0e, 0x00, 0x51, 0x00, 0x60, 0x0e, 0x70, 0xf1, 0x07,
   0x01, 0x04, 0x01, 0x04, 0xe1, 0xff, 0x11, 0x40, 0x09, 0x20, 0x05, 0x10,
   0x03, 0x08, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00};
}
} ; # End of proc poBmpData:open

proc poBmpData:save {} {
return {
#define save_width 16
#define save_height 16
static unsigned char save_bits[] = {
   0x00, 0x00, 0xfe, 0x7f, 0x0a, 0x50, 0x0a, 0x70, 0x0e, 0x50, 0x0e, 0x50,
   0x0e, 0x50, 0x0a, 0x50, 0xf2, 0x4f, 0x02, 0x40, 0xf2, 0x5f, 0xf2, 0x53,
   0xf2, 0x53, 0xf2, 0x53, 0xfc, 0x7f, 0x00, 0x00};
}
} ; # End of proc poBmpData:save

proc poBmpData:info {} {
return {
#define info_width 16
#define info_height 16
static unsigned char info_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00,
   0xc0, 0x03, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
   0x80, 0x01, 0xe0, 0x07, 0x00, 0x00, 0x00, 0x00};
}
} ; # End of proc poBmpData:info

proc poMisc:FileSlashName { fileName } {
    global tcl_platform

    # Convert file or directory name to Unix slash notation
    set slashName [file join $fileName ""]
    # Use the long name on Windows. Looks nicer in file lists. :-)
    if { [string compare $tcl_platform(platform) "windows"] == 0 } {
        if { [file exists $slashName] } {
            set slashName [file attributes $slashName -longname]
        }
    }
    return $slashName
}

# Utility functions for implementation of a tool bar.

proc poToolbar:AddGroup { w } {
    global groupNum

    if { ![info exists groupNum]} {
        set groupNum 1
    }

    set newFrame $w.fr$groupNum
    frame $newFrame -relief raised -borderwidth 1
    pack  $newFrame -side left -fill y
    incr groupNum
    return $newFrame
}

proc poToolbar:AddButton { btnName bmpData cmd str args } {
    global groupNum

    if { ![info exists groupNum]} {
        poToolbar:Init
    }

    if { [string compare $bmpData ""] == 0 } {
        eval button $btnName -relief flat -takefocus 0 \
                             -command [list $cmd] $args
    } else {
        set img [image create bitmap -data $bmpData]
        eval button $btnName -image $img -relief flat -takefocus 0 \
                             -command [list $cmd] $args
    }
    tcl3dToolhelpAddBinding $btnName $str
    pack $btnName -side left
}

proc HelpProg {} {
    tk_messageBox -message "Simple image viewer powered by Tcl3D.\n\
                            Copyright 2006-2024 by Paul Obermeier.\n\n\
                            https://www.tcl3d.org" \
                           -type ok -icon info -title "$::gPo(appName)"
    focus .
}

proc AddMenuCmd { menu label acc cmd args } {
    eval {$menu add command -label $label -accelerator $acc -command $cmd} $args
}

proc AddRecentFiles { menuId delOldEntries } {
    global gPo

    if { $delOldEntries } {
        $menuId delete 0 end
    }
    for { set i 0 } { $i < [llength $gPo(recentFileList)] } { incr i } {
        set curFile [lindex $gPo(recentFileList) $i]
        AddMenuCmd $menuId $curFile "" [list ReadImg $curFile]
    }
}

proc ShowMainWin { title } {
    global tcl_platform gPo

    # Create the windows title.
    wm title . $title
    wm minsize . 100 100

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

    frame .fr.toolfr -relief sunken -borderwidth 1
    frame .fr.workfr -relief sunken -borderwidth 1
    pack .fr.toolfr -side top -fill x
    pack .fr.workfr -side top -fill both -expand 1

    frame .fr.workfr.imgfr  -relief raised -borderwidth 1
    frame .fr.workfr.infofr -relief sunken -borderwidth 1

    grid .fr.workfr.imgfr  -row 0 -column 0 -sticky news
    grid .fr.workfr.infofr -row 1 -column 0 -sticky news
    grid rowconfigure    .fr.workfr 0 -weight 1
    grid columnconfigure .fr.workfr 0 -weight 1

    label .fr.workfr.infofr.label -text Status -anchor w
    pack  .fr.workfr.infofr.label -fill x -in .fr.workfr.infofr

    frame .fr.workfr.imgfr.fr
    pack  .fr.workfr.imgfr.fr -expand 1 -fill both

    togl .fr.workfr.imgfr.fr.toglwin -width 800 -height 500 \
                                     -double true -depth true \
                                     -createcommand CreateCallback \
                                     -displaycommand DisplayCallback \
                                     -reshapecommand ReshapeCallback
    pack  .fr.workfr.imgfr.fr.toglwin -expand 1 -fill both
    set gPo(toglWin) .fr.workfr.imgfr.fr.toglwin

    bind $gPo(toglWin) <Double-1> "AskOpen"

    # Create menus File, Edit, View, Settings and Help
    set hMenu .fr.menufr
    menu $hMenu -borderwidth 2 -relief sunken
    $hMenu add cascade -menu $hMenu.file -label File      -underline 0
    $hMenu add cascade -menu $hMenu.help -label Help      -underline 0

    set fileMenu $hMenu.file
    menu $fileMenu -tearoff 0

    AddMenuCmd $fileMenu "Open ..."    "Ctrl+O" AskOpen

    $fileMenu add separator
    $fileMenu add cascade -label "Reopen"  -menu $fileMenu.reopen
    menu $fileMenu.reopen -tearoff 0
    AddRecentFiles $fileMenu.reopen true
    set gPo(reopenMenu) $fileMenu.reopen

    $fileMenu add separator
    AddMenuCmd $fileMenu "Save ..." "Ctrl+S" AskSave
    if { $::tcl_platform(os) ne "Darwin" } {
        $fileMenu add separator
        AddMenuCmd $fileMenu "Quit" "Ctrl+Q" ExitProg
    }

    bind . <Control-o>  AskOpen
    bind . <Control-s>  AskSave
    bind . <Control-q>  ExitProg
    if { [string compare $tcl_platform(os) "windows"] == 0 } {
        bind . <Alt-F4>     ExitProg
    }
    wm protocol . WM_DELETE_WINDOW "ExitProg"

    set helpMenu $hMenu.help
    menu $helpMenu -tearoff 0
    AddMenuCmd $helpMenu "About $gPo(appName) ..."     ""   HelpProg
    AddMenuCmd $helpMenu "About packages ..."          ""   PkgInfo
    AddMenuCmd $helpMenu "About OpenGL version..."     ""   GLInfo

    . configure -menu $hMenu

    # Add new toolbar group and associated buttons.
    set btnFrame [poToolbar:AddGroup .fr.toolfr]

    poToolbar:AddButton $btnFrame.open [poBmpData:open] AskOpen \
                           "Open image file (Ctrl+O)" -activebackground white
    poToolbar:AddButton $btnFrame.save [poBmpData:save] AskSave \
                           "Save image file (Ctrl+S)" -activebackground white

    # Add new toolbar group and associated buttons.
    set btnFrame [poToolbar:AddGroup .fr.toolfr]

    poToolbar:AddButton $btnFrame.reset [poBmpData:hundred] Reset  \
                        "Reset transformations (Ctrl+R)" -activebackground white
}

proc WriteInfoStr { str } {
    .fr.workfr.infofr.label configure -text $str
}

proc AskOpen {} {
    global gPo

    set fileTypes {
        { "All files" * }
    }
    set imgName [tk_getOpenFile -filetypes $fileTypes \
                                -initialdir $gPo(lastDir)]
    if { $imgName != "" } {
        set gPo(lastDir) [file dirname $imgName]
        ReadImg $imgName
    }
}

proc AskSave {} {
    global gPo

    set fileTypes {
        { "All files" * }
    }
    set imgName [tk_getSaveFile -filetypes $fileTypes \
                     -initialfile [file rootname $gPo(lastFile)] \
                     -initialdir $gPo(lastDir)]
    if { $imgName != "" } {
        set gPo(lastDir) [file dirname $imgName]
        SaveImg $imgName
    }
}

proc ImgInfo {} {
    global gPo

    WriteInfoStr [format "Width x Height: %d x %d (Original: %d x %d)" \
                 $gPo(toglWidth) $gPo(toglHeight) \
                 $gPo(imgOrigWidth) $gPo(imgOrigHeight)]
}

# Trigger loading of a default model file when running from the presentation framework.
proc StartAnimation {} {
    ReadImg [file join $::gPo(scriptDir) "rabbit.jpg"]
}

proc Cleanup {} {
    foreach w [winfo children .] {
        if { [string match ".tcl3dImgView:*" $w] } {
            destroy $w
        }
    }
    uplevel #0 unset gPo
}

proc ExitProg {} {
    exit
}

proc Reset { } {
    global gPo

    $gPo(toglWin) configure \
                  -width $gPo(imgOrigWidth) \
                  -height $gPo(imgOrigHeight)
    ReshapeCallback $gPo(toglWin)
    DisplayCallback $gPo(toglWin)
    ImgInfo
    update
}

proc GetBestSquare { w h } {
    if { $w > $h } {
        set val $w 
    } else {
        set val $h
    }
    set sqrList { 1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 }
    foreach sqr $sqrList {
        if { $val <= $sqr } {
            return $sqr
        }
    }
}

proc ReadImg { imgName } {
    global gPo

    if { [info exists ::vecImg] } {
        $::vecImg delete
    }
    set retVal [catch {set phImg [image create photo -file $imgName]} err1]
    if { $retVal != 0 } {
        WriteInfoStr "Failure reading image $imgName"
    } else {
        WriteInfoStr "Reading image $imgName ..."
        set w [image width  $phImg]
        set h [image height $phImg]
        set sqr [GetBestSquare $w $h]
        set gPo(imgOrigWidth)  $w
        set gPo(imgOrigHeight) $h
        set gPo(texScaleS) [expr double ($w) / $sqr]
        set gPo(texScaleT) [expr double ($h) / $sqr]
        set sqrPhoto [image create photo -width $sqr -height $sqr]
        $sqrPhoto copy $phImg -from 0 0 $w $h -to 0 [expr $sqr -$h]
        update
        set ::vecImg [tcl3dVectorFromPhoto $sqrPhoto 4]
        image delete $phImg
        image delete $sqrPhoto
        glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP
        glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP
        glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
        glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
        glTexImage2D GL_TEXTURE_2D 0 4 \
                     $sqr $sqr \
                     0 GL_RGBA GL_UNSIGNED_BYTE $::vecImg
        wm title . [format "%s (%s)" \
                 $gPo(appName) [file tail $imgName]]               
        ImgInfo
        $::gPo(toglWin) postredisplay
        set gPo(lastFile) [poMisc:FileSlashName $imgName]
        if { [lsearch -exact $gPo(recentFileList) $gPo(lastFile)] < 0 } {
            set gPo(recentFileList) [linsert $gPo(recentFileList) 0 $gPo(lastFile)]
            set gPo(recentFileList) [lrange $gPo(recentFileList) 0 \
                                      [expr $gPo(recentFileListLen) -1]]
        }
        AddRecentFiles $gPo(reopenMenu) true
    }
}

proc SaveImg { imgName } {
    global gPo

    set w $gPo(toglWidth)
    set h $gPo(toglHeight)
    set numChans 4
    set vec [tcl3dVector GLubyte [expr $w * $h * $numChans]]
    glReadPixels 0 0 $w $h GL_RGBA GL_UNSIGNED_BYTE $vec
    set ph [image create photo -width $w -height $h]
    tcl3dVectorToPhoto $vec $ph $w $h $numChans
    set fmt [string range [file extension $imgName] 1 end]
    $ph write $imgName -format $fmt
}

# Initialize some default values

set gPo(recentFileList) {}
set gPo(recentFileListLen) 10
set gPo(appName) "Tcl3D Image Viewer"
set gPo(scriptDir) [file dirname [info script]]
set gPo(lastDir) [pwd]
set gPo(lastFile) "Default"
set gPo(imgOrigWidth) -1
set gPo(imgOrigHeight) -1
set gPo(texScaleS) 1.0
set gPo(texScaleT) 1.0

ShowMainWin $gPo(appName)

if { $argc != 0 } {
    set fileName [lindex $argv 0]
    if { $fileName ne "" } {
        ReadImg $fileName
    }
}
