Version 3 of St John's chapel
Updated 2004-02-23 09:04:10if 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.
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 .