no display name and no $DISPLAY environment variable
while executing
"load /enadisk/commun/linux/local/ActiveTcl-8.6.11/lib/libtk8.6.so Tk"
("package ifneeded Tk 8.6.11" script)
invoked from within
"load /commun/linux/local/ActiveTcl-8.6.11/lib/Img1.4.6/libtkimgwindow1.4.6.so"
("package ifneeded img::window 1.4.6" script)
invoked from within
"package require img::window"
("package ifneeded Img 1.4.6" script)
invoked from within
"package require Img"
(in namespace eval "::request" script line 18)
invoked from within
"namespace eval ::request $script"
("::try" body line 12)
OUTPUT BUFFER:
#******************************************************************************
#
# Copyright: 2006-2010 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 -> demos
# Filename: Makefile
#
# Author: Paul Obermeier
#
# Description: Script to present the Tcl3D demos.
#
#******************************************************************************
package require Img
package require tcl3d 0.4.1
# Window size.
set gPres(winWidth) 640
set gPres(winHeight) 500
# Display mode.
set gPres(fullscreen) false
array set gPresInfoList {
num 5
0,str "Tcl3D intro" \
0,cmd "PresIntro" \
1,str "Tcl3D packages" \
1,cmd "PresPkgInfo" \
2,str "OpenGL information" \
2,cmd "PresGLInfo" \
3,str "OpenGL extensions" \
3,cmd "PresGLExtInfo" \
4,str "Cg profiles" \
4,cmd "PresCGProfileInfo" }
proc bmpData:exit {} {
return {
#define exit_width 16
#define exit_height 16
static unsigned char exit_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x0c, 0x30, 0x18, 0x18, 0x30, 0x0c, 0x60, 0x06,
0xc0, 0x03, 0x80, 0x01, 0xc0, 0x03, 0x60, 0x06, 0x30, 0x0c, 0x18, 0x18,
0x0c, 0x30, 0x04, 0x20, 0x00, 0x00, 0x00, 0x00};
}
}
set gPres(bmps,exit) [image create bitmap -data [bmpData:exit]]
proc bmpData: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};
}
}
set gPres(bmps,info) [image create bitmap -data [bmpData:info]]
proc bmpData:full {} {
return {
#define full_width 16
#define full_height 16
static char full_bits[] = {
0x00, 0x00, 0xfe, 0x7f, 0xfe, 0x7f, 0xfe, 0x7f, 0xfe, 0x7f, 0x06, 0x60,
0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60,
0x06, 0x60, 0x06, 0x60, 0xfe, 0x7f, 0xfe, 0x7f};
}
}
set gPres(bmps,full) [image create bitmap -data [bmpData:full]]
proc bmpData:help {} {
return {
#define questionmark_width 16
#define questionmark_height 16
static char questionmark_bits[] = {
0x80, 0x01, 0x40, 0x02, 0x20, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x02,
0x80, 0x01, 0x40, 0x00, 0x20, 0x00, 0x20, 0x00, 0x20, 0x04, 0x40, 0x02,
0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x80, 0x01};
}
}
set gPres(bmps,help) [image create bitmap -data [bmpData:help]]
proc bmpData:demo {} {
return {
#define demo_width 16
#define demo_height 16
static unsigned char demo_bits[] = {
0xfe, 0x0f, 0x02, 0x18, 0x02, 0x28, 0x02, 0x78, 0x02, 0x40, 0x02, 0x40,
0x02, 0x40, 0x02, 0x40, 0xe2, 0x47, 0x02, 0x40, 0xe2, 0x47, 0x02, 0x40,
0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f, 0x00, 0x00};
}
}
set gPres(bmps,demo) [image create bitmap -data [bmpData:demo]]
rename ::exit ::presentationExit
proc exit { { status 0 } } {
StopRunningAnimation
set answer [tk_messageBox -icon question -type yesno \
-title "Exit confirmation" \
-message "Do you want to quit the presentation?"]
if { $answer eq "yes" } {
::presentationExit
}
set ::gExit 0
}
# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
proc LoadFileIntoTextWidget { w fileName } {
set retVal [catch {open $fileName r} fp]
if { $retVal != 0 } {
error "Could not open file $fileName for reading."
}
$w delete 1.0 end
while { ![eof $fp] } {
$w insert end [read $fp 2048]
}
close $fp
}
proc TextWidgetToFile { w fileName } {
set fileTypes {
{"Tcl files" ".tcl"}
{"All files" "*"} }
if { [info exists ::starkit::topdir] && \
[file isdirectory $::starkit::topdir] } {
set dumpDir [file dirname $::starkit::topdir]
} else {
set dumpDir [file dirname $fileName]
}
set dumpFile [file tail $fileName]
set saveName [tk_getSaveFile -filetypes $fileTypes \
-initialfile $dumpFile -initialdir $dumpDir \
-title "Save Tcl script to file system"]
if { $saveName != "" } {
set retVal [catch {open $saveName w} fp]
if { $retVal != 0 } {
error "Could not open file $saveName for writing."
}
puts -nonewline $fp [$w get 1.0 end]
close $fp
}
}
proc AddMenuCmd { menu label acc cmd } {
$menu add command -label $label -accelerator $acc -command $cmd
}
proc ShowEditor { fileName } {
global gPres
# Font to be used in the text widget.
set textFont {-family {Courier} -size 10}
if { ! [info exists gPres(editCount)] } {
set gPres(editCount) 0
} else {
incr gPres(editCount)
}
set titleStr "Tcl3D script: [file tail $fileName]"
set tw ".poTextEdit_$gPres(editCount)"
toplevel $tw
wm title $tw $titleStr
ttk::frame $tw.workfr -relief sunken -borderwidth 1
pack $tw.workfr -side top -fill both -expand 1
set hMenu $tw.menufr
menu $hMenu -borderwidth 2 -relief sunken
$hMenu add cascade -menu $hMenu.file -label File -underline 0
set textId [tcl3dCreateScrolledText $tw.workfr "$fileName" -font $textFont]
set fileMenu $hMenu.file
menu $fileMenu -tearoff 0
AddMenuCmd $fileMenu "Save as ..." "Ctrl+S" "TextWidgetToFile $textId [list $fileName]"
AddMenuCmd $fileMenu "Close" "Ctrl+W" "destroy $tw"
bind $tw "TextWidgetToFile $textId [list $fileName]"
bind $tw "destroy $tw"
bind $tw "destroy $tw"
wm protocol $tw WM_DELETE_WINDOW "destroy $tw"
$tw configure -menu $hMenu
LoadFileIntoTextWidget $textId $fileName
$textId configure -state disabled -cursor top_left_arrow
focus $tw
}
proc OpenContextMenu { lb x y } {
global gPres
StopRunningAnimation
set w .poContextMenu
catch { destroy $w }
menu $w -tearoff false -disabledforeground white
set noSel [llength [$lb curselection]]
if { $noSel != 0 } {
set curInd [lindex [$lb curselection] 0]
set fileName [$lb get $curInd]
set filePath $gPres(demoDir,$curInd)
set fullName [file join $filePath $fileName]
if { $::tcl_platform(platform) eq "windows" || \
$::tcl_platform(platform) eq "unix" } {
$w add command -label "ScreenShot (Window -> File)" \
-command "ScreenShot Window [list $fullName]"
}
$w add command -label "ScreenShot (Widgets -> File)" \
-command "ScreenShot Widget [list $fullName]"
$w add command -label "ScreenShot (Togl -> File)" \
-command "ScreenShot Togl [list $fullName]"
if { [string compare $::tcl_platform(platform) "windows"] == 0 } {
$w add command -label "ScreenShot (Window -> Clipboard)" \
-command "ScreenShot Window"
$w add command -label "ScreenShot (Widgets -> Clipboard)" \
-command "ScreenShot Widget"
$w add command -label "ScreenShot (Togl -> Clipboard)" \
-command "ScreenShot Togl"
}
$w add separator
$w add command -label "View script" \
-command "ShowEditor [list $fullName]"
} else {
set menuTitle "Nothing selected"
$w add command -label "$menuTitle" -state disabled -background "#303030"
}
tk_popup $w $x $y
}
proc StopRunningAnimation {} {
if { [info commands "StopAnimation"] eq "StopAnimation" } {
StopAnimation
}
}
proc KillRunningAnimation {} {
StopRunningAnimation
set evList [after info]
foreach ev $evList {
if { [string match "after*" $ev] } {
after cancel $ev
}
}
if { [info commands "Cleanup"] eq "Cleanup" } {
Cleanup
}
catch { unset ::gDemo) }
}
proc TryToStartAnimation { name } {
AddMenuBindings
puts ""
if { $name eq "" } {
set msgStr "inline script"
} else {
set msgStr [file tail $name]
}
puts "Available bindings for $msgStr"
PrintBindings .
PrintBindings .fr.toglwin
PrintBindings .fr.togl.toglwin
if { [info commands "StartAnimation"] eq "StartAnimation" } {
# Before starting the new script via the StartAnimation command,
# check, if there are any left-over events (typically after idles),
# and wait until they are finished.
set evList [after info]
set afterRunning false
foreach ev $evList {
if { [string match "after*" $ev] } {
set afterRunning true
break
}
}
if { ! $afterRunning } {
StartAnimation
}
} else {
proc StartAnimation {} {
}
}
}
proc AddMenuBindings {} {
global gPres
set frBttn $gPres(widList,frBttn)
bind . "$frBttn.info invoke"
bind . "$frBttn.help invoke"
bind . "$frBttn.demo invoke"
bind . "$frBttn.full invoke"
bind . "$frBttn.exit invoke"
bind . "$frBttn.exit invoke"
}
proc DeleteBindings { w } {
if { [winfo exists $w] } {
foreach b [bind $w] {
bind $w $b ""
}
}
}
proc PrintBindings { w } {
if { [winfo exists $w] } {
foreach b [lsort [bind $w]] {
puts "$w $b: [bind $w $b]"
}
}
}
proc DeleteAnimationCmds {} {
if { [info commands "StartAnimation"] eq "StartAnimation" } {
rename ::StartAnimation {}
}
if { [info commands "StopAnimation"] eq "StopAnimation" } {
rename ::StopAnimation {}
}
if { [info commands "Cleanup"] eq "Cleanup" } {
rename ::Cleanup {}
}
# Get all bindings and delete them to avoid unwanted actions.
DeleteBindings .
DeleteBindings .fr.toglwin
DeleteBindings .fr.togl.toglwin
}
proc PresIntro {} {
lappend retVal "title \"Tcl3D intro\""
lappend retVal "speed 1"
lappend retVal "angle -50"
lappend retVal "align center"
lappend retVal "color 0.7 0.0 0.0"
lappend retVal "line \"Tcl3D\""
lappend retVal "line \"Doing 3D with Tcl\""
lappend retVal "line \"\""
lappend retVal "color 0.8 0.8 0.8"
lappend retVal "line \"is brought to you by\""
lappend retVal "line \"Paul Obermeier\""
lappend retVal "line \"\""
lappend retVal "color 0.0 0.8 0.0"
lappend retVal "line \"Get it from\""
lappend retVal "line \"www.tcl3d.org\""
return [join $retVal "\n"]
}
proc PresPkgInfo {} {
lappend retVal "title \"Tcl3D packages\""
lappend retVal "fonttype 2d"
lappend retVal "speed 1.5"
lappend retVal "angle 0"
lappend retVal "color 0.8 0.8 0.8"
lappend retVal "align center"
lappend retVal "Loaded Tcl3D packages"
lappend retVal "using Tcl [info patchlevel]"
lappend retVal ""
lappend retVal "align left"
lappend retVal "color 0.2 0.8 0.2"
set vers [package version tcl3d]
set msgStr "tcl3d: $vers"
lappend retVal $msgStr
foreach pkgInfo [tcl3dGetPackageInfo] {
set pkg [lindex $pkgInfo 0]
set avail [lindex $pkgInfo 1]
set pkgVer [lindex $pkgInfo 2]
set libVer [lindex $pkgInfo 3]
if { ! $avail } {
set pkgVer "Not available"
}
if { $libVer ne "" } {
set msgStr "$pkg: $pkgVer ($libVer)"
} else {
set msgStr "$pkg: $pkgVer"
}
if { $avail } {
lappend retVal "color 0.0 1.0 0.0"
} else {
lappend retVal "color 1.0 0.0 0.0"
}
lappend retVal $msgStr
}
return [join $retVal "\n"]
}
proc PresGLInfo {} {
lappend retVal "title \"OpenGL information\""
lappend retVal "fonttype 2d"
lappend retVal "speed 1.0"
lappend retVal "angle 0"
lappend retVal "color 0.8 0.8 0.8"
lappend retVal "align center"
lappend retVal "Information about the OpenGL driver"
lappend retVal ""
lappend retVal "align left"
lappend retVal "color 0.2 0.8 0.2"
foreach glInfo [tcl3dOglGetVersions] {
set msgStr "[lindex $glInfo 0]: [lindex $glInfo 1]"
lappend retVal $msgStr
}
return [join $retVal "\n"]
}
proc PresGLExtInfo {} {
set numExt 0
foreach glInfo [tcl3dOglGetExtensions] {
set numExt [expr $numExt + [llength [lindex $glInfo 1]]]
}
lappend retVal "title \"OpenGL extensions\""
lappend retVal "fonttype 2d"
lappend retVal "speed 2.0"
lappend retVal "angle 0"
lappend retVal "align center"
if { $numExt == 0 } {
lappend retVal "color 1.0 0.0 0.0"
lappend retVal "No OpenGL extensions available"
} else {
lappend retVal "color 0.8 0.8 0.8"
lappend retVal "$numExt OpenGL extensions available"
lappend retVal ""
lappend retVal "align left"
set r 0.5
foreach glInfo [tcl3dOglGetExtensions] {
foreach ext [lsort [lindex $glInfo 1]] {
lappend retVal "color $r 1.0 $r"
lappend retVal $ext
set r [expr $r - 0.05]
if { $r < 0.0 } {
set r 0.5
}
}
}
}
return [join $retVal "\n"]
}
proc PresCGProfileInfo {} {
if { [tcl3dCgGetVersion] eq "" } {
set profileList [list]
} else {
set profileList [tcl3dCgGetProfileList]
}
lappend retVal "title \"Cg profiles\""
lappend retVal "fonttype 2d"
lappend retVal "speed 1.0"
lappend retVal "angle -30"
lappend retVal "color 0.8 0.8 0.8"
lappend retVal "align center"
if { [llength $profileList] == 0 } {
lappend retVal "color 1.0 0.0 0.0"
lappend retVal "No Cg profiles available"
} else {
lappend retVal "Available Cg profiles"
lappend retVal ""
lappend retVal "align left"
foreach { profile avail } $profileList {
if { $avail } {
lappend retVal "color 0.0 1.0 0.0"
lappend retVal "+ $profile"
} else {
lappend retVal "color 1.0 0.0 0.0"
lappend retVal "- $profile"
}
}
}
return [join $retVal "\n"]
}
proc SelectInstDir { msgStr } {
global gPres
if { ! [info exists ::starkit::topdir] } {
return ""
}
if { ! [info exists gPres(curInstDir)] } {
set gPres(curInstDir) [file dirname $::starkit::topdir]
}
set tmpDir [tk_chooseDirectory -initialdir $gPres(curInstDir) \
-mustexist 0 -title $msgStr]
if { $tmpDir ne "" } {
if { ! [file isdirectory $tmpDir] } {
file mkdir $tmpDir
}
set gPres(curInstDir) $tmpDir
return $tmpDir
}
return ""
}
proc InstCmd { writeCmd msgStr } {
StopRunningAnimation
set instDir [SelectInstDir $msgStr]
if { $instDir ne "" } {
eval $writeCmd [list $instDir]
}
}
proc ShowInfoList {} {
global gPres gPresInfoList
if { ! [info exists gPres(widList,lbInfo)] || \
! [winfo exists $gPres(widList,lbInfo)] } {
catch { destroy $gPres(widList,varFrame) }
ttk::frame $gPres(widList,varFrame)
pack $gPres(widList,varFrame) -side top -anchor w -fill x
set gPres(widList,lbInfo) [ttk::labelframe $gPres(widList,varFrame).frInf \
-text "Information"]
pack $gPres(widList,varFrame).frInf -expand 1 -fill both -side top \
-padx 3 -pady 5 -ipadx 2 -ipady 2
for { set i 0 } { $i < $gPresInfoList(num) } { incr i } {
ttk::radiobutton $gPres(widList,lbInfo).rb$i \
-value $i -style Toolbutton \
-text $gPresInfoList($i,str) \
-command "ShowInfoByInd $i"
pack $gPres(widList,lbInfo).rb$i -expand 1 -fill x \
-side top -anchor w
}
if { [info exists ::starkit::topdir] } {
ttk::labelframe $gPres(widList,varFrame).frInst -text "Installation"
pack $gPres(widList,varFrame).frInst -expand 1 -fill both -side top \
-padx 3 -pady 5 -ipadx 2 -ipady 2
set msgStr "Choose location for Tcl3D package folder"
ttk::button $gPres(widList,varFrame).frInst.b1 \
-text "Install Tcl packages" \
-command "InstCmd writeTcl3dPkgs [list $msgStr]"
set msgStr "Choose location for demo folder"
ttk::button $gPres(widList,varFrame).frInst.b2 \
-text "Install Tcl3D demos" \
-command "InstCmd writeTcl3dDemos [list $msgStr]"
set msgStr "Choose location for external libs folder"
ttk::button $gPres(widList,varFrame).frInst.b3 \
-text "Install external libraries" \
-command "InstCmd writeTcl3dExtLibs [list $msgStr]"
pack $gPres(widList,varFrame).frInst.b1 \
$gPres(widList,varFrame).frInst.b2 \
$gPres(widList,varFrame).frInst.b3 \
-expand 1 -fill x -side top -anchor w
}
}
$gPres(widList,lbInfo).rb0 invoke
}
proc ShowInfoByInd { ind } {
global gPres gPresInfoList
set cmdName $gPresInfoList($ind,cmd)
ShowText "" [$cmdName]
}
proc ShowText { msgFile msgStr } {
global gPres
KillRunningAnimation
DeleteAnimationCmds
destroy .fr
uplevel #0 source [list [file join $gPres(toolDir) "textdisplay.tcl"]]
if { $msgStr ne "" } {
uplevel #0 EvalMsgStr [list $msgStr]
}
if { $msgFile ne "" } {
uplevel #0 EvalMsgFile [list [file join $gPres(toolDir) $msgFile]]
}
TryToStartAnimation $msgFile
}
proc ShowDemoList { { rootDir "" } } {
global gPres
if { ! [info exists gPres(widList,lbDemoDirs)] || \
! [winfo exists $gPres(widList,lbDemoDirs)] } {
catch { destroy $gPres(widList,varFrame) }
ttk::frame $gPres(widList,varFrame)
pack $gPres(widList,varFrame) -side top -anchor w -fill x
ttk::frame $gPres(widList,varFrame).frLb1
ttk::frame $gPres(widList,varFrame).frLb2
pack $gPres(widList,varFrame).frLb1 $gPres(widList,varFrame).frLb2 \
-expand 1 -fill both -side top
set gPres(widList,lbDemoLabel) [ttk::label $gPres(widList,varFrame).frLb1.l]
set gPres(widList,lbDemoDirs) [listbox $gPres(widList,varFrame).frLb1.lb \
-height 5 -selectmode single \
-highlightcolor green -highlightthickness 2]
pack $gPres(widList,lbDemoLabel) $gPres(widList,lbDemoDirs) \
-side top -expand 1 -fill both
set gPres(widList,lbDemoFiles) [tcl3dCreateScrolledListbox \
$gPres(widList,varFrame).frLb2 "Demo scripts" \
-height 20 -selectmode single \
-highlightcolor green -highlightthickness 2]
}
if { $rootDir eq "" } {
set rootDir $gPres(toolDir)
set addParent false
} else {
set curInd [lindex [$gPres(widList,lbDemoDirs) curselection] 0]
set curDir [$gPres(widList,lbDemoDirs) get [lindex $curInd 0]]
set rootDir [file normalize [file join $gPres(curDemoDir) $curDir]]
if { $rootDir eq [file normalize $gPres(toolDir)] } {
set addParent false
} else {
set addParent true
}
}
$gPres(widList,lbDemoDirs) delete 0 end
$gPres(widList,lbDemoFiles) delete 0 end
set gPres(curDemoDir) $rootDir
if { $addParent } {
$gPres(widList,lbDemoDirs) insert end ".."
}
set dirCont [lsort [glob -nocomplain -dir $rootDir *]]
# First check, if a file named "leaf" exists in current directory.
# If yes, then we don't show sub-directories in the directory listing,
# but display the script files of theses sub-directories directly in the
# file listing. This behaviour has been implemented to keep the structure
# of existing demo tutorials (ex. NeHe's), but avoid having the user to
# click the directory structure up and down.
set curFile 0
set curDir 0
set isLeaf false
foreach f $dirCont {
set sf [file tail $f]
if { $sf eq "leaf" } {
set isLeaf true
break
}
}
foreach f $dirCont {
set sf [file tail $f]
if { [file isdirectory $f] } {
if { $isLeaf } {
set dirCont [lsort [glob -nocomplain -dir $f *.tcl]]
foreach subFile $dirCont {
set shortSubFile [file tail $subFile]
$gPres(widList,lbDemoFiles) insert end $shortSubFile
set gPres(demoDir,$curFile) $f
incr curFile
}
} else {
if { ! [string equal -nocase "CVS" [file tail $f]] } {
$gPres(widList,lbDemoDirs) insert end $sf
incr curDir
}
}
} elseif { [string match "*.tcl" $f] && $addParent } {
# Show all Tcl scripts in the file listbox, except the scripts at
# the top level, which are responsible for the presentation itself.
$gPres(widList,lbDemoFiles) insert end $sf
set gPres(demoDir,$curFile) [file dirname $f]
incr curFile
}
}
if { $addParent } {
set msgStr [file tail $rootDir]
incr curDir
} else {
set msgStr "Categories"
}
$gPres(widList,lbDemoLabel) configure -text $msgStr
$gPres(widList,lbDemoDirs) configure -height $curDir
bind $gPres(widList,lbDemoFiles) <> "ShowDemoByListbox"
bind $gPres(widList,lbDemoDirs) <> "ShowDemoList Sel"
bind $gPres(widList,lbDemoFiles) <> \
{OpenContextMenu [winfo containing %X %Y] %X %Y}
}
proc ShowDemoByListbox {} {
global gPres
set curInd [lindex [$gPres(widList,lbDemoFiles) curselection] 0]
set fileName [$gPres(widList,lbDemoFiles) get [lindex $curInd 0]]
set filePath $gPres(demoDir,$curInd)
ShowDemo $fileName $filePath
}
proc ShowDemo { demoFile demoPath } {
global gPres
KillRunningAnimation
DeleteAnimationCmds
destroy .fr
catch { destroy .tcl3dOutputConsole }
uplevel #0 source [list [file join $demoPath $demoFile]]
TryToStartAnimation $demoFile
}
proc ShowPoSoftLogo {} {
StopRunningAnimation
tcl3dLogoShowPoSoft "Tcl3D Version 0.5.0" \
"Copyright 2005-2010 Paul Obermeier" ""
}
proc ShowTclLogo {} {
StopRunningAnimation
tcl3dLogoShowTcl Tk Img
}
proc ShowHelpList {} {
global gPres
if { ! [info exists gPres(widList,lbHelp)] || \
! [winfo exists $gPres(widList,lbHelp)] } {
catch { destroy $gPres(widList,varFrame) }
ttk::frame $gPres(widList,varFrame)
pack $gPres(widList,varFrame) -side top -anchor w -fill x
ttk::labelframe $gPres(widList,varFrame).frHelp -text "Help"
pack $gPres(widList,varFrame).frHelp -expand 1 -fill both -side top \
-padx 3 -pady 5 -ipadx 2 -ipady 2
ttk::button $gPres(widList,varFrame).frHelp.b1 \
-text "About Tcl3D" -command "ShowPoSoftLogo"
ttk::button $gPres(widList,varFrame).frHelp.b2 \
-text "About Tcl" -command "ShowTclLogo"
pack $gPres(widList,varFrame).frHelp.b1 \
$gPres(widList,varFrame).frHelp.b2 \
-expand 1 -fill x -side top -anchor w
set gPres(widList,lbHelp) [ttk::labelframe $gPres(widList,varFrame).frDocu \
-text "Documentation"]
pack $gPres(widList,lbHelp) -expand 1 -fill both -side top \
-padx 3 -pady 5 -ipadx 2 -ipady 2
set dirCont [lsort [glob -nocomplain -dir $gPres(toolDir) *.txt]]
set i 0
foreach f $dirCont {
set sf [file rootname [file tail $f]]
ttk::radiobutton $gPres(widList,lbHelp).rb$i \
-value $i -style Toolbutton \
-text $sf -command "ShowHelpByName [list $f]"
pack $gPres(widList,lbHelp).rb$i -expand 1 -fill x \
-side top -anchor w
incr i
}
}
$gPres(widList,lbHelp).rb0 invoke
}
proc ShowHelpByName { fileName } {
global gPres
set filePath [file join $gPres(toolDir) $fileName]
lappend retVal "title \"Tcl3D help: [file rootname [file tail $fileName]]\""
lappend retVal "fonttype tex"
lappend retVal "speed 1.0"
lappend retVal "angle 0"
lappend retVal "color 1 1 1"
lappend retVal "align left"
ShowText $filePath [join $retVal "\n"]
}
proc SetFullScreenMode { win } {
set sh [winfo screenheight $win]
set sw [winfo screenwidth $win]
wm minsize $win $sw $sh
wm maxsize $win $sw $sh
set fmtStr [format "%dx%d+0+0" $sw $sh]
wm geometry $win $fmtStr
wm overrideredirect $win 1
focus -force $win
}
proc SetWindowMode { win w h } {
set sh [winfo screenheight $win]
set sw [winfo screenwidth $win]
wm minsize $win 10 10
wm maxsize $win $sw $sh
set fmtStr [format "%dx%d+0+25" $w $h]
wm geometry $win $fmtStr
wm overrideredirect $win 0
focus -force $win
}
# Toggle between windowing and fullscreen mode.
proc ToggleWindowMode {} {
global gPres
StopRunningAnimation
if { $gPres(fullscreen) } {
SetFullScreenMode .
set gPres(fullscreen) false
} else {
SetWindowMode . $gPres(winWidth) $gPres(winHeight)
set gPres(fullscreen) true
}
}
# 3 dummy callback functions for first instantiation of Togl widget.
proc CreateCallback { toglwin } {
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
}
proc DisplayCallback { toglwin } {
}
proc ScreenShot { type { fileName "" } } {
global gPres
. configure -cursor watch
update
if { $fileName ne "" } {
# Create a name on the file system, if running from within a Starpack.
set fileName [tcl3dGenExtName $fileName]
set imgName [file rootname $fileName]
set imgExt ".jpg"
set imgFmt "JPEG"
set imgOpt "-quality 95"
append imgName $imgExt
if { $type == "Window" } {
after 300
tcl3dWindow2File $imgName $imgFmt $imgOpt
} elseif { $type == "Widget" } {
tcl3dWidget2File . $imgName "*Console*" $imgFmt $imgOpt
} else {
tcl3dWidget2File .fr.toglwin $imgName "" $imgFmt $imgOpt
}
puts "Screenshot written to: $imgName"
} else {
# Put the screenshot into the clipboard.
if { $type == "Window" } {
after 300
tcl3dWindow2Clipboard
} else {
if { $type == "Widget" } {
set phImg [tcl3dWidget2Img . "*Console*"]
} else {
set phImg [tcl3dWidget2Img .fr.toglwin]
}
tcl3dImg2Clipboard $phImg
image delete $phImg
}
}
. configure -cursor top_left_arrow
}
proc ExitProg {} {
exit
}
# Create the OpenGL window and some Tk helper widgets.
proc CreateWindow {} {
global gPres
wm title . "Tcl3D Presentation"
set frTogl [ttk::frame .fr -relief sunken -borderwidth 2]
set frMenu [ttk::frame .frMenu]
pack $frTogl -side left
pack $frMenu -side left -fill y
set frBttn [ttk::frame $frMenu.frPresBttn]
set frMode [ttk::frame $frMenu.frModeBttn]
set gPres(widList,frBttn) $frBttn
set gPres(widList,varFrame) [ttk::frame $frMenu.frPresList]
pack $frBttn $frMode -side top -anchor w -fill x
pack $gPres(widList,varFrame) -side top -anchor w -fill x
ttk::radiobutton $frBttn.info -image $gPres(bmps,info) \
-value info -command "ShowInfoList" \
-variable gPres(state) -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frBttn.info "Information and installation (Shift-F1)"
ttk::radiobutton $frBttn.help -image $gPres(bmps,help) \
-value help -command "ShowHelpList" \
-variable gPres(state) -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frBttn.help "Help and documentation (Shift-F2)"
ttk::radiobutton $frBttn.demo -image $gPres(bmps,demo) \
-value demo -command "ShowDemoList" \
-variable gPres(state) -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frBttn.demo "Demos and tutorials (Shift-F3)"
pack $frBttn.info $frBttn.help $frBttn.demo -side left -expand 1 -fill x
ttk::checkbutton $frBttn.full -image $gPres(bmps,full) \
-command ToggleWindowMode -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frBttn.full "Toggle fullscreen mode (Shift-F4)"
ttk::checkbutton $frBttn.exit -image $gPres(bmps,exit) \
-command ExitProg -variable gExit -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frBttn.exit "Quit Tcl3D presentation (Shift-F5)"
pack $frBttn.full $frBttn.exit -side left -expand 1 -fill x
ttk::radiobutton $frMode.normal -text "Normal" \
-value normal -command "tcl3dOglSetNormalMode" \
-variable gOglMode -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frMode.normal "Set OpenGL normal execution mode"
ttk::radiobutton $frMode.safe -text "Safe" \
-value safe -command "tcl3dOglSetSafeMode" \
-variable gOglMode -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frMode.safe "Set OpenGL safe execution mode"
ttk::radiobutton $frMode.debug -text "Debug" \
-value debug -command "tcl3dOglSetDebugMode" \
-variable gOglMode -takefocus 0 -style Toolbutton
tcl3dToolhelpAddBinding $frMode.debug "Set OpenGL debug execution mode"
pack $frMode.normal $frMode.safe $frMode.debug -side left -expand 1 -fill x
# Create Our OpenGL Window
togl $frTogl.toglwin -width 640 -height 500 \
-double true -depth true \
-createproc CreateCallback \
-reshapeproc ReshapeCallback \
-displayproc DisplayCallback
pack $frTogl.toglwin -expand 1 -fill both
# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
AddMenuBindings
# Disable the standard arrow events of a listbox.
# Put the default bindings for these events onto a Shift-Arrow binding.
# This allows most demos using the arrows for moving something around,
# being effective, but also allows us to switch between demos and categories
# with Tab, Space and Shift-Arrow keys.
bind Listbox ""
bind Listbox "tk::ListboxUpDown %W -1 ; break"
bind Listbox ""
bind Listbox "tk::ListboxUpDown %W 1 ; break"
bind Listbox ""
bind Listbox "%W xview scroll -1 units ; break"
bind Listbox ""
bind Listbox "%W xview scroll 1 units ; break"
bind Listbox ""
bind Listbox ""
bind Listbox ""
bind Listbox ""
}
set gPres(state) "info"
set gOglMode "safe"
tcl3dOglSetSafeMode
tcl3dAddEvents
CreateWindow
# Check, if we are running in a Starkit or Starpack.
if { [info exists ::starkit::topdir] && \
[file isdirectory $::starkit::topdir] } {
set gPres(toolDir) [file join $::starkit::topdir "demos"]
} else {
set gPres(toolDir) [file dirname [info script]]
}
ToggleWindowMode
update
ShowInfoList