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.

There are still some shortcomings to this code, especially when you try to walk inside the church - corrections are very welcome!
}
 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 .