# 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
}
}
|
