3D polyhedra with simple tk canvas
GS - This code displays 3d polyhedra in shaded or wireframe mode. It uses only the tk canvas. The illumination model is a simple flat shading model [L1 ]. The color intensity of a face is proportional to the angle between its normal and a light direction.
- A starkit version with more demos is available at [L2 ]
- A lightweight tclet version can be seen at [L3 ] (sources [L4 ])
The hidden face removal algorithm works well with convex objects but is very limited for the others. See for instance the torus or the shuttle as bad examples.
Jeff Smith 2019-07-13 : Below is an online demo using CloudTk
Jeff Smith 2020-08-19 : A new demo using 3display.kit which has more shapes. This demo runs "3D polyhedra with simple tk canvas" in an Alpine Linux Docker Container. It is a 27.5MB image which is made up of Alpine Linux + tclkit + 3display.kit + + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
Jeff Smith 2025-01-08 : This demo now runs with Tcl9.
Changes
PWQ 2005-05-02: moved bind command to after package require Tk!
PYK 2012-11-26: eliminated [update] command, added "speed" scale, added <Destroy> binding
ZB 2014-10-24: fixed a little flaw in DisplayInit (should be there "Shaded", not "shaded")
See Also
Source code
#!/bin/env tclsh
# polyhedra.tcl
# Author: Gerard Sookahet
# Date: 30 Mai 2005
# Description: Rotating polyhedra using a 'standard' tk canvas.
# Flat shading and wireframe mode.
package require Tcl 8.5
package require Tk 8.4
bind all <Escape> {exit}
proc Barycenter {lcoords} {
set X 0
set Y 0
set n [llength $lcoords]
foreach vtx $lcoords {
foreach {x y} $vtx {
set X [expr {$X + $x}]
set Y [expr {$Y + $y}]
}
}
return [list [expr {$X/$n}] [expr {$Y/$n}]]
}
proc CrossProduct {x1 y1 z1 x2 y2 z2} {
return [list [expr {$y1*$z2 - $y2*$z1}] \
[expr {$z1*$x2 - $z2*$x1}] \
[expr {$x1*$y2 - $x2*$y1}]]
}
proc DotProduct {x1 y1 z1 x2 y2 z2} {
return [expr {$x1*$x2 + $y1*$y2 + $z1*$z2}]
}
proc MatrixVectorProduct {M V} {
set x [lindex $V 0]
set y [lindex $V 1]
set z [lindex $V 2]
return [list [expr {[lindex $M 0 0]*$x+[lindex $M 1 0]*$y+[lindex $M 2 0]*$z}] \
[expr {[lindex $M 0 1]*$x+[lindex $M 1 1]*$y+[lindex $M 2 1]*$z}] \
[expr {[lindex $M 0 2]*$x+[lindex $M 1 2]*$y+[lindex $M 2 2]*$z}]]
}
proc MatrixProduct {M1 M2} {
set M {{0 0 0 0} {0 0 0 0} {0 0 0 0} {0 0 0 0}}
for {set i 0} {$i<4} {incr i} {
for {set j 0} {$j<4} {incr j} {
lset M $i $j 0
for {set k 0} {$k<4} {incr k} {
lset M $i $j [expr {[lindex $M $i $j]+[lindex $M1 $i $k]*[lindex $M2 $k $j]}]
}
}
}
return $M
}
proc MatrixRotation { ax ay az } {
set sax [expr {sin($ax)}]
set cax [expr {cos($ax)}]
set say [expr {sin($ay)}]
set cay [expr {cos($ay)}]
set saz [expr {sin($az)}]
set caz [expr {cos($az)}]
set Mx {{1 0 0 0} {0 0 0 0} {0 0 0 0} {0 0 0 1}}
set My {{0 0 0 0} {0 1 0 0} {0 0 0 0} {0 0 0 1}}
set Mz {{0 0 0 0} {0 0 0 0} {0 0 1 0} {0 0 0 1}}
# Rotation matrix around X axis with angle ax
lset Mx 1 1 $cax
lset Mx 1 2 $sax
lset Mx 2 1 [expr {-1*$sax}]
lset Mx 2 2 $cax
# Rotation matrix around Y axis with angle ay
lset My 0 0 $cay
lset My 0 2 [expr {-1*$say}]
lset My 2 0 $say
lset My 2 2 $cay
# Rotation matrix around Z axis with angle az
lset Mz 0 0 $caz
lset Mz 0 1 $saz
lset Mz 1 0 [expr {-1*$saz}]
lset Mz 1 1 $caz
return [MatrixProduct [MatrixProduct $Mx $My] $Mz]
}
# Compute normal vector and norm for each face
# -------------------------------------------------------------------
proc NormalVector {lvtx lcnx} {
set lnv {}
set lmv {}
foreach face $lcnx {
foreach {nx ny nz} [CrossProduct \
[expr {[lindex $lvtx [lindex $face 1] 0] - [lindex $lvtx [lindex $face 0] 0]}] \
[expr {[lindex $lvtx [lindex $face 1] 1] - [lindex $lvtx [lindex $face 0] 1]}] \
[expr {[lindex $lvtx [lindex $face 1] 2] - [lindex $lvtx [lindex $face 0] 2]}] \
[expr {[lindex $lvtx [lindex $face 2] 0] - [lindex $lvtx [lindex $face 1] 0]}] \
[expr {[lindex $lvtx [lindex $face 2] 1] - [lindex $lvtx [lindex $face 1] 1]}] \
[expr {[lindex $lvtx [lindex $face 2] 2] - [lindex $lvtx [lindex $face 1] 2]}]] {}
lappend lnv [list $nx $ny $nz]
lappend lmv [DotProduct $nx $ny $nz $nx $ny $nz]
}
return [list $lnv $lmv]
}
# 2D projection
# -------------------------------------------------------------------
proc Projection {x y z M} {
global scx scy vdist
set nx [expr {[lindex $M 0 0]*$x+[lindex $M 1 0]*$y+[lindex $M 2 0]*$z}]
set ny [expr {[lindex $M 0 1]*$x+[lindex $M 1 1]*$y+[lindex $M 2 1]*$z}]
set nz [expr {([lindex $M 0 2]*$x+[lindex $M 1 2]*$y+[lindex $M 2 2]*$z+10)/$vdist}]
return [list [expr {$nx/$nz+$scx/2.0}] [expr {$ny/$nz+$scy/2.0}]]
}
# Apply transformations to vertex coordinates
# -------------------------------------------------------------------
proc Transformations {lvtx lnv} {
global ax ay az
set lnew {}
set lvn {}
# Compute matrix rotation
set M [MatrixRotation $ax $ay $az]
set i 0
# Apply projection
foreach vtx $lvtx {
lappend lnew [Projection [lindex $vtx 0] [lindex $vtx 1] [lindex $vtx 2] $M]
incr i
}
# Normal vector rotation
foreach v $lnv {lappend lvn [MatrixVectorProduct $M $v]}
return [list $M $lnew $lvn]
}
# Compute color entensity for each face
# -------------------------------------------------------------------
proc Intensity {lnv lmv lvv} {
set lclr {}
set v [DotProduct [lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2] \
[lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2]]
set i 0
foreach nv $lnv {
set clr 31
set a [DotProduct [lindex $nv 0] [lindex $nv 1] [lindex $nv 2] \
[lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2]]
set b [expr {sqrt([lindex $lmv $i]*$v)}]
set clr [expr {round(31*($a/$b))}]
lappend lclr [expr {$clr < 0 ? 31 : [expr {32 - $clr}]}]
incr i
}
return $lclr
}
# Start the display and rotation loop
# -------------------------------------------------------------------
proc DisplayModel {w s} {
global stop
global display
global ax ay az tx ty tz
global form
$w.c delete all
set stop 0
global iterations
set ax 0.2
set ay 0.1
set az 0.3
set tx 0
set ty 0
set tz 0
set d $display
foreach {t lvtx lcnx lclr} [ReadData $s] {}
$w.c create text 10 10 -anchor w -fill white -text $t
foreach {lnv lmv} [NormalVector $lvtx $lcnx] {}
set lpoly [DisplayInit $w $d $lcnx $lclr]
after cancel $::run
set ::run [after 0 [list Display$d $w $lpoly $lvtx $lcnx $lnv $lmv]]
}
# Data structure for models with vertices and connectivity
# -------------------------------------------------------------------
proc ReadData { n } {
set lvtx {}
set lcnx {}
set lclr {}
set txt ""
switch $n {
tetrahedron {
set txt "tetrahedron: 4 faces 4 vertices 5 edges"
set a [expr {1.0/sqrt(3.0)}]
set lvtx [list [list $a $a $a] [list $a -$a -$a] \
[list -$a $a -$a] [list -$a -$a $a]]
set lcnx {{0 3 1} {2 0 1} {3 0 2} {1 3 2}}
}
cube {
set txt "cube: 6 faces 8 vertices 12 edges"
set lvtx {{0.7 0.7 0.7} {-0.7 0.7 0.7} {-0.7 -0.7 0.7} {0.7 -0.7 0.7}
{0.7 0.7 -0.7} {-0.7 0.7 -0.7} {-0.7 -0.7 -0.7} {0.7 -0.7 -0.7}}
set lcnx {{4 7 6 5} {0 1 2 3} {3 2 6 7} {4 5 1 0} {0 3 7 4} {5 6 2 1}}
}
octahedron {
set txt "octahedron 8 faces 6 vertices 16 edges"
set lvtx {{1 0 0} {0 1 0} {-1 0 0} {0 -1 0} {0 0 1} {0 0 -1}}
set lcnx {{0 1 4} {1 2 4} {2 3 4} {3 0 4}
{1 0 5} {2 1 5} {3 2 5} {0 3 5}}
}
dodecahedron {
set txt "dodecahedron 12 faces 20 vertices 30 edges"
set s3 [expr sqrt(3)]
set s5 [expr sqrt(5)]
set alpha [expr {sqrt(2.0/(3 + $s5))/$s3}]
set beta [expr {(1.0 + sqrt(6.0/(3 + $s5) - 2 + 2*sqrt(2.0/(3.0 + $s5))))/$s3}]
set gamma [expr {1.0/$s3}]
set lvtx [list \
[list -$alpha 0 $beta] \
[list $alpha 0 $beta] \
[list -$gamma -$gamma -$gamma] \
[list -$gamma -$gamma $gamma] \
[list -$gamma $gamma -$gamma] \
[list -$gamma $gamma $gamma] \
[list $gamma -$gamma -$gamma] \
[list $gamma -$gamma $gamma] \
[list $gamma $gamma -$gamma] \
[list $gamma $gamma $gamma] \
[list $beta $alpha 0] \
[list $beta -$alpha 0] \
[list -$beta $alpha 0] \
[list -$beta -$alpha 0] \
[list -$alpha 0 -$beta] \
[list $alpha 0 -$beta] \
[list 0 $beta $alpha] \
[list 0 $beta -$alpha] \
[list 0 -$beta $alpha] \
[list 0 -$beta -$alpha]]
set lcnx {{0 1 9 16 5} {1 0 3 18 7} {1 7 11 10 9} {11 7 18 19 6}
{8 17 16 9 10} {2 14 15 6 19} {2 13 12 4 14} {2 19 18 3 13}
{3 0 5 12 13} {6 15 8 10 11} {4 17 8 15 14} {4 12 5 16 17}}
}
icosahedron {
set txt "icosahedron: 20 faces 12 vertices 30 edges"
set X 0.525731112119133606
set Z 0.850650808352039932
set lvtx [list [list -$X 0.0 $Z] [list $X 0.0 $Z] [list -$X 0.0 -$Z] \
[list $X 0.0 -$Z] [list 0.0 $Z $X] [list 0.0 $Z -$X] \
[list 0.0 -$Z $X] [list 0.0 -$Z -$X] [list $Z $X 0.0] \
[list -$Z $X 0.0] [list $Z -$X 0.0] [list -$Z -$X 0.0]]
set lcnx {{4 0 1} {9 0 4} {5 9 4} {5 4 8}
{8 4 1} {10 8 1} {3 8 10} {3 5 8}
{2 5 3} {7 2 3} {10 7 3} {6 7 10}
{11 7 6} {0 11 6} {1 0 6} {1 6 10}
{0 9 11} {11 9 2} {2 9 5} {2 7 11}}
}
}
for {set i 0} {$i <= [llength $lcnx]} {incr i} {
lappend lclr "0000[format %2.2x 255]"
}
return [list $txt $lvtx $lcnx $lclr]
}
# Initialization of canvas with polygonal objects filled or not
# -------------------------------------------------------------------
proc DisplayInit {w d lcnx lclr} {
set lpoly {}
set i 0
if {$d == "Shaded"} then {
foreach cnx $lcnx {
lappend lpoly [$w.c create polygon \
[string repeat " 0" [expr {2*[llength $cnx]}]] \
-fill "#[lindex $lclr $i]"]
incr i
}
} else {
foreach cnx $lcnx {
lappend lpoly [$w.c create polygon \
[string repeat " 0" [expr {2*[llength $cnx]}]] \
-fill black -outline blue]
}
}
return $lpoly
}
# Flat shaded display with gradient color
# -------------------------------------------------------------------
proc DisplayShaded {w lpoly lvtx lcnx lnv lmv} {
if {$::stop} return
global iterations
global ax ay az
set ax [expr {$ax-0.02}]
set az [expr {$az+0.02}]
set ay [expr {$ay+0.025}]
set lgradB {}
foreach {M lnew lvn} [Transformations $lvtx $lnv] {}
# Light vector is set to <1 1 -1>
foreach i [Intensity $lvn $lmv [list 1 1 -1]] {
lappend lgradB [format %2.2x [expr {100+154*$i/32}]]
}
set i 0
foreach cnx $lcnx {
set lcoords {}
foreach j $cnx {lappend lcoords [lindex $lnew $j]}
# Backface culing for hidden face. Not removed but only reduced to a point
if {[lindex $lvn $i 2] < 0} {
eval $w.c coords [lindex $lpoly $i] [join $lcoords]
$w.c itemconfigure [lindex $lpoly $i] -fill "#0000[lindex $lgradB $i]"
} else {
$w.c coords [lindex $lpoly $i] [string repeat " [join [Barycenter $lcoords]]" [llength $cnx]]
}
incr i
}
if {[incr ::iterations]} {
set ::run [after $::speed [list DisplayShaded $w $lpoly $lvtx $lcnx $lnv $lmv]]
} else {
return
}
}
# Wireframe display
# -------------------------------------------------------------------
proc DisplayWireframe {w lpoly lvtx lcnx lnv lmv} {
if {$::stop} return
global ax az ay
set ax [expr {$ax-0.02}]
set az [expr {$az+0.02}]
set ay [expr {$ay+0.025}]
foreach {M lnew lvn} [Transformations $lvtx $lnv] {}
set i 0
foreach cnx $lcnx {
set lcoords {}
foreach j $cnx {lappend lcoords [lindex $lnew $j]}
# Backface culing for hidden face. Not removed but only reduced to a point
if {[lindex $lvn $i 2] < 0} {
eval $w.c coords [lindex $lpoly $i] [join $lcoords]
} else {
$w.c coords [lindex $lpoly $i] [string repeat " [join [Barycenter $lcoords]]" [llength $cnx]]
}
incr i
}
if {[incr ::iterations] } {
set ::run [after $::speed [list DisplayWireframe $w $lpoly $lvtx $lcnx $lnv $lmv]]
} else {
return
}
}
# -------------------------------------------------------------------
proc Main {} {
global stop
global display
global scx scy vdist speed
set ::run {}
set w .tdc
catch {destroy $w}
toplevel $w
wm withdraw .
wm title $w "Rotating polyhedra in Tk canvas "
set display Shaded
set scx 420
set scy 420
set vdist 1200
set ::scaspeed 40
set ::speed 40
pack [canvas $w.c -width $scx -height $scy -bg white -bg black -bd 0]
$w.c delete all
bind $w.c <Destroy> {
after cancel $::run
}
set f1 [frame $w.f1 -relief sunken -borderwidth 2]
pack $f1 -fill x
button $f1.brun -text Stop -command {set stop 1}
button $f1.bq -text Quit -command exit
label $f1.l1 -text " "
radiobutton $f1.rbs -text "Shaded" -variable display -value Shaded
radiobutton $f1.rbw -text "Wireframe" -variable display -value Wireframe
pack {*}[winfo children $f1] -side left
set f2 [frame $w.f2 -relief sunken -borderwidth 2]
pack $f2 -fill x
foreach i {tetrahedron cube octahedron dodecahedron icosahedron} {
button $f2.b$i -text $i -command "DisplayModel $w $i"
}
pack {*}[winfo children $f2] -side left
set f3 [frame $w.f3 -relief sunken -borderwidth 2]
pack $f3 -fill x
label $f3.l1 -text "View distance " -width 12
scale $f3.sca -from 300 -to 1600 -length 300 \
-orient horiz -bd 1 -showvalue true -variable vdist
pack {*}[winfo children $f3] -side left
set f4 [frame $w.f4 -relief sunken -borderwidth 2]
pack $f4 -fill x
label $f4.l1 -text "Speed " -width 12
scale $f4.speed -from 1 -to 99 -length 300 \
-orient horiz -bd 1 -showvalue true -variable scaspeed \
-command {set speed [expr {100-$scaspeed}];#}
pack {*}[winfo children $f4] -side left
}
MainFM 2026/09/18
get a try to test TIP 759 (13_436 chars instead of 14_694 chars)
#!/bin/env tclsh
# polyhedra.tcl
# Author: Gerard Sookahet
# Date: 30 Mai 2005
# Description: Rotating polyhedra using a 'standard' tk canvas.
# Flat shading and wireframe mode.
# Adapted to TIP 759 by Florent MERLET (september 2026)
# https://wiki.tcl-lang.org/page/3D+polyhedra+with+simple+tk+canvas
bind all <Escape> {exit}
proc Barycenter {lcoords} {(
X=Y=0;
n=[llength $lcoords];
[foreach vtx $lcoords {
foreach {x y} $vtx {(
X = $X + $x;
Y = $Y + $y;
)}
}];
$X/$n, $Y/$n
)}
proc CrossProduct {x1 y1 z1 x2 y2 z2} {(
$y1*$z2 - $y2*$z1,
$z1*$x2 - $z2*$x1,
$x1*$y2 - $x2*$y1
)}
proc DotProduct {x1 y1 z1 x2 y2 z2} {(
$x1*$x2 + $y1*$y2 + $z1*$z2
)}
proc MatrixVectorProduct {M V} {(
[lassign $V x y z];
Map = {{a b c} {d e f} {g h i}};
[foreach row $M map $Map {
foreach val $row var $map {(
$var = $val
)}
}];
$a*$x + $d*$y + $g*$z,
$b*$x + $e*$y + $h*$z,
$c*$x + $f*$y + $i*$z
)}
proc MatrixProduct {M1 M2} {(
# trick : use Maps of variable names :
Amap = {{a00 a01 a02} {a10 a11 a12} {a20 a21 a22}};
Bmap = {{b00 b01 b02} {b10 b11 b12} {b20 b21 b22}};
# Complex lassign : for each rows of Matrix val and each row of Map of vars :
[foreach rowA $M1 rowB $M2 mapA $Amap mapB $Bmap {
foreach valA $rowA valB $rowB varA $mapA varB $mapB {(
# Assign the variables to the values in matrix, using expr syntax
$varA = $valA;
$varB = $valB
)}
}];
# Finally, return the formula, as a 3x3 nested list
# First row :
( ($a00*$b00 + $a01*$b10 + $a02*$b20),
($a00*$b01 + $a01*$b11 + $a02*$b21),
($a00*$b02 + $a01*$b12 + $a02*$b22)),
# Second row :
( ($a10*$b00 + $a11*$b10 + $a12*$b20),
($a10*$b01 + $a11*$b11 + $a12*$b21),
($a10*$b02 + $a11*$b12 + $a12*$b22)),
# Third row :
( ($a20*$b00 + $a21*$b10 + $a22*$b20),
($a20*$b01 + $a21*$b11 + $a22*$b21),
($a20*$b02 + $a21*$b12 + $a22*$b22))
)}
proc MatrixRotation { ax ay az } {(
# Rotation matrix around X axis with angle ax
Mx=((1, 0, 0, 0), (0, cos($ax), sin($ax),0),
(0, -sin($ax), cos($ax),0), (0, 0, 0, 1));
# Rotation matrix around Y axis with angle ay
My =((cos($ay), 0, -sin($ay), 0), (0, 1, 0, 0),
(sin($ay), 0, cos($ay), 0), (0, 0, 0, 1));
# Rotation matrix around Z axis with angle az
Mz = ((cos($az), sin($az), 0, 0), (-sin($az), cos($az), 0, 0),
(0, 0, 1, 0), (0, 0, 0, 1));
[MatrixProduct [MatrixProduct $Mx $My] $Mz]
)}
# Compute normal vector and norm for each face
# -------------------------------------------------------------------
proc NormalVector {lvtx lcnx} {
set lnv {}
set lmv {}
foreach face $lcnx {
lassign [CrossProduct {*}[(
[lindex $lvtx [lindex $face 1] 0] - [lindex $lvtx [lindex $face 0] 0],
[lindex $lvtx [lindex $face 1] 1] - [lindex $lvtx [lindex $face 0] 1],
[lindex $lvtx [lindex $face 1] 2] - [lindex $lvtx [lindex $face 0] 2],
[lindex $lvtx [lindex $face 2] 0] - [lindex $lvtx [lindex $face 1] 0],
[lindex $lvtx [lindex $face 2] 1] - [lindex $lvtx [lindex $face 1] 1],
[lindex $lvtx [lindex $face 2] 2] - [lindex $lvtx [lindex $face 1] 2]
)]] nx ny nz
lappend lnv [($nx, $ny, $nz)]
lappend lmv [DotProduct $nx $ny $nz $nx $ny $nz]
}
return [($lnv,$lmv)]
}
# 2D projection
# -------------------------------------------------------------------
proc Projection {x y z M} {(
[global scx scy vdist];
Map = {{a b c} {d e f} {g h i}};
[foreach row $M map $Map {
foreach val $row var $map {(
$var = $val
)}
}];
nx = $a*$x + $d*$y + $g*$z;
ny = $b*$x + $e*$y + $h*$z;
nz = ($c*$x + $f*$y + $i*$z+10)/$vdist;
$nx/$nz+$scx/2.0,$ny/$nz+$scy/2.0
)}
# Apply transformations to vertex coordinates
# -------------------------------------------------------------------
proc Transformations {lvtx lnv} {(
[global ax ay az];
lvn = lnew = {};
# Compute matrix rotation
M = [MatrixRotation $ax $ay $az];
i=0;
# Apply projection
[foreach vtx $lvtx {
lappend lnew [Projection [lindex $vtx 0] [lindex $vtx 1] [lindex $vtx 2] $M]
incr i
}
# Normal vector rotation
foreach v $lnv {lappend lvn [MatrixVectorProduct $M $v]}
];
$M,$lnew, $lvn
)}
# Compute color entensity for each face
# -------------------------------------------------------------------
proc Intensity {lnv lmv lvv} {(
lclr = {};
v = [DotProduct [lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2] \
[lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2]];
i = 0;
[ foreach nv $lnv {(
clr = 31;
a = [DotProduct [lindex $nv 0] [lindex $nv 1] [lindex $nv 2] \
[lindex $lvv 0] [lindex $lvv 1] [lindex $lvv 2]];
b = sqrt([lindex $lmv $i]*$v);
clr = round(31*($a/$b));
[ lappend lclr \
[($clr < 0 ? 31 : (32 - $clr))]
incr i
];
)}];
$lclr
)}
# Start the display and rotation loop
# -------------------------------------------------------------------
proc DisplayModel {w s} {
global stop
global display
global ax ay az tx ty tz
global form
global iterations
$w.c delete all
[( stop = 0;
ax = 0.2;
ay = 0.1;
az = 0.3;
tx = ty = tz = 0;
d = $display; )]
lassign [ReadData $s] t lvtx lcnx lclr
$w.c create text 10 10 -anchor w -fill white -text $t
lassign [NormalVector $lvtx $lcnx] lnv lmv
set lpoly [DisplayInit $w $d $lcnx $lclr]
after cancel $::run
set ::run [after 0 [list Display$d $w $lpoly $lvtx $lcnx $lnv $lmv]]
}
# Data structure for models with vertices and connectivity
# -------------------------------------------------------------------
proc ReadData { n } {
[( lvtx = lcnx = lclr = txt = "" )]
switch $n {
tetrahedron {(
txt = "tetrahedron: 4 faces 4 vertices 5 edges" ;
a = 1.0/sqrt(3.0);
lvtx = (($a, $a, $a), ($a, -$a, -$a), (-$a,$a,-$a), (-$a,-$a,$a));
lcnx = ((0,3,1),(2,0,1),(3,0,2),(1,3,2))
)}
cube {(
txt="cube: 6 faces 8 vertices 12 edges";
lvtx=((0.7,0.7,0.7),(-0.7,0.7,0.7),(-0.7,-0.7,0.7),(0.7,-0.7,0.7),
(0.7,0.7,-0.7),(-0.7,0.7,-0.7),(-0.7,-0.7,-0.7),(0.7,-0.7,-0.7));
lcnx=((4,7,6,5),(0,1,2,3),(3,2,6,7),(4,5,1,0),(0,3,7,4),(5,6,2,1));
)}
octahedron {(
txt = "octahedron 8 faces 6 vertices 16 edges";
lvtx = {{1 0 0} {0 1 0} {-1 0 0} {0 -1 0} {0 0 1} {0 0 -1}};
lcnx = {{0 1 4} {1 2 4} {2 3 4} {3 0 4} {1 0 5} {2 1 5} {3 2 5} {0 3 5}};
)}
dodecahedron {(
txt = "dodecahedron 12 faces 20 vertices 30 edges";
s3 = sqrt(3);
s5 = sqrt(5);
alpha = sqrt(2.0/(3 + $s5))/$s3;
beta = (1.0 + sqrt(6.0/(3 + $s5) - 2 + 2*sqrt(2.0/(3.0 + $s5))))/$s3;
gamma = 1.0/$s3;
lvtx=((-$alpha, 0, $beta), ($alpha, 0, $beta),
(-$gamma, -$gamma, -$gamma), (-$gamma, -$gamma, $gamma),
(-$gamma, $gamma, -$gamma), (-$gamma, $gamma, $gamma),
( $gamma, -$gamma, -$gamma), ( $gamma, -$gamma, $gamma),
( $gamma, $gamma, -$gamma), ( $gamma, $gamma, $gamma),
( $beta, $alpha, 0), ( $beta, -$alpha, 0),
(-$beta, $alpha, 0), (-$beta, -$alpha, 0),
(-$alpha, 0,-$beta), ( $alpha, 0, -$beta),
( 0, $beta, $alpha), ( 0, $beta, -$alpha),
( 0,-$beta, $alpha), ( 0, -$beta, -$alpha));
lcnx = {{0 1 9 16 5} {1 0 3 18 7} {1 7 11 10 9} {11 7 18 19 6}
{8 17 16 9 10} {2 14 15 6 19} {2 13 12 4 14} {2 19 18 3 13}
{3 0 5 12 13} {6 15 8 10 11} {4 17 8 15 14} {4 12 5 16 17}}
)}
icosahedron {(
txt="icosahedron: 20 faces 12 vertices 30 edges";
X = 0.525731112119133606;
Z = 0.850650808352039932;
lvtx = ((-$X, 0.0, $Z), ($X, 0.0, $Z), (-$X, 0.0, -$Z),
($X, 0.0, -$Z), (0.0, $Z, $X), (0.0, $Z, -$X),
(0.0, -$Z, $X), (0.0, -$Z, -$X), ($Z, $X, 0.0),
(-$Z, $X, 0.0), ($Z, -$X, 0.0), (-$Z, -$X, 0.0));
lcnx = {{4 0 1} {9 0 4} {5 9 4} {5 4 8}
{8 4 1} {10 8 1} {3 8 10} {3 5 8}
{2 5 3} {7 2 3} {10 7 3} {6 7 10}
{11 7 6} {0 11 6} {1 0 6} {1 6 10}
{0 9 11} {11 9 2} {2 9 5} {2 7 11}}
)}
}
for (i=0) {$i <= [llength $lcnx]} {incr i} {
lappend lclr "0000[format %2.2x 255]"
}
return [($txt,$lvtx,$lcnx,$lclr)]
}
# Initialization of canvas with polygonal objects filled or not
# -------------------------------------------------------------------
proc DisplayInit {w d lcnx lclr} {
set lpoly {}
set i 0
if {$d == "Shaded"} then {
foreach cnx $lcnx {
lappend lpoly [$w.c create polygon \
[string repeat " 0" [expr {2*[llength $cnx]}]] \
-fill "#[lindex $lclr $i]"]
incr i
}
} else {
foreach cnx $lcnx {
lappend lpoly [$w.c create polygon \
[string repeat " 0" [expr {2*[llength $cnx]}]] \
-fill black -outline blue]
}
}
return $lpoly
}
# Flat shaded display with gradient color
# -------------------------------------------------------------------
proc DisplayShaded {w lpoly lvtx lcnx lnv lmv} {
if {$::stop} return
global iterations
global ax ay az
[( ax = $ax-0.02;
az =$az+0.02;
ay = $ay+0.025;
lgradB = {}; )]
lassign [Transformations $lvtx $lnv] M lnew lvn
# Light vector is set to <1 1 -1>
foreach i [Intensity $lvn $lmv [(1, 1, -1)]] {
lappend lgradB [format %2.2x [(100+154*$i/32)]]
}
set i 0
foreach cnx $lcnx {
set lcoords {}
foreach j $cnx {lappend lcoords [lindex $lnew $j]}
# Backface culing for hidden face. Not removed but only reduced to a point
if {[lindex $lvn $i 2] < 0} {
eval $w.c coords [lindex $lpoly $i] [join $lcoords]
$w.c itemconfigure [lindex $lpoly $i] -fill "#0000[lindex $lgradB $i]"
} else {
$w.c coords [lindex $lpoly $i] [string repeat " [join [Barycenter $lcoords]]" [llength $cnx]]
}
incr i
}
if {[incr ::iterations]} {
set ::run [after $::speed [list DisplayShaded $w $lpoly $lvtx $lcnx $lnv $lmv]]
} else {
return
}
}
# Wireframe display
# -------------------------------------------------------------------
proc DisplayWireframe {w lpoly lvtx lcnx lnv lmv} {
if {$::stop} return
global ax az ay
[( ax = $ax-0.02;
az = $az+0.02;
ay = $ay+0.025; )]
lassign [Transformations $lvtx $lnv] M lnew lvn
set i 0
foreach cnx $lcnx {
set lcoords {}
foreach j $cnx {lappend lcoords [lindex $lnew $j]}
# Backface culing for hidden face. Not removed but only reduced to a point
if {[lindex $lvn $i 2] < 0} {
eval $w.c coords [lindex $lpoly $i] [join $lcoords]
} else {
$w.c coords [lindex $lpoly $i] [string repeat " [join [Barycenter $lcoords]]" [llength $cnx]]
}
incr i
}
if {[incr ::iterations] } {
set ::run [after $::speed [list DisplayWireframe $w $lpoly $lvtx $lcnx $lnv $lmv]]
} else {
return
}
}
# -------------------------------------------------------------------
proc Main {} {
global stop
global display
global scx scy vdist speed
set ::run {}
set w .tdc
catch {destroy $w}
toplevel $w
wm withdraw .
wm title $w "Rotating polyhedra in Tk canvas "
set display Shaded
set scx 420
set scy 420
set vdist 1200
set ::scaspeed 40
set ::speed 40
pack [canvas $w.c -width $scx -height $scy -bg white -bg black -bd 0]
$w.c delete all
bind $w.c <Destroy> {
after cancel $::run
}
set f1 [frame $w.f1 -relief sunken -borderwidth 2]
pack $f1 -fill x
button $f1.brun -text Stop -command {set stop 1}
button $f1.bq -text Quit -command exit
label $f1.l1 -text " "
radiobutton $f1.rbs -text "Shaded" -variable display -value Shaded
radiobutton $f1.rbw -text "Wireframe" -variable display -value Wireframe
pack {*}[winfo children $f1] -side left
set f2 [frame $w.f2 -relief sunken -borderwidth 2]
pack $f2 -fill x
foreach i {tetrahedron cube octahedron dodecahedron icosahedron} {
button $f2.b$i -text $i -command "DisplayModel $w $i"
}
pack {*}[winfo children $f2] -side left
set f3 [frame $w.f3 -relief sunken -borderwidth 2]
pack $f3 -fill x
label $f3.l1 -text "View distance " -width 12
scale $f3.sca -from 300 -to 1600 -length 300 \
-orient horiz -bd 1 -showvalue true -variable vdist
pack {*}[winfo children $f3] -side left
set f4 [frame $w.f4 -relief sunken -borderwidth 2]
pack $f4 -fill x
label $f4.l1 -text "Speed " -width 12
scale $f4.speed -from 1 -to 99 -length 300 \
-orient horiz -bd 1 -showvalue true -variable scaspeed \
-command {set speed [expr {100-$scaspeed}];#}
pack {*}[winfo children $f4] -side left
}
Main