if 0 {
[Richard Suchenwirth] 2004-02-23 - In [Playing 3D], first steps were taken to represent
3D objects in memory, and render them by projection on a 2D [canvas]. The
unsatisfying part was that the positions of the "observer" were limited to
curvy trajectories along the x axis, or very flat views parallel to the
3D axes.  In this continuation I experiment with freely choosable
observer position, so you can really "walk through" the scene, a little church on a green meadow which I call St John's chapel. Use cursor keys, possibly modified with Shift or Alt, to experiment what you can do. "+"/"-" to zoom in or out; "x", "y", "z" to see a projection along one of the main axes; "3" to return to 3D display.

[http://mini.net/files/stjohn.jpg]

There are still many shortcomings to this code, especially when you try to walk inside the church - corrections are very welcome! I suspect the ''3d'project'' proc has bugs, but my math books couldn't help me further...
}
 proc 3d'reset {} {
    variable 3d
    array set 3d {
        x0 3 y0 -3 z0 3 hy0 0 hz0 0 hyi 0 hzi 0 zoom 50 flat 3d
    }
 }
 proc 3d'poly {id points args} {
    variable 3d
    lappend 3d(polygons) $id
    set 3d($id) [list $points $args]
 }
 proc 3d'project {point} {
    variable 3d; variable proj
    set factor $3d(zoom)
    if {![info exist proj($point)]} {
        foreach {x y z} $point break
        if {$z == ""} {set z 0}
        set rxy 0; set rxz 0
        switch -- $3d(flat) {
          x {set x [expr {$y*$factor}]; set y [expr {-$z*$factor}] ;# side  view}
          y {set x [expr {$x*$factor}]; set y [expr {-$z*$factor}] ;# front view}
          z {set x [expr {$x*$factor}]; set y [expr {-$y*$factor}] ;# top   view}
          default {
            set dx  [expr {$x-$3d(x0)}]
            set dy  [expr {$y-$3d(y0)}]
            set dz  [expr {$z-$3d(z0)}]
            set 3d(hy0) [expr {-atan2($3d(y0),$3d(x0))+$3d(hyi)}]
            set 3d(hz0) [expr {-atan2($3d(z0),$3d(y0))+$3d(hzi)}]
            set 3d(hy0) $3d(hyi)
            set 3d(hz0) $3d(hzi)
            set rxy [expr {hypot($dx,$dy)}]
            if {$rxy} {
                set ay  [expr {-atan2($dy,$dx)+$3d(hy0)}]
            } else {set ay 0 ;#$3d(hy0)}
            set t $rxy
            set rxz [expr {hypot($t,$dz)}]
            if {$rxz} {
                set az  [expr {+atan2($dz,$t)-$3d(hz0)}]
            } else {set az 0 ;#$3d(hz0)}
            set x [expr {cos($ay)  * $3d(zoom)*2}]
            set y [expr {-sin($az) * $3d(zoom)*2}]
          }
        }
        set proj($point) [list $rxy $x $y]
    }
    #debug'locals
    set proj($point)
 }
 proc 3d'redraw {w} {
    variable 3d; variable proj
    $w delete all
    $w create line -100 0 100 0 -fill blue
    $w create line 0 -100 0 100 -fill blue
    catch {unset proj}
    set tmp {}
    foreach id $3d(polygons) {
        set sum 0
        set n 0
        foreach point [lindex $3d($id) 0] {
            set sum [expr {$sum+[lindex [3d'project $point] 0]}]
            incr n
        }
        puts [list $sum $n [expr {$sum/$n}] $id]
        lappend tmp [list [expr {$sum/$n}] $id]
    }
    set sorted {}
    foreach i [lsort -real -index 0 -decr $tmp] {
        lappend sorted [lindex $i 1]
    }
    foreach id $sorted {
        foreach {points args} $3d($id) break
        set 2dpoints {}
        foreach point $points {
            eval lappend 2dpoints [lrange [3d'project $point] 1 end]
        }
        eval $w create poly $2dpoints -outline black $args -tag $id
    }
    $w lower bg
    $w config -scrollregion [$w bbox all]
    wm title . "Observer: $3d(x0) $3d(y0) $3d(z0)/$3d(hy0),$3d(hz0)"
 }
 proc sgn x {expr {$x>0? 1: $x<0? -1: 0}}
 proc debug'locals {} {
    uplevel 1 {
        puts ----------[info level 0]
        foreach i [lsort [info locals]] {
            if {![array exists $i]} {puts $i=[set $i]}
        }
    }
 }
 #----------------------
 catch {console show} ;# not available on Unix
 3d'reset
 3d'poly lawn {{-3 -3} {7 -3} {7 6} {-3 6}} -fill green3 -tag bg
 3d'poly towerbot   {{0 0 0} {0 1 0} {1 1 0} {1 0 0}} -fill blue
 3d'poly towerfront {{0 0 0} {0 0 4} {1 0 4} {1 0 0}} -fill beige
 3d'poly towerleft  {{0 0 0} {0 1 0} {0 1 4} {0 0 4}} -fill yellow
 3d'poly towerback  {{0 1 0} {0 1 4} {1 1 4} {1 1 0}} -fill beige
 3d'poly towerright {{1 0 0} {1 1 0} {1 1 4} {1 0 4}} -fill beige
 3d'poly trfront {{0 0 4} {.5 .5 5} {1 0 4}} -fill red
 3d'poly trback  {{0 1 4} {.5 .5 5} {1 1 4}} -fill red
 3d'poly trleft  {{0 0 4} {.5 .5 5} {0 1 4}} -fill red
 3d'poly trright {{1 0 4} {.5 .5 5} {1 1 4}} -fill red
 3d'poly floor {{1 0} {4 0} {4 2} {1 2}} -fill grey
 3d'poly front {{1 0} {4 0} {4 0 2} {1 0 2}} -fill orange
 3d'poly left  {{1 0} {1 0 2} {1 1 3} {1 2 2} {1 2}
    {1 1.8} {1 1.8 1} {1 1.3 1} {1 1.3}} -fill beige ;# with door
 3d'poly back  {{1 2} {4 2} {4 2 2} {1 2 2}} -fill bisque
 3d'poly right {{4 0} {4 0 2} {4 1 3} {4 2 2} {4 2}} -fill bisque
 3d'poly rfront {{1 0 2} {4 0 2} {4 1 3} {1 1 3}} -fill red
 3d'poly rback  {{1 2 2} {4 2 2} {4 1 3} {1 1 3}} -fill red
 pack [canvas .c] -fill both -expand 1
 3d'redraw .c

 bind . <Escape> {exec wish $argv0 &; exit}
 bind . <Up>    {set 3d(z0) [expr $3d(z0)+1]; 3d'redraw .c}
 bind . <Down>  {set 3d(z0) [expr $3d(z0)-1]; 3d'redraw .c}
 bind . <Left>  {set 3d(x0) [expr $3d(x0)-1]; 3d'redraw .c}
 bind . <Right> {set 3d(x0) [expr $3d(x0)+1]; 3d'redraw .c}
 bind . <Alt-Up>   {set 3d(y0) [expr $3d(y0)+1]; 3d'redraw .c}
 bind . <Alt-Down> {set 3d(y0) [expr $3d(y0)-1]; 3d'redraw .c}
 bind . <Shift-Up>    {set 3d(hzi) [expr $3d(hzi)-.1]; 3d'redraw .c}
 bind . <Shift-Down>  {set 3d(hzi) [expr $3d(hzi)+.1]; 3d'redraw .c}
 bind . <Shift-Left>  {set 3d(hyi) [expr $3d(hyi)-.1]; 3d'redraw .c}
 bind . <Shift-Right> {set 3d(hyi) [expr $3d(hyi)+.1]; 3d'redraw .c}
 bind . x       {set 3d(flat) x; 3d'redraw .c}
 bind . y       {set 3d(flat) y; 3d'redraw .c}
 bind . z       {set 3d(flat) z; 3d'redraw .c}
 bind . 3       {set 3d(flat) 3; 3d'redraw .c}
 bind . +       {set 3d(zoom) [expr $3d(zoom)*2]; 3d'redraw .c}
 bind . -       {set 3d(zoom) [expr $3d(zoom)*0.5]; 3d'redraw .c}
 bind . r       {3d'reset; 3d'redraw .c}

 update; raise .