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]}
}
}
}
#----------------------
console show
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 .