package require Tcl 8.5
set ::tcl_precision 17
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 == "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==""} {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==""} {set rpoint [3d'center $w $tag]}
    foreach {x0 y0 z0} $rpoint break
    foreach {xf yf zf} $factors break
    if {$yf == ""} {set yf $xf}
    if {$zf == ""} {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 == ""} {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 == ""} {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 == ""} {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 == "-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 == "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 == ""} {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 == ""} {set i 0}
        if {$j == ""} {set j 0}
        lappend res [expr {$i + $j}]
    }
    set res
}


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

if {[file tail [info script]] == [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 [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] == ""} {
              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
}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References