Keith Vetter -- this is a fun little graphical animation which morphs an octahedron into an open cuboctahedron and back. Hidden w/i this code is actually a simple 3-d to 2-d transformation package.
#!/bin/sh
# The next line is executed by /bin/sh, but not Tcl \
exec wish $0 ${1+"$@"}
##+##########################################################################
#
# Octabug
#
# Animates the morphing of a octahedron into an open cuboctahedron.
# by Keith Vetter
#
# Revisions:
# KPV Mar 07, 1995 - initial revision
# KPV Jun 07, 2002 - some minor code clean up
#
##+##########################################################################
#
# do_display
#
# Sets up the display
#
proc do_display {} {
wm title . "Octabug"
canvas .c -relief raised -borderwidth 4
pack .c -side top
.c config -height 600 -width 600
xyz .eye "Eye Position" eye_ {5 4 3}
frame .buttons
button .anim -text Animate -command { set go [expr 1 - $go]; animate}
button .qbtn -text Quit -command exit
pack .buttons -side left -expand yes -fill both
pack .anim .qbtn -side top -expand yes -in .buttons
}
##+##########################################################################
#
# animate
#
# Sets things in motion
#
proc animate {} {
global go param
if $go {
set param [expr ($param + 1) % 100]
triag
after 1 animate
}
}
##+##########################################################################
#
# Triag
#
# Draws all 8 triangles of the octabug.
#
proc triag {} {
global mem param
set t $param
set t [expr $t*2.0/100] ;# Change to 0-2 range
set t1 $t ;# Remember
if {$t > 1} { set t [expr 2.0 - $t] } ;# Exploit symmetry
set t [expr $t + 1.0] ;# 1.0-2.0 range
.c delete poly
if [info exists mem($t1,a)] { ;# Did we memoize entry already?
set a $mem($t1,a)
set b $mem($t1,b)
} else { ;# Nope, recompute
set d [expr sqrt(12 - 3 * $t * $t)]
set a [expr (3*$t + $d) / 6]
set b [expr $t - $a]
if {$t1 > 1} { ;# In or out?
set d $a ; set a $b ; set b $d
}
set mem($t1,a) $a ;# Memoize--faster on next loop
set mem($t1,b) $b
}
triag2 $a $b 7 -1 -1 -1 ;# Draw all the triangles...
triag2 $a $b 6 -1 1 -1 ;# ...back to front if we can
triag2 $a $b 5 1 -1 -1
triag2 $a $b 4 1 1 -1
triag2 $a $b 3 -1 -1 1
triag2 $a $b 2 -1 1 1
triag2 $a $b 1 1 -1 1
triag2 $a $b 0 1 1 1
update
}
##+##########################################################################
#
# Triag2
#
# Draws an individual triangle
#
proc triag2 {a b color x y z} {
global colors
set color [lindex $colors $color]
set p1 [3d_obj2screen 0 [expr $y*$a] [expr $z*$b]]
set p2 [3d_obj2screen [expr $x*$b] 0 [expr $z*$a]]
set p3 [3d_obj2screen [expr $x*$a] [expr $y*$b] 0 ]
eval .c create polygon $p1 $p2 $p3 -fill $color -tags poly
}
##+##########################################################################
#
# 3d Canvas
#
# Simple 3d canvas package. After specifying the eye, the page size and a
# few other variables, this package will draw points and lines in 3d space.
#
# This is very simple. No clipping, z-buffering, or rotation is provided.
#
# Procedures:
# 3d_init
# Generates the transformation matrix needed to map from world to screen.
# Must be called after setting or changing the eye, etc.
# 3d_obj2screen
# Converts x,y,z of world coordinates into x,y of screen coordinates
#
# Variables:
# 3d(ex) 3d(ey) 3d(ez) == eye position
# 3d(rx) 3d(ry) 3d(rz) == reference point
# 3d(x) 3d(y) == canvas size
# 3d(cx) 3d(cy) == viewport center (reference point goes here)
# 3d(sx) 3d(sy) == size of viewport
#
set 3d(ex) 5 ;# Eye position
set 3d(ey) 4
set 3d(ez) 3
set 3d(rx) 0 ;# Reference point
set 3d(ry) 0
set 3d(rz) 0
set 3d(x) 600 ;# Page size
set 3d(y) 600
set 3d(cx) [expr $3d(x) / 2.0] ;# Mid-point
set 3d(cy) [expr $3d(y) / 2.0]
set 3d(sx) [expr $3d(cx) - 5.0] ;# Viewport size
set 3d(sy) [expr $3d(cy) - 6.0]
##+##########################################################################
#
# 3d_init
#
# Computes the transformation matrix for the current eye and center.
# Note, calling this resets all scaling, translations, etc.
#
proc 3d_init {} {
global 3d_mat 3d
if {$3d(ex) == 0 && $3d(ey) == 0} { set 3d(ey) .01 }
set xy [expr sqrt($3d(ex)*$3d(ex) + $3d(ey)*$3d(ey))]
set xyz [expr sqrt($xy*$xy + $3d(ez)*$3d(ez))]
3d_ident 3d_mat
3d_ident t ;# T0 - center to origin
set t(3,0) [expr -$3d(rx)]
set t(3,1) [expr -$3d(ry)]
set t(3,2) [expr -$3d(rz)]
3d_m44 3d_mat t 3d_mat
3d_ident t ;# T1 -- Origin To Eye
set t(3,0) [expr -$3d(ex)]
set t(3,1) [expr -$3d(ey)]
set t(3,2) [expr -$3d(ez)]
3d_m44 3d_mat t 3d_mat
3d_ident t ;# T2 -- Rotate 90 Around X
set t(1,1) 0 ; set t(2,2) 0
set t(1,2) -1 ; set t(2,1) 1
3d_m44 3d_mat t 3d_mat
3d_ident t ;# T3 -- rotate to eye line
set t(0,0) [set t(2,2) [expr -$3d(ey) / $xy]]
set t(0,2) [expr $3d(ex) / $xy]
set t(2,0) [expr -$t(0,2)]
3d_m44 3d_mat t 3d_mat
3d_ident t ;# T4 -- Rotate To Eye Line
set t(1,1) [set t(2,2) [expr $xy / $xyz]]
set t(1,2) [expr $3d(ez) / $xyz]
set t(2,1) [expr -$t(1,2)]
3d_m44 3d_mat t 3d_mat
3d_ident t ;# T5 -- Left-Handed Coords
set t(2,2) -1
3d_m44 3d_mat t 3d_mat
3d_ident t ;# N - Scale By D/S
set t(0,0) [set t(1,1) 4]
3d_m44 3d_mat t 3d_mat
}
##+##########################################################################
#
# 3d_ident matrix
#
# Returns $mm as the identity matrix of size 4
#
proc 3d_ident mm {
upvar 1 $mm m
catch "uplevel [list unset $mm]" ;# Erase all entries
foreach a {0,1 0,2 0,3 1,0 1,2 1,3 2,0 2,1 2,3 3,0 3,1 3,2} {
set m($a) 0
}
set m(0,0) [set m(1,1) [set m(2,2) [set m(3,3) 1.0]]]
}
##+##########################################################################
#
# 3d_m44 ma mb mc
#
# Matrix multiply ma x mb => mc of size 4. mc can be either ma or mb.
#
proc 3d_m44 {ma mb mc} {
upvar 1 $ma aa
upvar 1 $mb bb
upvar 1 $mc cc
for {set r 0} {$r < 4} {incr r} {
set result($r,0) [expr .0 + $aa($r,0)*$bb(0,0) + $aa($r,1)*$bb(1,0) \
+ $aa($r,2)*$bb(2,0) + $aa($r,3)*$bb(3,0)]
set result($r,1) [expr .0 + $aa($r,0)*$bb(0,1) + $aa($r,1)*$bb(1,1) \
+ $aa($r,2)*$bb(2,1) + $aa($r,3)*$bb(3,1)]
set result($r,2) [expr .0 + $aa($r,0)*$bb(0,2) + $aa($r,1)*$bb(1,2) \
+ $aa($r,2)*$bb(2,2) + $aa($r,3)*$bb(3,2)]
set result($r,3) [expr .0 + $aa($r,0)*$bb(0,3) + $aa($r,1)*$bb(1,3) \
+ $aa($r,2)*$bb(2,3) + $aa($r,3)*$bb(3,3)]
}
catch "uplevel [list unset $mc]"
foreach arr [array names result] {
set cc($arr) $result($arr)
}
}
##+##########################################################################
#
# 3d_obj2screen
#
# Converts a 3d position into 2d screen coordinates based on the current
# transformation matrix 3d_mat set up by 3d_init.
#
proc 3d_obj2screen {x y z} {
global 3d_mat 3d
set xe [expr $x*$3d_mat(0,0)+$y*$3d_mat(1,0)+$z*$3d_mat(2,0)+$3d_mat(3,0)]
set ye [expr $x*$3d_mat(0,1)+$y*$3d_mat(1,1)+$z*$3d_mat(2,1)+$3d_mat(3,1)]
set ze [expr $x*$3d_mat(0,1)+$y*$3d_mat(1,2)+$z*$3d_mat(2,2)+$3d_mat(3,2)]
set sx [expr $3d(cx) + ($xe / $ze) * $3d(sx)]
set sy [expr $3d(cx) - ($ye / $ze) * $3d(sy)]
return [list $sx $sy]
}
##+##########################################################################
#
# 3d_axis
#
# Draws x,y,z axes
#
proc 3d_axis {c} {
$c delete axis
set o [3d_obj2screen 0 0 0]
$c create line $o [3d_obj2screen 1.2 0 0] -fill black -arrow last -tag axis
$c create line $o [3d_obj2screen 0 1.2 0] -fill black -arrow last -tag axis
$c create line $o [3d_obj2screen 0 0 1.2] -fill black -arrow last -tag axis
}
##+##########################################################################
#
# Xyz
#
# Creates the subwindow with XYZ scales.
#
proc xyz {w title tag values} {
global eyex eyey eyez centerx centery centerz num_steps
catch {set x [expr round([lindex $values 0])]}
catch {set y [expr round([lindex $values 1])]}
catch {set z [expr round([lindex $values 2])]}
set values [list $x $y $z]
frame $w
pack $w -side left -expand y;# -pady .1i
label $w.ltitle -text $title -relief raised -bd 3
bind $w.ltitle <Double-Button-1> reeye
pack $w.ltitle -side top -fill x
foreach l {x y z} { ;# Create 3 scales for x,y,z
frame $w.f$l -bd 2 -relief raised ;# Holds scale & label
scale $w.f$l.$l -from 10 -to 0 -relief ridge -length 75
$w.f$l.$l config -var 3d(e$l) ;# -comm "redraw"
bind $w.f$l.$l <ButtonRelease-1> "after 1 redraw"
label $w.f$l.l$l -text [string toupper $l]
$w.f$l.l$l config -bg [lindex [$w.f$l.$l config -bg] 4]
pack $w.f$l -side left -expand yes
pack $w.f$l.l$l $w.f$l.$l -side top -fill x
$w.f$l.$l set [lindex $values 0] ;# Set the scale value
set values [lrange $values 1 end]
}
}
##+##########################################################################
#
# redraw
#
# Updates 3d stuff when eye position changes
#
proc redraw {} {
global param
3d_init
triag
}
##+##########################################################################
#
# reeye
#
# Repositions the eye to the default location
#
proc reeye {} {
global 3d
set 3d(ex) 5 ; set 3d(ey) 4 ; set 3d(ez) 3
redraw
}
##+##########################################################################
#############################################################################
#############################################################################
set go 0 ;# Animation off
set param 0 ;# Time parameter
set colors {red green blue cyan slateblue magenta chocolate yellow}
3d_init ;# Initialize the 3d world
do_display ;# Draw the display
triag ;# Draw initial shapeGPS This is very impressive! Thanks for sharing it. I've been playing with perspective based projection for a while, but stereographic has stumped me (mostly I can't find simple examples). What kind of projection does this use?
DKF - This appears to be using a simple perspective projection i.e. take a view plane and an eye point, and map from points in your 3D space to points on your view plane by drawing a line passing through the target point and the eye point, and plotting a point on the view plane where the line intersects it.
Stereographic projection is something else - it is used to map points on a sphere to points on a plane, and it tends to map distances to their inverses (the closer two things are together in the real world, the further apart they are in the projection.) Stereographic projections (or at least things that are conceptually very similar) are used when studying atomic structures with X-Ray crystallography.