if 0 {
[happy-3d-easter.png]

[Richard Suchenwirth] 2002-04-02:  In this Easter fun project, I experimented with
rendering three-dimensional objects on a two-dimensional [Tk] [canvas]. Points
in 3D space are specified by x, y, and z coordinates (if only two are given,
z defaults to 0, "upgrading" 2D points); such points can be
used to construct lines and polygons (ovals too, but those may suffer
from distortions). Also, the shadowing of background objects by foreground objects leaves room for improvement -
currently this is only controlled by the order of creation.

The 2D projection of points is based on parallel projection, with some
perspective thrown in. It depends heavily on the view angle, which I simply take as the visual angle between x and y axis. The x axis is horizontal as usual, z axis is vertical. For better
orientation, the axes are painted red (x), green (y), and blue (z).
Type "x"/"y"/"z" to switch temporarily to a 2D projection along the specified
axis. In the demo program, which shows a little "doll house" (even with
badly hidden Easter eggs ;-), children may collect eggs by clicking on them
(they'll turn to 0-s in the title bar). For adults, they might serve to verify
spatial arrangement.

You can modify the '''view angle''' in steps of 5 degrees with cursor
Left/Right keys, or '''zoom in/out''' with Up/Down keys. As the canvas
can't keep the 3D information, changes in view are done by redrawing
everything from a backing store [array], which keeps all parameters
for every object. Reaction was just about fast enough on my P200 machine.

The standard operations of translating (=moving), scaling,
and rotating 3D objects are implemented - maybe not optimally, but
doing their job. They operate on tags, because most often an
object is composed of several primitives which share the same tag.
'''Moving''' can be tested with the table and chairs - click on one to select,
use Shift-cursor keys to push it around (and ignore possible uglities
in shadowing by other objects). To test movement in z direction,
type "F" or "f" to hoist or lower the flag, which when up is another
experiment in random 3D movement (but grows ridiculously long after
extended Monte Carlo walks in 3D space - click on it to restore original
dimensions). '''Rotation''' of furniture can be tested with Alt-cursor keys,
'''scaling''' with "+" and "-". Clicking on the swings makes
it swing (test for excentric animated rotation). Likewise, move the door
with left or right click. Experiments with '''dimming colours''' are
also included - use "d" resp. "D" keys to try. If things get too dark,
turn on the light with the switch next to the door.

For really good 3D rendering, points should be projected depending on the
location of the "observer", a point in 3D space from which the objects
are seen, and his "point of view" (which becomes the 2D origin), but I
had no appropriate math books handy - please edit this page if you know
better! (But then, real hidden-line treatment also becomes inevitable...)

Latest addition, not very finished yet: the little red toy cart is
movable, and when you drive it over an egg and click right on the egg,
it is "lifted" into the cart and stays with it. Still pretty crude, but
a long Easter weekend is now over - and I'm not paid for Tk games
programming... 

DISCLAIMER: This works well and fine on Linux, W95 and W2K. On Solaris, via Reflection from a Windows box, Alt-Cursor keys don't get through. Also, had to add nonzero tests in "3d'rotate", 
as ''atan2'' errors when called with 0.0,0.0 (not so on Windows). [RS]

[Arjen Markus]:  The problem with the Alt-key may be that Reflection has not been informed to pass the left or right Alt-key to X Window - this is part of the keyboard settings. [RS]: Yes, this did it - thanks!
----
''[escargo] 15 Apr 2003'' - Are we supposed to be able to prune the shrubs?  (Clicking on some
of the greenery makes it go away?  Also, there are sometimes some z-order problems.  I had some of
the shrubs get drawn on the wrong side of one of the chairs.  Also, sometimes the table is visible
through the walls of the house.  (I really like the light switch!)
----

I Updated Merry to Happy in the window title. I've heard of Merry Christmas, but never Merry Easter. I guess Merry and Happy have similar meanings though.

----

[dbohdan] 2018-08-17: Fixed Tcl 8.5-8.6 compatibility.  Eliminated `[update]` and replaced `[eval]` with `[{*}]`.

----

======
}
package require Tcl 8.5
package require Tk
proc deg2rad {deg} {expr {$deg * atan(1)/45.}}
trace var 3d(angle) w "set 3d(th) \[deg2rad \$3d(angle)];#"
array set 3d {angle 30 scale 100 bright 1 lastDim .25 flat 0}

proc 3d {type w points args} {
    variable 3d
    set cmd [list $w create $type]
    foreach point $points {lappend cmd {*}[3d'project $point]}
    if {$type eq {poly} && [lsearch $args -outline] < 0} {
        lappend cmd -outline black   ;# looks better...
    }
    set cmd [concat $cmd $args]
    if {$3d(bright) != 1} {
       foreach att {-outline -fill} {
          if {[set pos [lsearch $cmd $att]] > 0} {
             set f [lindex $cmd [incr pos]]
             set cmd [lreplace $cmd $pos $pos [dimColor $f $3d(bright)]]
          }
       }
    }
    set 3d([{*}$cmd]) [list $type $points $args]       ;# backing store
}
proc 3d'axes w {
    foreach {name from       to       color} {
            Xaxis {-30 0 0} {30 0 0}  red
            X1    {1 0 0}   {1 .05 0} red
            Yaxis {0 -30 0} {0 30 0}  green
            Y1    {0 1 0}   {0 1 .05} green
            Zaxis {0 0 -30} {0 0 30}  blue
            Z1    {0 0 1}   {.05 0 1} blue
    } {3d line $w [list $from $to] -fill $color -tag axes}
}
proc 3d'project point {
    variable 3d
    foreach {x y z} $point break
    if {$z eq {}} {set z 0}
    set factor $3d(scale)
    switch -- $3d(flat) {
        x {list [expr {$y*$factor}] [expr {-$z*$factor}] ;# side  view}
        y {list [expr {$x*$factor}] [expr {-$z*$factor}] ;# front view}
        z {list [expr {$x*$factor}] [expr {-$y*$factor}] ;# top   view}
        default {
            set rad [expr {$y * abs(1-($3d(angle)/90.))}]
            if {abs($y)<6} {set factor [expr {$factor*(1-$y/6.)}]};#perspective
            set 2dx [expr {($x + $rad*cos($3d(th))) *  $factor}]
            set 2dy [expr {($z + $rad*sin($3d(th))) * -$factor}];#+y goes down
            list $2dx $2dy
        }
    }
}
proc 3d'redraw {w {tag all} {flat {}}} {
    variable 3d
    if {$flat != {}} {set 3d(flat) $flat}
    set 3d(angle) [expr {$3d(angle)>180? 180: $3d(angle)<0? 0: $3d(angle)}]
    foreach item [$w find withtag $tag] {
        foreach {type points args} $::3d($item) break
        unset 3d($item)
        $w delete $item
        3d $type $w $points {*}$args
    }
}
proc 3d'move {w tag vector} {
    variable 3d
    foreach item [$w find withtag $tag] {
        set newpoints {}
        foreach point [lindex $3d($item) 1] {
             lappend newpoints [vector'add $point $vector]
        }
        set 3d($item) [lreplace $3d($item) 1 1 $newpoints]
    }
    3d'redraw $w $tag
}
proc 3d'scale {w tag factors {rpoint {}}} {
    variable 3d
    if {$rpoint eq {}} {set rpoint [3d'center $w $tag]}
    foreach {x0 y0 z0} $rpoint break
    foreach {xf yf zf} $factors break
    if {$yf eq {}} {set yf $xf}
    if {$zf eq {}} {set zf $yf}
    foreach item [$w find withtag $tag] {
        set newpoints {}
        foreach point [lindex $3d($item) 1] {
            foreach {x y z} $point break
            if {$z eq {}} {set z 0}
            set x1 [expr {($x - $x0) * $xf + $x0}]
            set y1 [expr {($y - $y0) * $yf + $y0}]
            set z1 [expr {($z - $z0) * $zf + $z0}]
            lappend newpoints [list $x1 $y1 $z1]
        }
        set 3d($item) [lreplace $3d($item) 1 1 $newpoints]
    }
    3d'redraw $w $tag
}
proc 3d'rotate {w tag rvector {rpoint {}}} {
    variable 3d
    foreach {rx ry rz} $rvector break ;# rotation angles in degrees
    foreach i {x y z} {set rd$i [deg2rad [set r$i]]}
    if {$rpoint eq {}} {set rpoint [3d'center $w $tag]}
    foreach {xc yc zc} $rpoint break
    foreach item [$w find withtag $tag] {
        set newpoints {}
        foreach point [lindex $3d($item) 1] {
            foreach {x y z} $point break
            if {$z eq {}} {set z 0}
            set x1 [expr {$x-$xc}]
            set y1 [expr {$y-$yc}]
            set z1 [expr {$z-$zc}]
            if {$rx != 0} {
                if {[set rad [expr {hypot($y1,$z1)}]]} {
                  set th  [expr {atan2($z1,$y1) - $rdx}]
                  set y   [expr {$yc + $rad * cos($th)}]
                  set z   [expr {$zc + $rad * sin($th)}]
                } ;# tests for nonzero rad necessary on Unix
            }
            if {$ry != 0} {
                if {[set rad [expr {hypot($x1,$z1)}]]} {
                  set th  [expr {atan2($z1,$x1) - $rdy}]
                  set x   [expr {$xc + $rad * cos($th)}]
                  set z   [expr {$zc + $rad * sin($th)}]
                }
            }
            if {$rz != 0} {
                if {[set rad [expr {hypot($x1,$y1)}]]} {
                   set th  [expr {atan2($y1,$x1) - $rdz}]
                   set x   [expr {$xc + $rad * cos($th)}]
                   set y   [expr {$yc + $rad * sin($th)}]
                }
            }
            lappend newpoints [list $x $y $z]
        }
        set 3d($item) [lreplace $3d($item) 1 1 $newpoints]
    }
    3d'redraw $w $tag
}
proc 3d'bcube {w tag} {
    #-- compute "bounding cube" (minx maxx miny maxy minz maxz)
    variable 3d
    set xs {}; set ys {}; set zs {}
    foreach item [$w find withtag $tag] {
        foreach point [lindex $3d($item) 1] {
            foreach {x y z} $point break
            lappend xs $x
            lappend ys $y
            lappend zs $z
        }
    }
    concat [minmax $xs] [minmax $ys] [minmax $zs]
}
proc 3d'center {w tag} {
    foreach {x x1 y y1 z z1} [3d'bcube $w $tag] break
    list [expr {($x+$x1)/2.}] [expr {($y+$y1)/2.}] [expr {($z+$z1)/2.}]
}
proc 3d'addtag {w item tag} {
    variable 3d
    set args [lindex $3d($item) 2]
    set found 0; set newargs {}
    foreach {att val} $args {
        if {$att eq {-tag}} {lappend val $tag; incr found}
        lappend newargs $att $val
    }
    if {!$found} {lappend newargs -tag $tag}
    set 3d($item) [lreplace $3d($item) 2 2 $newargs]
}
proc dim {w factor {tag all}} {
    variable 3d
    if {$factor == 0} {
        set factor [expr {1./$3d(lastDim)}]
        set 3d(lastDim) $factor ;# allow toggle for light switch
    } else {set 3d(bright) [expr {$3d(bright)*$factor}]}
    if {$tag eq {all}} {
        $w config -bg [dimColor [$w cget -bg] $factor]
    }
    foreach item [$w find withtag $tag] {
        foreach att {-fill -outline} {
            if {![catch {$w itemcget $item $att} f]} {
                $w itemconf $item $att [dimColor $f $factor]
            }
        }
    }
}
proc dimColor {color factor} {
    if {$color eq {}} {return {}}
    foreach {r g b} [winfo rgb . $color] break
    set res "#"
    foreach i {r g b} {
        set col [expr {round([set $i]*$factor)}]
        if {$col > 0xFFFF} {set col 0xFFFF}
        append res [format %4.4x $col]
    }
    set res
}
proc minmax L {
    set sorted [lsort -real $L]
    list [lindex $sorted 0] [lindex $sorted end]
}
proc vector'add {v1 v2} {
    set res {}
    foreach i $v1 j $v2 {
        if {$i eq {}} {set i 0}
        if {$j eq {}} {set j 0}
        lappend res [expr {$i + $j}]
    }
    set res
}


#-------------------------------- A mighty elaborate and playful demo:

if {[file tail [info script]] eq [file tail $argv0]} {
    proc plant {c x y {diameter 0.6} {branches 8}} {
        set root [list $x $y 0]
        for {set i 0} {$i<$branches} {incr i} {
            set x1 [expr {$x + rand()*$diameter - $diameter/2}]
            set y1 [expr {$y + rand()*$diameter - $diameter/2}]
            set z  [expr {rand()*0.25 + $diameter}]
            set width [expr {round($diameter*6)}]
            3d line $c [list $root [list $x1 $y1 $z]] -width $width\
            -fill [lpick {DarkGreen green4 ForestGreen SeaGreen YellowGreen}]\
            -tag plant
        }
    }
    proc chair {c x y {colors {white blue}}} {
        set h1 0.12
        set h2 0.2
        set h3 0.3
        set y1 0.25; set y2 0.26
        set tag chair[incr ::chairID]
        set tag2 [list $tag mv]
        foreach {c1 c2} $colors break
        3d line $c "{0 $y2} {.05 $y2 $h2} {.25 $y2 $h2} {.3 $y2}" -fill $c1\
            -width 2 -tag $tag2
        3d poly $c "{.05 0 $h1} {.05 $y1 $h1} {.3 $y1 $h1} {.3 0 $h1}" \
            -fill $c2 -tag $tag2 -width 2
        3d poly $c "{.05 0 $h1} {0 0 $h3} {0 $y1 $h3} {.05 $y1 $h1}" \
            -fill $c2 -tag $tag2 -width 2
        3d line $c "{0 0} {.05 0 $h2} {.25 0 $h2} {.3 0}" -fill $c1 \
            -width 2 -tag $tag2
        3d'move $c $tag [list $x $y 0]
        set tag
    }
    set chairID 0


    proc every {ms body} {
        eval $body; after $ms [namespace code [info level 0]]
    }


    proc lpick L {lindex $L [expr {int(rand() * [llength $L])}]}


    proc moveFlag w {
        variable 3d
        foreach i [$w find withtag =flag] {
            set points [lindex $3d($i) 1]
            if {[lindex [lindex $points 0] 2] > 1.5} {
                set randv {}
                foreach _ {x y z} {
                    lappend randv [expr {rand()*0.05-0.025}]
                }
                set p1 [vector'add [lindex $points 1] $randv]
                set p2 [vector'add [lindex $points 2] $randv]
                set points [lreplace $points 1 2 $p1 $p2]
                set 3d($i) [lreplace $3d($i) 1 1 $points]
            }
        }
        3d'redraw $w  =flag
        $w lower      =flag backWall
    }


    proc placeEggs w {
        foreach color {
            red green blue cyan magenta yellow orange pink purple brown
        } {
            set x [expr {rand() * 5.4 - 1.9}]
            set y [expr {rand() * 4 - 2}]
            3d oval $w "{$x $y .04} {[expr $x+.1] [expr $y+.04] -.04}" \
                -fill $color -tag egg
        }
        $w lower egg frontWall
        wm title . {Happy 3D Easter!}
        $w bind egg <1> {
            %W delete current
            wm title . "[wm title .] 0" ;# append found eggs to title
            if {[%W find withtag egg] eq {}} {
                tk_messageBox -message Super!
                placeEggs %W
            }
        }
    }


    proc swings {w x0 y0} {
        set x1 [expr {$x0 + 0.8}]
        set xm [expr {($x0 + $x1)/2}]
        set x2 [expr {$xm - 0.05}]
        set x3 [expr {$xm + 0.05}]
        set y1 [expr {$y0 + 0.7}]
        set y2 [expr {$y0 + 0.3}] ;# rope 1
        set y3 [expr {$y0 + 0.5}] ;# rope 2
        set h 0.8    ;# top crossbar
        set s 0.14   ;# height of swing seat
        set col turquoise4
        3d line $w "{$x0 $y1} {$xm $y1 $h} {$x1 $y1}" -width 2 -fill $col
        3d line $w "{$xm $y0 $h} {$xm $y1 $h}" -width 2 -fill $col
        3d line $w "{$xm $y3 $h} {$xm $y3 $s}" -tag swingm
        3d poly $w "{$x2 $y2 $s} {$x3 $y2 $s} {$x3 $y3 $s} {$x2 $y3 $s}"\
            -fill orange -tag swingm
        3d line $w "{$xm $y2 $h} {$xm $y2 $s}" -tag swingm
        3d line $w "{$x0 $y0} {$xm $y0 $h} {$x1 $y0}" -width 2 -fill $col\
            -tag swingfg
        set swingpoint [list $xm $y2 $h]
        $w bind swingm <1> [list swing'move %W swingm $swingpoint 20]
    }


    proc swing'move {w tag rpoint angle} {
        $w raise swingfg
        if {$angle<=0} return
        3d'rotate $w $tag [list 0 $angle 0] $rpoint
        set angle2 [expr {$angle*-2}]
        after 250 [list 3d'rotate $w $tag [list 0 $angle2 0] $rpoint]
        after 500 [list 3d'rotate $w $tag [list 0 $angle 0] $rpoint]
        after 500 [list swing'move $w $tag $rpoint [incr angle -1]]
    }


    proc toycart {w x y {color red}} {
        3d oval $w {{.01 .18 .1}  {.09 .2 0}} -fill black -tags {cart mv}
        3d oval $w {{.19 .18 .1}  {.27 .2 0}} -fill black -tags {cart mv}
        3d poly $w {{.01 .01 .1} {.01 .19 .1} {.29 .19 .1} {.29 .01 .1}}\
            -fill $color -tags {cart mv}
        3d poly $w {{.01 .19 .1} {0 .2 .15} {.3 .2 .15} {.29 .19 .1}}\
            -fill $color -tags {cart mv}
        3d poly $w {{.01 .01 .1} {0 0 .15} {0 .2 .15} {.01 .19 .1}}\
            -fill $color -tags {cart mv}
        3d poly $w {{.29 .01 .1} {.3 0 .15} {.3 .2 .15} {.29 .19 .1}}\
            -fill $color -tags {cart mv}
        3d poly $w {{.01 .01 .1} {0 0 .15} {.3 0 .15} {.29 .01 .1}}\
            -fill $color -tags {cart mv front}
        3d line $w {{.3 .1 .1}  {.55 .1 0}} -width 2 \
            -fill $color -tags {cart mv}
        3d line $w {{.55 .07 0} {.55 .13 0}} -width 2 \
            -fill $color -tags {cart mv}
        3d oval $w {{.01 .02 .1}  {.09 0 0}} -fill black -tags {cart mv}
        3d oval $w {{.19 .02 .1}  {.27 0 0}} -fill black -tags {cart mv}
        3d'move $w cart [list $x $y] ;# bring to target position
        $w bind egg <3> {
            set item [%W find withtag current]
            3d'addtag %W $item cart      ;# let it move with the cart...
            3d'move   %W $item {0 0 .11} ;# ...and raise it on board
            %W raise front egg
        }
        return cart
    }

    #---------------------------------- let's build up the scene...
    set c [canvas .c -width 600 -height 400 \
        -scrollregion {-250 -300 350 100} -bg steelblue1]
    pack $c  -fill both -expand 1
    3d'axes $c
    3d poly $c {{-4 -3} {6 -3} {6 -3 -2} {-4 -3 -2}} -fill brown    ;# earth
    3d poly $c {{-4 -3} {6 -3} {6 2} {-4 2}} -fill green3            ;# lawn
    3d poly $c {{-4 2} {.3 2} {.3 2 .4} {-4 2 .4}} -fill DarkOrange2;# fence
    3d poly $c {{.7 2} {6 2} {6 2 .4} {.7 2 .4}} -fill DarkOrange2  ;# fence
    3d poly $c {{.3 .1} {1.7 .1} {1.7 -.7} {.3 -.7}} -fill gray    ;#terrace
    plant $c 1 1.9
    3d line $c {{.5 1.8} {.5 1.8 2.85}} -fill white -width 3     ;# flagpole
    set flagCoords {{.5 1.8 2.5} {.62 2 2.5} {.62 2 2.8} {.5 1.8 2.8}}
    3d poly $c $flagCoords -fill blue -tags =flag                    ;# flag
    $c bind =flag <1> {
      $c delete =flag; 3d poly $c $flagCoords -fill blue -tags =flag
    }
    3d poly $c {{0 .1} {0 1} {2 1} {2 .1}} -fill orange -tag in      ;#floor
    3d oval $c {{.3 .3} {1.8 .8}} -fill purple -tag in             ;# carpet
    plant $c  -1.3  1.8 0.5
    plant $c   3    1.8 0.6
    swings $c -1.6 -0.3
    3d oval $c {{-3.2 -2.7} {-1.5 -1}}   -fill beige                 ;# pool
    3d oval $c {{-3.1 -2.6} {-1.6 -1.1}} -fill DeepSkyBlue3 ;# water in pool
    3d poly $c {{.2 1} {.36 1.3} {.36 1.3 .8} {.2 1 .8}} \
    -fill brown -tag {=door in}                                      ;# door
    3d oval $c {{.34 1.25 .29} {.37 1.29 .32}} -fill yellow \
    -outline orange -tag {=door in}                                   ;#knob
    $c bind =door <1> {
        3d'rotate %W =door {0 0 -15} {.2 1 .4}; %W lower =door backWall}
    $c bind =door <3> {
        3d'rotate %W =door {0 0 15} {.2 1 .4}; %W lower =door backWall}
    3d poly $c {{0 1} {.2 1} {.2 1 .7} {.54 1 .7} {.54 1}
         {1.3 1} {1.3 1 .3} {.8 1 .3} {.8 1 .7} {1.3 1 .7}
        {1.3 1} {2 1} {2 1 1} {0 1 1}} -fill bisque -outline bisque \
            -tag {backWall in}                                  ;# back wall 
    3d poly $c {{.57 1 .4} {.65 1 .4} {.65 1 .48} {.57 1 .48}} \
        -fill white -tag {=lightSwitch in}                   ;# light switch
    $c bind =lightSwitch <1> {dim %W 0 in}
    3d line $c {{1 1 .3} {1 1 .7}} -fill white -width 2 -tag in;# window bar
        3d poly $c {{-.05 1.05 1} {-.05 .5 1.5} {2.05 .5 1.5} {2.05 1.05 1}}\
         -fill red                                            ;# (back) roof
    3d poly $c {{0 .1} {0 1} {0 1 1} {0 .5 1.5} {0 .1 1}} \
        -fill beige                                        ;# left side wall
    foreach {x y} {.51 .31  .51 .49  .79 .49  .79 .31} {
        3d line $c [list [list $x $y 0] [list $x $y .3]] \
            -fill black -width 3 -tag {=table mv}}             ;# table legs
    3d poly $c {{.5 .3 .3} {.5 .5 .3} {.8 .5 .3} {.8 .3 .3}} \
        -fill lightblue -tag {=table mv in}                   ;# table plate
    3d poly $c {{2 .1} {2 1} {2 1 1} {2 .5 1.5} {2 .1 1}} -fill pink  ;#wall
    3d poly $c {{0 .1} {.3 .1} {.3 .1 .8} {1.7 .1 .8} {1.7 .1 .3}
    {1 .1 .3} {1 .1 .8} {.9 .1 .8} {.9 .1} {2 .1} {2 .1 1} {0 .1 1}} \
        -fill LightYellow -outline LightYellow -tag frontWall  ;# front wall
    placeEggs $c
    3d poly $c {{.99 .1 .29} {1.7 .1 .29} {1.7 .1 .81} {.99 .1 .81}}\
        -fill {} -width 2 -outline NavyBlue                   ;#window frame
    3d poly $c {{-.05 .05 1} {-.05 .5 1.5} {2.05 .5 1.5} {2.05 .05 1}}\
         -fill red                                           ;# (front) roof
    chair   $c -0.5 -1.8
    toycart $c  2   -2
    3d'rotate $c [chair $c 0 -2.5] {0 0 -60}
    for {set i 0} {$i<10} {incr i} {
        plant $c [expr {5-rand()*6}] [expr {-3+rand()*2.3}] 0.2 5
    }
    plant $c -2.5 -.8 .7
    plant $c  2.8 -.8 .5
    #--------------------------------------------------------- Bindings
    bind . <Left>  {incr 3d(angle)  5; 3d'redraw .c all 3d}
    bind . <Right> {incr 3d(angle) -5; 3d'redraw .c all 3d}
    bind . <Up>    {set 3d(scale) [expr {$3d(scale)*1.25}]; 3d'redraw .c}
    bind . <Down>  {set 3d(scale) [expr {$3d(scale)/1.25}]; 3d'redraw .c}
    #-- test transformations with current "mv" (movable) object
    set mv =table ;# initially: table (best move it out of house first)
    bind . <Shift-Left>  {3d'move   $c $mv {-.1 0 0}}
    bind . <Shift-Right> {3d'move   $c $mv {.1  0 0}}
    bind . <Shift-Up>    {3d'move   $c $mv {0  .1 0}}
    bind . <Shift-Down>  {3d'move   $c $mv {0 -.1 0}}
    bind . <Alt-Left>    {3d'rotate $c $mv {0  0  5}}
    bind . <Alt-Right>   {3d'rotate $c $mv {0  0 -5}}
    bind . <Alt-Up>      {3d'rotate $c $mv {0  5  0}}
    bind . <Alt-Down>    {3d'rotate $c $mv {0 -5  0}}
    bind . +             {3d'scale  $c $mv 1.25}               ;# grow
    bind . -             {3d'scale  $c $mv 0.8}              ;# shrink
    $c bind mv <1> {
        set mv [lindex [%W gettags current] 0]
        3d'move %W $mv {-.01 -.01 -.01}       ;# visual feedback in 3D
        after 100 [list 3d'move %W $mv {.01 .01 .01}]
    }
    $c bind plant <1> {%W delete current}           ;# for "gardening"
    bind . x {3d'redraw $c all x}           ;# side view, along x axis
    bind . y {3d'redraw $c all y}          ;# front view, along y axis
    bind . z {3d'redraw $c all z}            ;# top view, along z axis
    bind . 3 {3d'redraw $c all 3d}           ;#      perspectivic view
    bind . F [list 3d'move $c =flag  {0 0  .1}]          ;# hoist flag
    bind . f [list 3d'move $c =flag  {0 0 -.1}]          ;# lower flag
    bind . d {dim .c .8}                        ;# decrease brightness
    bind . D {dim .c 1.25}                      ;# increase brightness
    bind . <Escape> {exec wish $argv0 &; exit}              ;# restart
    bind . ? {console show}                           ;# for debugging

    #-------------------------------------------- Initial animation...
    set 3d(scale) 0.2               ;# start with a view from far away
    3d'redraw .c
    raise .                                    ;# necessary on Windows
    proc zoomIn {} {
        if {$::3d(scale) < 80} {
            event generate . <Up>
            after idle zoomIn
        }
    }
    zoomIn
    every 250 {moveFlag  .c}     ;# so there's always something moving
}
if 0 {
======

<<categories>> 3D Graphics | Arts and crafts of Tcl-Tk programming

}