# 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: modelViewer.tcl
#
# Author: Paul Obermeier
#
# Description: Tcl program to display 3D model files in all formats supported
# by the Tcl3D extension.
# Set next variable to 1, if you want to source this file and use a separate
# toplevel, instead of integrating into the widget hierarchy.
set gUseToplevel 0
# Enable azimuth and elevation sliders.
set gShowSliders 1
# Set next variable to 1, if your graphic supports multisampling.
set gUseMultisampling 0
# Set next variable to 1, if you want screen rectangle mode enabled.
set gUseScreenRect 0
# Enable the use of angles instead of trackball matrix.
set gPo(useAngles) 1
if { $::gUseToplevel } {
set gRoot .po
set gRootFr .po.fr
} else {
set gRoot .
set gRootFr .fr
}
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
set gTextureId [tcl3dVector GLuint 1]
set g_ScriptName [info script]
set g_ScriptDir [file dirname [info script]]
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 poWin:CreateScrolledWidget { wType w titleStr args } {
if { [winfo exists $w.par] } {
destroy $w.par
}
frame $w.par
if { [string compare $titleStr ""] != 0 } {
label $w.par.label -text "$titleStr"
}
eval { $wType $w.par.widget \
-xscrollcommand "$w.par.xscroll set" \
-yscrollcommand "$w.par.yscroll set" } $args
scrollbar $w.par.xscroll -command "$w.par.widget xview" -orient horizontal
scrollbar $w.par.yscroll -command "$w.par.widget yview" -orient vertical
set rowNo 0
if { [string compare $titleStr ""] != 0 } {
set rowNo 1
grid $w.par.label -sticky ew -columnspan 2
}
grid $w.par.widget $w.par.yscroll -sticky news
grid $w.par.xscroll -sticky ew
grid rowconfigure $w.par $rowNo -weight 1
grid columnconfigure $w.par 0 -weight 1
pack $w.par -side top -fill both -expand 1
return $w.par.widget
}
proc poWin:CreateScrolledText { w titleStr args } {
return [eval {poWin:CreateScrolledWidget text $w $titleStr} $args ]
}
proc poWin:CreateScrolledListbox { w titleStr args } {
return [eval {poWin:CreateScrolledWidget listbox $w $titleStr} $args ]
}
proc poMisc:Max { a b } {
if { $a > $b } {
return $a
} else {
return $b
}
}
proc PkgInfo {} {
set tw .tcl3dModelView: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 [poWin:CreateScrolledText $tw.fr0 "" -wrap word -height 2]
$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 .tcl3dModelView: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 4]
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 ShortcutInfo {} {
set tw .tcl3dModelView:ShortcutInfoWin
catch { destroy $tw }
toplevel $tw
wm title $tw "Shortcut Information"
wm resizable $tw true true
frame $tw.fr0 -relief sunken -borderwidth 1
grid $tw.fr0 -row 0 -column 0 -sticky nwse
set textId [poWin:CreateScrolledText $tw.fr0 "" -wrap none -height 9]
$textId insert end "Key l: Toggle line and flat shaded drawing\n"
$textId insert end "Key f: Toggle showing backfaces as faces or lines\n"
if { $::gUseMultisampling } {
$textId insert end "Key m: Toggle drawing with/without multisampling\n"
}
if { $::gUseScreenRect } {
$textId insert end "Key b: Toggle drawing the enclosing screen rect\n"
}
$textId insert end "Key r: Reset translations and rotations\n"
$textId insert end "\n"
$textId insert end "LeftMouseButton : Rotate object\n"
$textId insert end "RightMouseButton : Zoom in and out\n"
$textId insert end "Ctrl + RightMouseButton : Move up and down\n"
$textId insert end "Shift + RightMouseButton: Move left and right\n"
$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 AddMenuCmd { menu label acc cmd args } {
eval {$menu add command -label $label -accelerator $acc -command $cmd} $args
}
proc AddMenuCheck { menu label acc var cmd args } {
eval {$menu add checkbutton -label $label -accelerator $acc \
-variable $var -command $cmd} $args
}
proc MoveStart { win x y } {
set ::mouseX $x
set ::mouseY $y
}
proc MoveCont { win x y axis } {
global gPo
set diff [expr $y - $::mouseY]
set gPo($axis) [expr $gPo($axis) + 0.1 * $diff]
set ::mouseX $x
set ::mouseY $y
$win postredisplay
}
proc MoveEnd { win x y } {
$win postredisplay
}
proc ShowMainWin { title } {
global tcl_platform gPo gRoot gRootFr
if { $::gUseToplevel } {
if { [file tail $::g_ScriptName] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then destroy
# default toplevel.
wm withdraw .
}
toplevel $gRoot
}
# Create the windows title.
wm title $gRoot $title
wm minsize $gRoot 100 100
# Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
frame $gRootFr
pack $gRootFr -fill both -expand 1
frame $gRootFr.workfr -relief sunken -borderwidth 1
pack $gRootFr.workfr -side top -fill both -expand 1
frame $gRootFr.workfr.imgfr -relief raised -borderwidth 1
frame $gRootFr.workfr.infofr -relief sunken -borderwidth 1
grid $gRootFr.workfr.imgfr -row 0 -column 0 -sticky news
grid $gRootFr.workfr.infofr -row 1 -column 0 -sticky news
grid rowconfigure $gRootFr.workfr 0 -weight 1
grid columnconfigure $gRootFr.workfr 0 -weight 1
label $gRootFr.workfr.infofr.label -text Ready -anchor w
pack $gRootFr.workfr.infofr.label -fill x -in $gRootFr.workfr.infofr
frame $gRootFr.workfr.imgfr.fr
pack $gRootFr.workfr.imgfr.fr -expand 1 -fill both
if { $::gUseMultisampling } {
togl $gRootFr.workfr.imgfr.fr.toglwin \
-width 800 -height 500 \
-multisamplebuffers 1 -multisamplesamples 2 \
-double true -depth true \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
} else {
togl $gRootFr.workfr.imgfr.fr.toglwin \
-width 800 -height 500 \
-double true -depth true \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
}
#pack $gRootFr.workfr.imgfr.fr.toglwin -expand 1 -fill both
grid $gRootFr.workfr.imgfr.fr.toglwin -row 0 -column 0 -stick news
if { $::gShowSliders } {
scale $gRootFr.workfr.imgfr.fr.azi -from -180 -to 180 \
-length 380 -resolution 1 \
-command UpdatePosition \
-showvalue true -orient horizontal \
-variable gPo(ry)
scale $gRootFr.workfr.imgfr.fr.ele -from 180 -to -180 \
-length 380 -resolution 1 \
-command UpdatePosition \
-showvalue true -orient vertical \
-variable gPo(rx)
grid $gRootFr.workfr.imgfr.fr.azi -row 1 -column 0 -columnspan 2 -sticky ew
grid $gRootFr.workfr.imgfr.fr.ele -row 0 -column 1 -sticky ns
}
grid rowconfigure $gRootFr.workfr.imgfr.fr 0 -weight 1
grid columnconfigure $gRootFr.workfr.imgfr.fr 0 -weight 1
set gPo(toglWin) $gRootFr.workfr.imgfr.fr.toglwin
bind $gPo(toglWin) <Double-1> "AskOpenMod"
# Create menus File, Edit, View, Settings and Help
set hMenu $gRootFr.menufr
menu $hMenu -borderwidth 2 -relief sunken
$hMenu add cascade -menu $hMenu.file -label File -underline 0
$hMenu add cascade -menu $hMenu.edit -label Edit -underline 0
$hMenu add cascade -menu $hMenu.view -label View -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" AskOpenMod
AddMenuCmd $fileMenu "Save as ..." "Ctrl+S" AskSaveMod
if { $::tcl_platform(os) ne "Darwin" } {
$fileMenu add separator
AddMenuCmd $fileMenu "Quit" "Ctrl+Q" ExitProg
}
bind $gRoot <Control-o> AskOpenMod
bind $gRoot <Control-s> AskSaveMod
bind $gRoot <Control-q> ExitProg
bind $gRoot <Escape> ExitProg
if { [string compare $tcl_platform(os) "windows"] == 0 } {
bind $gRoot <Alt-F4> ExitProg
}
wm protocol $gRoot WM_DELETE_WINDOW "ExitProg"
set editMenu $hMenu.edit
menu $editMenu -tearoff 0
AddMenuCmd $editMenu "Add texture ..." "Ctrl+T" AskOpenTex
$editMenu add separator
AddMenuCmd $editMenu "Reset transformations" "r" \
"ResetTfms; $::gPo(toglWin) postredisplay"
bind $gRoot <Control-t> AskOpenTex
set viewMenu $hMenu.view
menu $viewMenu -tearoff 0
AddMenuCheck $viewMenu "Use display list" "d" \
::optUseDisplayList "ToggleDisplayList 0"
AddMenuCheck $viewMenu "View back faces as lines" "f" \
::optMarkBackFaces "ToggleBackFaceMode 0"
AddMenuCheck $viewMenu "Line mode" "l" \
::optLines "ToggleDrawMode 0"
if { $::gUseMultisampling } {
AddMenuCheck $viewMenu "Multisampling mode" "m" \
::optMultisampling "ToggleMultisampling 0"
}
if { $::gUseScreenRect } {
AddMenuCheck $viewMenu "Show enclosing screen rect" "b" \
::optShowBB "ToggleScreenRect 0"
}
AddMenuCheck $viewMenu "Lighting on/off" "" \
::optMakeLight "ToggleLighting 0"
$viewMenu add separator
AddMenuCmd $viewMenu "Show Euler angles" "" \
"ShowAngleWindow"
set helpMenu $hMenu.help
menu $helpMenu -tearoff 0
AddMenuCmd $helpMenu "About $gPo(appName) ..." "" HelpProg
AddMenuCmd $helpMenu "About shortcuts ..." "" ShortcutInfo
AddMenuCmd $helpMenu "About packages ..." "" PkgInfo
AddMenuCmd $helpMenu "About OpenGL version..." "" GLInfo
$gRoot configure -menu $hMenu
bind $gRoot <Key-d> "ToggleDisplayList"
bind $gRoot <Key-l> "ToggleDrawMode"
bind $gRoot <Key-f> "ToggleBackFaceMode"
if { $::gUseMultisampling } {
bind $gRoot <Key-m> "ToggleMultisampling"
}
if { $::gUseScreenRect } {
bind $gRoot <Key-b> "ToggleScreenRect"
}
bind $gRoot <Key-r> "ResetTfms; $::gPo(toglWin) postredisplay"
bind $gPo(toglWin) <ButtonPress-1> "AngOff ; tcl3dTbStartMotion %W %x %y"
bind $gPo(toglWin) <ButtonRelease-1> "tcl3dTbStopMotion %W"
bind $gPo(toglWin) <B1-Motion> "tcl3dTbMotion %W %x %y"
if { $::tcl_platform(os) eq "Darwin" } {
bind $gPo(toglWin) <ButtonPress-2> "MoveStart %W %x %y"
bind $gPo(toglWin) <B2-Motion> "MoveCont %W %x %y tz"
bind $gPo(toglWin) <ButtonRelease-2> "MoveEnd %W %x %y"
bind $gPo(toglWin) <Control-ButtonPress-2> "MoveStart %W %x %y"
bind $gPo(toglWin) <Control-B2-Motion> "MoveCont %W %x %y ty"
bind $gPo(toglWin) <Control-ButtonRelease-2> "MoveEnd %W %x %y"
bind $gPo(toglWin) <Shift-ButtonPress-2> "MoveStart %W %x %y"
bind $gPo(toglWin) <Shift-B2-Motion> "MoveCont %W %x %y tx"
bind $gPo(toglWin) <Shift-ButtonRelease-2> "MoveEnd %W %x %y"
} else {
bind $gPo(toglWin) <ButtonPress-3> "MoveStart %W %x %y"
bind $gPo(toglWin) <B3-Motion> "MoveCont %W %x %y tz"
bind $gPo(toglWin) <ButtonRelease-3> "MoveEnd %W %x %y"
bind $gPo(toglWin) <Control-ButtonPress-3> "MoveStart %W %x %y"
bind $gPo(toglWin) <Control-B3-Motion> "MoveCont %W %x %y ty"
bind $gPo(toglWin) <Control-ButtonRelease-3> "MoveEnd %W %x %y"
bind $gPo(toglWin) <Shift-ButtonPress-3> "MoveStart %W %x %y"
bind $gPo(toglWin) <Shift-B3-Motion> "MoveCont %W %x %y tx"
bind $gPo(toglWin) <Shift-ButtonRelease-3> "MoveEnd %W %x %y"
}
}
proc WriteInfoStr { str } {
global gRootFr
$gRootFr.workfr.infofr.label configure -text $str
}
proc HelpProg {} {
global gRoot
tk_messageBox -message "Simple model 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 $gRoot
}
# Trigger loading of a default model file when running from the presentation framework.
proc StartAnimation {} {
ReadModel [file join $::g_ScriptDir "f-16.obj"]
}
proc Cleanup {} {
foreach w [winfo children .] {
if { [string match ".tcl3dModelView:*" $w] } {
destroy $w
}
}
if { [info exists ::objId] } {
glmDeleteModel $::objId
unset ::objId
}
uplevel #0 unset gPo
}
proc ExitProg {} {
global gPo gRoot
tcl3dTbStopMotion $gPo(toglWin)
Cleanup
if { $::gUseToplevel } {
destroy $gRoot
}
if { [file tail $::g_ScriptName] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then exit application.
exit
}
}
proc ReadModel { fileName } {
global gPo gRoot
WriteInfoStr "Reading model file $fileName ..."
if { [info exists ::objId] } {
glmDeleteModel $::objId
unset ::objId
}
ResetTfms
if { [file extension $fileName] eq ".sab" } {
set ::objId [glmReadSAB $fileName]
set gPo(curFile,type) "sab"
} elseif { [file extension $fileName] eq ".obj" } {
set ::objId [glmReadOBJ $fileName]
set gPo(curFile,type) "obj"
} elseif { [file extension $fileName] eq ".pof" } {
set ::objId [glmReadPOF $fileName]
set gPo(curFile,type) "pof"
} else {
error "Unknown file extension $fileName"
}
set gPo(curFile,name) $fileName
set ::scaleFactor [glmUnitize $::objId]
if { ! [glmHaveVertexNormals $::objId] } {
if { ! [glmHaveFacetNormals $::objId] } {
# puts "Creating facet normals"
glmFacetNormals $::objId
}
}
calculateObjSizes
wm title $gRoot [format "%s (%s)" \
$gPo(appName) [file tail $fileName]]
$::gPo(toglWin) postredisplay
}
proc SaveModel { fileName } {
global gPo
if { [file extension $gPo(curFile,name)] eq ".sab" } {
set tmpObjId [glmReadSAB $gPo(curFile,name)]
} elseif { [file extension $gPo(curFile,name)] eq ".obj" } {
set tmpObjId [glmReadOBJ $gPo(curFile,name)]
} elseif { [file extension $gPo(curFile,name)] eq ".pof" } {
set tmpObjId [glmReadPOF $gPo(curFile,name)]
} else {
error "Unknown file extension $gPo(curFile,name)"
}
if { [file extension $fileName] eq ".sab" } {
glmWriteSAB $tmpObjId $fileName
} elseif { [file extension $fileName] eq ".pof" } {
glmWritePOF $tmpObjId $fileName
} elseif { [file extension $fileName] eq ".obj" } {
glmWriteOBJ $tmpObjId $fileName $::GLM_FLAT
} else {
error "Unknown file extension $fileName"
}
glmDeleteModel $tmpObjId
}
proc AskOpenMod {} {
global gPo
set fileTypes {
{ "All files" "*" }
{ "Wavefront files" "*.obj" }
{ "SAB CAD files" "*.sab" }
{ "POF CAD files" "*.pof" }
}
set modName [tk_getOpenFile -filetypes $fileTypes \
-initialdir $gPo(lastDir)]
if { $modName != "" } {
set gPo(lastDir) [file dirname $modName]
ReadModel $modName
}
}
proc AskSaveMod {} {
global gPo
set fileTypes {
{ "All files" "*" }
{ "Wavefront files" "*.obj" }
{ "SAB CAD files" "*.sab" }
{ "POF CAD files" "*.pof" }
}
set modName [tk_getSaveFile -filetypes $fileTypes \
-initialdir $gPo(lastDir)]
if { $modName != "" } {
set gPo(lastDir) [file dirname $modName]
SaveModel $modName
}
}
proc AskOpenTex {} {
global gPo
set fileTypes {
{ "Image files" "*.pcx *ppm *.tga *.bmp *.jpg *.rgb *.rgba" }
{ "All files" "*" }
}
set texName [tk_getOpenFile -filetypes $fileTypes \
-initialdir $gPo(lastDir)]
if { $texName != "" } {
set gPo(lastDir) [file dirname $texName]
ReadTex $texName
set gPo(curFile,haveTex) 1
}
}
# The Togl callback functions, when the Togl window is created,
# it's size is changed, and when the window content has to be redrawn.
proc CreateCallback { toglwin } {
set light0_ambient { 0.0 0.0 0.0 1.0 }
set light0_diffuse { 1.0 1.0 1.0 1.0 }
set light0_specular { 1.0 1.0 1.0 1.0 }
set light0_position { -1.0 1.0 1.0 0.0 }
set light1_ambient { 0.0 0.0 0.0 1.0 }
set light1_diffuse { 1.0 1.0 1.0 1.0 }
set light1_specular { 1.0 1.0 1.0 1.0 }
set light1_position { 1.0 1.0 1.0 0.0 }
glLightfv GL_LIGHT0 GL_AMBIENT $light0_ambient
glLightfv GL_LIGHT0 GL_DIFFUSE $light0_diffuse
glLightfv GL_LIGHT0 GL_SPECULAR $light0_specular
glLightfv GL_LIGHT0 GL_POSITION $light0_position
glLightfv GL_LIGHT1 GL_AMBIENT $light1_ambient
glLightfv GL_LIGHT1 GL_DIFFUSE $light1_diffuse
glLightfv GL_LIGHT1 GL_SPECULAR $light1_specular
glLightfv GL_LIGHT1 GL_POSITION $light1_position
glEnable GL_DEPTH_TEST
glEnable GL_LIGHTING
glEnable GL_LIGHT0
glEnable GL_LIGHT1
tcl3dTbInit $toglwin
tcl3dTbAnimate $toglwin $::GL_TRUE
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set w [$toglwin width]
set h [$toglwin height]
set aspect [expr double ($w) / double ($h)]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective $::fov $aspect 0.1 [expr 50 * $::maxSize]
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 $::dist 0.0 0.0 0.0 0.0 1.0 0.0
tcl3dTbReshape $toglwin $w $h
}
# Write contents of one vertex to stdout.
proc print2DVertex { size } {
# puts -nonewline " "
set n [$::feedbackBuffer get [expr {$size - $::count}]]
incr ::count -1
for { set i 0 } { $i < $n } { incr i } {
set x [$::feedbackBuffer get [expr {$size - $::count}]]
incr ::count -1
set y [$::feedbackBuffer get [expr {$size - $::count}]]
incr ::count -1
# puts -nonewline [format "(%4.2f, %4.2f) " $x $y]
if { $x > $::bb(x2) } {
set ::bb(x2) $x
}
if { $y > $::bb(y2) } {
set ::bb(y2) $y
}
if { $x < $::bb(x1) } {
set ::bb(x1) $x
}
if { $y < $::bb(y1) } {
set ::bb(y1) $y
}
}
# puts ""
}
# Write contents of entire buffer. (Parse tokens!)
proc printBuffer { size } {
set ::count $size
set ::bb(x1) 10000
set ::bb(x2) -10000
set ::bb(y1) 10000
set ::bb(y2) -10000
while { $::count } {
set token [$::feedbackBuffer get [expr {$size-$::count}]]
incr ::count -1
if { $token == $::GL_PASS_THROUGH_TOKEN } {
puts "GL_PASS_THROUGH_TOKEN"
puts [format " %4.2f" [$::feedbackBuffer get [expr {$size-$::count}]]]
incr ::count -1
} elseif { $token == $::GL_POLYGON_TOKEN } {
# puts "GL_POLYGON_TOKEN"
print2DVertex $size
}
}
WriteInfoStr [format "BBox (x1,x2) (y1,y2): (%4.1f, %4.1f) (%4.1f, %4.1f)" \
$::bb(x1) $::bb(x2) $::bb(y1) $::bb(y2)]
}
proc drawScreenRect { toglwin x1 x2 y1 y2 } {
glDisable GL_LIGHTING
glMatrixMode GL_PROJECTION
glPushMatrix
glLoadIdentity
gluOrtho2D 0 [$toglwin width] 0 [$toglwin height]
glMatrixMode GL_MODELVIEW
glPushMatrix
glLoadIdentity
glColor3f 0 1 1
glBegin GL_LINE_LOOP
glVertex2f $x1 $y1
glVertex2f $x2 $y1
glVertex2f $x2 $y2
glVertex2f $x1 $y2
glEnd
glPopMatrix
glMatrixMode GL_PROJECTION
glPopMatrix
glMatrixMode GL_MODELVIEW
glEnable GL_LIGHTING
}
proc drawGeometry { mode } {
global gPo
glPushMatrix
obj2ogl $mode
glPopMatrix
}
proc SetCamera {} {
global gPo
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 $::dist 0.0 0.0 0.0 0.0 1.0 0.0
glTranslatef $gPo(tx) $gPo(ty) $gPo(tz)
}
proc Abs { a } {
if { $a < 0 } {
return [expr -1 * $a]
} else {
return $a
}
}
proc getMatrixAngles {} {
set tmpMat [tcl3dVector GLfloat 16]
set tmpVec [tcl3dVector GLfloat 3]
glGetFloatv GL_MODELVIEW_MATRIX $tmpMat
set retVal [tcl3dMatfGetAngles1 $tmpMat $tmpVec]
set rx [tcl3dRadToDeg [$tmpVec get 0]]
set ry [tcl3dRadToDeg [$tmpVec get 1]]
set rz [tcl3dRadToDeg [$tmpVec get 2]]
#puts "Angles1 ($retVal): $rx $ry $rz"
set retVal [tcl3dMatfGetAngles $tmpMat $tmpVec]
set rx [tcl3dRadToDeg [$tmpVec get 0]]
set ry [tcl3dRadToDeg [$tmpVec get 1]]
set rz [tcl3dRadToDeg [$tmpVec get 2]]
#puts "Angles ($retVal): $rx $ry $rz"
$tmpMat delete
$tmpVec delete
return [list $rx $ry $rz]
}
proc convertMatrixToAngles {} {
global gPo
set angList [getMatrixAngles]
set gPo(rx) [expr int ([lindex $angList 0])]
set gPo(ry) [expr -1 * int ([lindex $angList 1])]
set gPo(rz) [expr int ([lindex $angList 2])]
}
proc DisplayCallback { toglwin } {
global gPo
if { $::optMultisampling } {
glEnable GL_MULTISAMPLE
} else {
glDisable GL_MULTISAMPLE
}
if { [info exists ::objId] && [glmHaveTexCoords $::objId] && $gPo(curFile,haveTex) } {
glEnable GL_TEXTURE_2D
} else {
glDisable GL_TEXTURE_2D
}
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]
glColor3f 0.0 1.0 0.0
SetCamera
if { $gPo(useAngles) } {
glRotatef $gPo(rx) 1 0 0
glRotatef $gPo(ry) 0 1 0
glRotatef $gPo(rz) 0 0 1
} else {
tcl3dTbMatrix $toglwin
convertMatrixToAngles
}
glPolygonMode GL_FRONT GL_FILL
if { $::optMarkBackFaces } {
glPolygonMode GL_BACK GL_LINE
} else {
glPolygonMode GL_BACK GL_FILL
}
drawGeometry $::GL_RENDER
if { $::optShowBB } {
glFeedbackBuffer $::feedbackSize GL_2D $::feedbackBuffer
glRenderMode GL_FEEDBACK
drawGeometry $::GL_FEEDBACK
set size [glRenderMode GL_RENDER]
# TODO: Check size for being in correct range.
printBuffer $size
drawScreenRect $toglwin $::bb(x1) $::bb(x2) $::bb(y1) $::bb(y2)
}
glFlush
$toglwin swapbuffers
}
proc calculateObjSizes {} {
set objSize [tcl3dVector GLfloat 3]
glmDimensions $::objId $objSize
set ::maxSize 0.0
set ::maxSize [poMisc:Max $::maxSize [$objSize get 0]]
set ::maxSize [poMisc:Max $::maxSize [$objSize get 1]]
set ::maxSize [poMisc:Max $::maxSize [$objSize get 2]]
set ::dist [expr 0.5 * $::maxSize / tan (3.1415926 / 180.0 * (0.5 * $::fov))]
WriteInfoStr [format "Size (x,y,z): (%.2f, %.2f, %.2f)" \
[expr 1.0 / $::scaleFactor * [$objSize get 0]] \
[expr 1.0 / $::scaleFactor * [$objSize get 1]] \
[expr 1.0 / $::scaleFactor * [$objSize get 2]]]
$objSize delete
}
proc CreateDisplayList { mode } {
global gPo
if { $::optUseDisplayList } {
if { [info exists gPo(displayList)] } {
glDeleteLists $gPo(displayList) 1
}
set gPo(displayList) [glmList $::objId $mode]
}
}
# Function to draw the in-memory representation of a Wavefront 3D model
# with OpenGL calls.
proc obj2ogl { mode } {
global gPo
if { ! [info exists ::objId] } {
return
}
set mode 0
if { [glmHaveTexCoords $::objId] && $gPo(curFile,haveTex) } {
#puts "Have texture coordinates and texture file"
set mode [expr $mode | $::GLM_TEXTURE]
}
if { [glmHaveMaterials $::objId] } {
#puts "Have materials"
set mode [expr $mode | $::GLM_MATERIAL]
}
if { $::optLines } {
#puts "Drawing lines"
set mode [expr $mode | $::GLM_LINE]
} elseif { [glmHaveVertexNormals $::objId] } {
#puts "Drawing smooth shaded"
glShadeModel GL_SMOOTH
set mode [expr $mode | $::GLM_SMOOTH]
} elseif { [glmHaveFacetNormals $::objId] } {
#puts "Drawing flat shaded"
glShadeModel GL_FLAT
set mode [expr $mode | $::GLM_FLAT]
} else {
#puts "Drawing without shading"
set mode [expr $mode | $::GLM_NONE]
}
if { $::optUseDisplayList } {
if { ! [info exists gPo(displayList)] } {
CreateDisplayList $mode
}
glCallList $gPo(displayList)
} else {
glmDraw $::objId $mode
}
}
proc ToggleScreenRect { { sw 1 } } {
if { $::optLines } {
tk_messageBox \
-message "Screen rectangle mode only supported in face mode." \
-type ok -icon info -title "$::gPo(appName) Information"
return
}
if { $sw } {
set ::optShowBB [expr ! $::optShowBB]
}
$::gPo(toglWin) postredisplay
}
proc ToggleDisplayList { { sw 1 } } {
global gPo
if { $sw } {
set ::optUseDisplayList [expr ! $::optUseDisplayList]
}
if { ! $::optUseDisplayList && [info exists gPo(displayList)] } {
glDeleteLists $gPo(displayList) 1
unset gPo(displayList)
}
$::gPo(toglWin) postredisplay
}
proc ToggleMultisampling { { sw 1 } } {
if { $sw } {
set ::optMultisampling [expr ! $::optMultisampling]
}
$::gPo(toglWin) postredisplay
}
proc ToggleDrawMode { { sw 1 } } {
if { $sw } {
set ::optLines [expr ! $::optLines]
}
$::gPo(toglWin) postredisplay
}
proc ToggleBackFaceMode { { sw 1 } } {
if { $sw } {
set ::optMarkBackFaces [expr ! $::optMarkBackFaces]
}
$::gPo(toglWin) postredisplay
}
proc ToggleLighting { { sw 1 } } {
if { $sw } {
set ::optMakeLight [expr ! $::optMakeLight]
}
if { $::optMakeLight } {
glEnable GL_LIGHTING
glEnable GL_LIGHT0
} else {
glDisable GL_LIGHTING
glDisable GL_LIGHT0
}
$::gPo(toglWin) postredisplay
}
proc AngOn {} {
global gPo
set gPo(useAngles) 1
#puts "Angle on $gPo(count)"
incr gPo(count)
}
proc AngOff {} {
global gPo
set gPo(useAngles) 0
convertMatrixToAngles
#puts "Angle off $gPo(count)"
}
proc ShowAngleWindow {} {
global gPo
set tw .modelViewer:angleWin
if { [winfo exists $tw] } {
wm deiconify $tw
update
raise $tw
return
}
toplevel $tw
wm title $tw "Euler angles"
wm resizable $tw false false
AngOn
set labels { "Pitch (X):" \
"Roll (Y):" \
"Yaw (Z):" }
# Generate left column with text labels.
set row 0
foreach labelStr $labels {
label $tw.l$row -text $labelStr
grid $tw.l$row -row $row -column 0 -sticky nw
incr row
}
# Generate right column with scale widgets.
set row 0
frame $tw.fr$row
grid $tw.fr$row -row $row -column 1 -sticky news
scale $tw.fr$row.sx -from -180 -to 180 \
-length 380 -resolution 1 \
-command UpdatePosition \
-showvalue false -orient horizontal \
-variable gPo(rx)
entry $tw.fr$row.ex -textvariable gPo(rx) -width 10
pack $tw.fr$row.sx $tw.fr$row.ex -side left -anchor w -pady 2
bind $tw.fr$row.ex <KeyPress-Return> "UpdatePositionGlobal"
incr row
frame $tw.fr$row
grid $tw.fr$row -row $row -column 1 -sticky news
scale $tw.fr$row.sx -from -180 -to 180 \
-length 380 -resolution 1 \
-command UpdatePosition \
-showvalue false -orient horizontal \
-variable gPo(ry)
entry $tw.fr$row.ex -textvariable gPo(ry) -width 10
pack $tw.fr$row.sx $tw.fr$row.ex -side left -anchor w -pady 2
bind $tw.fr$row.ex <KeyPress-Return> "UpdatePositionGlobal"
incr row
frame $tw.fr$row
grid $tw.fr$row -row $row -column 1 -sticky news
scale $tw.fr$row.sx -from -180 -to 180 \
-length 380 -resolution 1 \
-command UpdatePosition \
-showvalue false -orient horizontal \
-variable gPo(rz)
entry $tw.fr$row.ex -textvariable gPo(rz) -width 10
pack $tw.fr$row.sx $tw.fr$row.ex -side left -anchor w -pady 2
bind $tw.fr$row.ex <KeyPress-Return> "UpdatePositionGlobal"
# Create Close button
incr row
frame $tw.fr$row
grid $tw.fr$row -row $row -column 0 -columnspan 2 -sticky news
bind $tw <KeyPress-Escape> "AngOff ; destroy $tw"
button $tw.fr$row.b -text "Close" -command "AngOff ; destroy $tw"
wm protocol $tw WM_DELETE_WINDOW "AngOff ; destroy $tw"
pack $tw.fr$row.b -side left -fill x -padx 2 -expand 1
focus $tw
}
proc UpdatePositionGlobal {} {
global gPo
$::gPo(toglWin) postredisplay
}
proc UpdatePosition { val } {
global gPo
AngOn
$::gPo(toglWin) postredisplay
getMatrixAngles
}
proc ResetTfms {} {
global gPo
set gPo(tx) 0.0
set gPo(ty) 0.0
set gPo(tz) 0.0
# Start values for model rotation
set gPo(rx) 45
set gPo(ry) 45
set gPo(rz) 0
if { [info exists gPo(toglWin)] } {
tcl3dTbInit $gPo(toglWin)
}
}
proc ReadImg { imgName numChans } {
if { $numChans != 3 && $numChans != 4 } {
error "Error: Only 3 or 4 channels allowed ($numChans supplied)"
}
set retVal [catch {set phImg [image create photo -file $imgName]} err1]
if { $retVal != 0 } {
error "Error reading image $imgName ($err1)"
} else {
set w [image width $phImg]
set h [image height $phImg]
set texImg [tcl3dVectorFromPhoto $phImg $numChans]
image delete $phImg
}
return [list $texImg $w $h]
}
proc ReadTex { fileName } {
set imgInfo [ReadImg $fileName 3]
set imgData [lindex $imgInfo 0]
set imgWidth [lindex $imgInfo 1]
set imgHeight [lindex $imgInfo 2]
if { [tcl3dIsPow2 $imgWidth] && [tcl3dIsPow2 $imgHeight] } {
# Create The Texture
glGenTextures 1 $::gTextureId
glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL
glBindTexture GL_TEXTURE_2D [$::gTextureId get 0]
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
glTexImage2D GL_TEXTURE_2D 0 $::GL_RGB $imgWidth $imgHeight \
0 GL_RGB GL_UNSIGNED_BYTE $imgData
} else {
tk_messageBox \
-message "Texture dimensions must be a power of two." \
-type ok -icon info -title "$::gPo(appName) Information"
}
# Delete the image data vector.
$imgData delete
}
if { $gUseToplevel } {
catch { destroy $gRoot }
}
set gPo(appName) "Tcl3D Model Viewer"
set gPo(lastDir) [pwd]
set gPo(lastFile) "Default"
set gPo(curFile,type) ""
set gPo(curFile,haveTex) 0
set gPo(count) 0
#AngOff
set ::maxSize 10
set ::dist 10
set ::fov 60
set ::optShowBB 0
set ::optLines 0
set ::optMarkBackFaces 0
set ::optMultisampling 0
set ::optMakeLight 1
set ::optUseDisplayList 0
ResetTfms
# TODO:
# This size must be changed according to the number of polygons of the model.
# Plus take into account the format specified with glFeedbackBuffer.
set feedbackSize 100000
set feedbackBuffer [tcl3dVector GLfloat $feedbackSize]
ShowMainWin $gPo(appName)
if { $argc != 0 } {
set modName [lindex $argv 0]
if { $modName ne "" } {
ReadModel $modName
}
}
|
