Updated 2010-06-06 17:04:56 by paul

Paul Obermeier 2005/10/11

Another demo implemented with tclogl.

TclOgl has been enhanced and renamed to Tcl3D.

I was asked, if it would be possible to use tclogl for molecule display.

Here is a little application to test the possibilities of sphere rendering with tclogl.

An updated version (using Tcl3D instead of tclogl) is available as part of the Tcl3D demos at [1].


 #!/bin/sh
 # The next line restarts using wish84 \
 exec wish8.4 $0 ${1+"$@"}

 # TclOgl demo displaying spheres in various modes.
 # Author: Paul Obermeier
 # Date: 2005-10-11

 package require tclogl
 package require Togl

 set no_mat { 0.0 0.0 0.0 1.0 }
 set mat_ambient { 0.7 0.7 0.7 1.0 }
 set mat_ambient_color { 0.8 0.8 0.2 1.0 }
 set mat_diffuse { 0.1 0.5 0.8 1.0 }
 set mat_specular { 1.0 1.0 1.0 1.0 }
 set no_shininess { 0.0 }
 set low_shininess { 5.0 }
 set high_shininess { 100.0 }
 set mat_emission {0.3 0.2 0.2 0.0}

 proc bgerror { msg } {
     tk_messageBox -icon error -type ok -message "bgerror: $msg"
 }

 proc RotX { w angle } {
     set ::xRotate [expr {$::xRotate + $angle}]
     $w postredisplay
 }

 proc RotY { w angle } {
     set ::yRotate [expr {$::yRotate + $angle}]
     $w postredisplay
 }

 proc RotZ { w angle } {
     set ::zRotate [expr {$::zRotate + $angle}]
     $w postredisplay
 }

 proc DrawSpheres {} {
     if { $::shadeModel == $::GL_SMOOTH } {
         glMaterialfv GL_FRONT GL_AMBIENT   $::mat_ambient_color
         glMaterialfv GL_FRONT GL_DIFFUSE   $::mat_diffuse
         glMaterialfv GL_FRONT GL_SPECULAR  $::mat_specular
         glMaterialfv GL_FRONT GL_SHININESS $::high_shininess
         glMaterialfv GL_FRONT GL_EMISSION  $::no_mat
     }

     set quadObj [gluNewQuadric]
     for { set x 0 } { $x < $::numSpheresPerDim } { incr x } {
         for { set y 0 } { $y < $::numSpheresPerDim } { incr y } {
             for { set z 0 } { $z < $::numSpheresPerDim } { incr z } {
                 glPushMatrix
                 glTranslatef $x $y [expr {-1.0 * $z}]
                 if { $::lineMode } {
                     gluQuadricDrawStyle $quadObj GLU_LINE
                 } else {
                     gluQuadricDrawStyle $quadObj GLU_FILL
                     if { $::shadeModel == $::GL_SMOOTH } {
                         gluQuadricNormals $quadObj GLU_SMOOTH
                     } else {
                         gluQuadricNormals $quadObj GLU_FLAT
                     }
                 }
                 gluSphere $quadObj $::sphereSize $::numSlices $::numStacks
                 glPopMatrix
             }
         }
     }
     gluDeleteQuadric $quadObj
 }

 proc ToggleDisplayList {} {
     if { $::useDisplayList } {
         if { ! [info exists ::sphereList] } {
             CreateDisplayList
         }
     } else {
         if { [info exists ::sphereList] } {
             glDeleteLists $::sphereList 1
             unset ::sphereList
         }
     }
 }

 proc CreateDisplayList {} {
     if { $::useDisplayList } {
         if { [info exists ::sphereList] } {
             glDeleteLists $::sphereList 1
         }
         set ::sphereList [glGenLists 1]
         glNewList $::sphereList GL_COMPILE
         DrawSpheres
         glEndList
     }
 }

 proc ShowAnimation { w } {
     if { $::animStarted == 0 } {
         return
     }
     set ::yRotate [expr {$::yRotate + 1}]
     set ::zRotate [expr {$::zRotate + 1}]
     $w postredisplay
     set ::animId [after idle ShowAnimation $w]
 }

 proc tclCreateFunc { w } {
     set ambient { 0.0 0.0 0.0 1.0 }
     set diffuse { 1.0 1.0 1.0 1.0 }
     set specular { 1.0 1.0 1.0 1.0 }
     set position { 0.0 3.0 2.0 0.0 }
     set lmodel_ambient { 0.4 0.4 0.4 1.0 }
     set local_view { 0.0 }

     glClearColor 0.0 0.1 0.1 0
     glEnable GL_DEPTH_TEST

     glLightfv GL_LIGHT0 GL_AMBIENT $ambient
     glLightfv GL_LIGHT0 GL_DIFFUSE $diffuse
     glLightfv GL_LIGHT0 GL_POSITION $position
     glLightModelfv GL_LIGHT_MODEL_AMBIENT $lmodel_ambient
     glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER $local_view

     glEnable GL_LIGHTING
     glEnable GL_LIGHT0

     CreateDisplayList
 }

 proc tclDisplayFunc { w } {
     glShadeModel $::shadeModel
     glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
     glPushMatrix
     glTranslatef $::xdist $::ydist [expr {-1.0 * $::zdist}]
     glRotatef $::xRotate 1.0 0.0 0.0
     glRotatef $::yRotate 0.0 1.0 0.0
     glRotatef $::zRotate 0.0 0.0 1.0
     if { $::useDisplayList } {
         if { ! [info exists ::sphereList] } {
             CreateDisplayList
         }
         glCallList $::sphereList
     } else {
         DrawSpheres
     }
     glPopMatrix

     $w swapbuffers
 }

 proc tclReshapeFunc { toglwin w h } {
     glViewport 0 0 $w $h
     glMatrixMode GL_PROJECTION
     glLoadIdentity
     gluPerspective 60.0 [expr double($w)/double($h)] 1.0 2000.0
     glMatrixMode GL_MODELVIEW
     glLoadIdentity
     gluLookAt 0.0 0.0 5.0 0.0 0.0 0.0 0.0 1.0 0.0
 }

 proc UpdateNumSpheres { name1 name2 op } {
     set numSpheres [expr $::numSpheresPerDim*$::numSpheresPerDim*$::numSpheresPerDim]
     $::infoLabel configure -text "$numSpheres"
 }

 proc HandleRot {x y win} {
     global cx cy

     RotY $win [expr {180 * (double($x - $cx) / [winfo width $win])}]
     RotX $win [expr {180 * (double($y - $cy) / [winfo height $win])}]

     set cx $x
     set cy $y
 }

 proc HandleTrans {axis x y win} {
     global cx cy

     if { $axis != "Z" } {
         set ::xdist [expr {$::xdist + 0.1 * double($x - $cx)}]
         set ::ydist [expr {$::ydist - 0.1 * double($y - $cy)}]
     } else {
         set ::zdist [expr {$::zdist + 0.1 * (double($x - $cx))}]
     }

     set cx $x
     set cy $y

     $win postredisplay
 }

 set ::xdist 0
 set ::ydist 0
 set ::zdist 5
 set ::xRotate 0.0
 set ::yRotate 0.0
 set ::zRotate 0.0

 set ::shadeModel $::GL_SMOOTH
 set ::lineMode 0
 set ::useDisplayList 0
 set ::animStarted 0

 wm title . "TclOgl spheres demo"

 set frTogl [frame .f1]
 set frSett [frame .f2]
 set frTfms [frame .f3]
 set frBttn [frame .f4]
 set frInfo [frame .f5]
 grid $frTogl -row 0 -column 0 -sticky news -columnspan 2
 grid $frSett -row 1 -column 0 -sticky nws
 grid $frTfms -row 1 -column 1 -sticky nes
 grid $frBttn -row 2 -column 0 -sticky nws -columnspan 2
 grid $frInfo -row 3 -column 0 -sticky news -columnspan 2
 grid rowconfigure . 0 -weight 1
 grid columnconfigure . 0 -weight 1
 grid columnconfigure . 1 -weight 1

 togl $frTogl.c -width 500 -height 500 \
         -double true -depth true \
         -displayproc tclDisplayFunc \
         -reshapeproc tclReshapeFunc \
         -createproc  tclCreateFunc
 pack $frTogl.c -side top -expand 1 -fill both

 frame $frSett.fr1
 label $frSett.fr1.l1 -text "Number of slices per sphere:"
 spinbox $frSett.fr1.s1 -from 4 -to 30 \
                        -textvariable ::numSlices -width 4 \
                        -command { CreateDisplayList ; $frTogl.c postredisplay }
 eval pack [winfo children $frSett.fr1] -side left -anchor w -expand 1
 pack $frSett.fr1 -expand 1 -anchor w

 frame $frSett.fr2
 label $frSett.fr2.l1 -text "Number of stacks per sphere:"
 spinbox $frSett.fr2.s1 -from 4 -to 30 \
                        -textvariable ::numStacks -width 4 \
                        -command { CreateDisplayList ; $frTogl.c postredisplay }
 eval pack [winfo children $frSett.fr2] -side left -anchor w -expand 1
 pack $frSett.fr2 -expand 1 -anchor w

 frame $frSett.fr3
 label $frSett.fr3.l1 -text "Number of spheres per side:"
 spinbox $frSett.fr3.s1 -from 1 -to 50 \
                        -textvariable ::numSpheresPerDim -width 4 \
                        -command { CreateDisplayList ; $frTogl.c postredisplay }
 eval pack [winfo children $frSett.fr3] -side left -anchor w -expand 1
 pack $frSett.fr3 -expand 1 -anchor w

 frame $frSett.fr4
 label $frSett.fr4.l2 -text "Total number of spheres:"
 label $frSett.fr4.info -text "-1"
 set ::infoLabel $frSett.fr4.info
 eval pack [winfo children $frSett.fr4] -side left -anchor w -expand 1
 pack $frSett.fr4 -expand 1 -anchor w

 frame $frTfms.fr1
 label $frTfms.fr1.lx -text "X translate:"
 scale $frTfms.fr1.sx -from -50 -to 50 -length 200 -resolution 0.5 \
                      -orient horiz -showvalue true \
                      -variable xdist \
                      -command { $frTogl.c postredisplay }
 eval pack [winfo children $frTfms.fr1] -side left -anchor nw -expand 1
 pack $frTfms.fr1 -expand 1 -anchor w

 frame $frTfms.fr2
 label $frTfms.fr2.ly -text "Y translate:"
 scale $frTfms.fr2.sy -from -50 -to 50 -length 200 -resolution 0.5 \
                      -orient horiz -showvalue true \
                      -variable ydist \
                      -command { $frTogl.c postredisplay }
 eval pack [winfo children $frTfms.fr2] -side left -anchor nw -expand 1
 pack $frTfms.fr2 -expand 1 -anchor w

 frame $frTfms.fr3
 label $frTfms.fr3.lz -text "Z translate:"
 scale $frTfms.fr3.sz -from -50 -to 50 -length 200 -resolution 0.5 \
                      -orient horiz -showvalue true \
                      -variable zdist \
                      -command { $frTogl.c postredisplay }
 eval pack [winfo children $frTfms.fr3] -side left -anchor nw -expand 1
 pack $frTfms.fr3 -expand 1 -anchor w

 checkbutton $frBttn.b1 -text "Use display list" -indicatoron 1 \
                        -variable ::useDisplayList \
                        -command ToggleDisplayList
 checkbutton $frBttn.b2 -text "Use flat shading" -indicatoron 1 \
                        -variable ::shadeModel \
                        -offvalue $::GL_SMOOTH -onvalue $::GL_FLAT \
                        -command { $frTogl.c postredisplay }
 checkbutton $frBttn.b3 -text "Use line mode" -indicatoron 1 \
                        -variable ::lineMode \
                        -command { CreateDisplayList ; $frTogl.c postredisplay }
 checkbutton $frBttn.b4 -text "Animate" -indicatoron 0 \
                        -variable ::animStarted \
                        -command { ShowAnimation $frTogl.c }
 eval pack [winfo children $frBttn] -side left -expand 1 -fill x

 label $frInfo.l1 -text "TclOgl spheres demo: Copyright Paul Obermeier, 2005" \
                  -fg gray
 eval pack [winfo children $frInfo] -side left -expand 1 -fill x

 trace add variable ::numSpheresPerDim write UpdateNumSpheres

 set ::sphereSize 0.4
 set ::numSlices 15
 set ::numStacks 15
 set ::numSpheresPerDim 5

 bind $frTogl.c <1> {set cx %x; set cy %y}
 bind $frTogl.c <2> {set cx %x; set cy %y}
 bind $frTogl.c <3> {set cx %x; set cy %y}

 bind $frTogl.c <B1-Motion> {HandleRot %x %y %W}
 bind $frTogl.c <B2-Motion> {HandleTrans X %x %y %W}
 bind $frTogl.c <B3-Motion> {HandleTrans Z %x %y %W}

 bind all <Escape> { exit }