. Unfortunately I don't know much about OpenGL so the lighting doesn't work right, and it could probably be optimized better for OpenGL. But its nifty nontheless.Right click to toggle fill. Left click and drag to rotate Space bar to toggle (broken) lightingkpv - damn, I'm dying to see it but TkOGL for windows seems to need tcl80. Has anyone gotten it to work in 8.4 on windows?12feb04 kpv - jcw has created a stubs-enabled version of Tkogl 1.1 for windows, see the OpenGL page for details. You have to add a load Tkogl.dll call to make the code work.
[wfs] - Gosh I love linux/tcl it's amazing...I have two machines 400mhz and 1.2 gig. Haven't bothered to compile tkogl on the new 1.2gig machine yet. Really wanted to try the demo below...copied it to the 400mhz... exported my display...ran glwish and sourced the file below... hardware accelerated graphics since my 1.2gig has it... amazing that a simple prog running on my 400mhz machine can use the hardware accelleration on my 1.2gig machine...OpenGL rocks. ..what is windows...what is DirectX...how come we even use Microsoft products ...buy a game that doesnt use OpenGL and you add one more bullet to the war machine that is killing some cool technology ...lets see DirectX run an app on one machine while displaying it on another and using the 2nd machines graphics hardware... nugh venting...
14dec05 DKF: I've added some code to do a simple shading model that lets you see the shape of the mountains better. For some reason, I find this makes it better to work with smaller numbers of iterations (I think 3 to 5 works well).
##+##########################################################################
#
# Fractal Mountain
#
# Builds and displays a fractal mountain. Based on code at
# http://www.mactech.com/articles/mactech/Vol.07/07.05/FractalMountains/
# by Keith Vetter
#
# Revisions:
# KPV Nov 07, 2002 - initial revision
# KPV Nov 12, 2002 - added variable water level; better redraw for new depths
#
##+##########################################################################
package require Tk
proc K {x y} {return [set x]}
if {[catch {package require Tcl 8.4}]} {
package require Tcl 8.3
proc lset {_lvar idx value} { ;# Need lset from 8.4
upvar 1 $_lvar lvar
set lvar [lreplace [K $lvar [unset lvar]] $idx $idx $value]
}
}
interp alias {} = {} expr
set S(version) 1.2
set S(date) "Nov 12, 2002"
# S(v,*) = GUI S(w,*) = what user wants to see M(d,*) = what's in $map
set S(params) [list depth contour roughness nHeight profile xTilt flood]
set S(v,depth) 3 ;# Number of iterations
set S(v,contour) 1.00 ;# The contour of the mountain
set S(v,roughness) 2.75 ;# How jagged the mountain
set S(v,nHeight) 7 ;# Max height of mountain
set S(v,profile) 1 ;# Profile number (1-4)
set S(v,xTilt) 80 ;# Tilt angle (in degrees)
set S(v,flood) 50
set M(d,depth) -1 ;# No map yet
set S(maxIter) 9 ;# Bounds our height
set S(normalHeightBase) 10000 ;# Normalized height
set S(normalHeightBase) 10000 ;# Normalized height
set S(water) 0 ;# Water level altitude
set S(nocolor) 0
set S(seed) 0
# Unit vector to our light source
set S(lx) [= {-1 / sqrt(3)}]; set S(ly) [= {-$S(lx)}]; set S(lz) [= {-$S(lx)}]
set MIN_INT 0x80000000
set DEG2RAD [= {4*atan(1)*2/360}]
proc LMAP {a b v} { lset ::map [= {$a + $b*$::M(S)}] $v; return}
proc LMAP {a b v} { lset ::map [= {$a + $b*$::M(S)}] $v}
proc LMAP1 {a v} { lset ::map $a $v; return}
proc RMAP {a b} { return [lindex $::map [= {$a + $b*$::M(S)}]]}
proc RMAP1 {a} { return [lindex $::map $a]}
##+##########################################################################
#
# Go - Computes the new mountain and draws it.
#
proc Go {{how 1}} {
global S M
set start [clock click -milliseconds]
clear
if {$how == 1} {
set M(d,depth) -1 ;# Force recalculation
set S(seed) [clock clicks -milliseconds]
}
set S(draw) 1
ToggleButtons 1
CalcMountains
DrawMountains
set xysc [= {50.0 / (1 << $M(d,depth))}]
# set zsc [= {.005 / (1 << $M(d,depth))}]
set zsc .0005
.gl eval -matrixmode modelview -loadidentity -scale $xysc $xysc $zsc
set start [= {([clock click -milliseconds] - $start) / 1000}]
Stop
set msg "Iterations: $S(w,depth) Contour: $M(d,contour) "
append msg "Smoothness: $M(d,roughness) Height: $M(d,nHeight) "
append msg "Profile: $M(d,profile) Tilt: $S(w,xTilt) ([Duration $start])"
INFO $msg
}
proc Stop {} {
global S
set S(draw) 0
ToggleButtons 0
ProgressBar 1 0
}
##+##########################################################################
#
# CopyParameters
#
# Copies gui/want/data parameter values to g/w/d as requested
#
proc CopyParameters {from to} {
global S M
foreach v [array names S $from,*] {
foreach {a b} [split $v ,] break
if {$to == "d"} {
set M($to,$b) $S($v)
} else {
set S($to,$b) $S($v)
}
}
}
##+##########################################################################
#
# CalcMountains
#
# Initializes our mountain grid for the profile and then does the
# recursive iterations to build up our fractal. It then normalizes
# all the data to be under a certain height.
#
proc CalcMountains {} {
global M S
CopyParameters v w ;# Params the user wants to use
set n [CompareParameters] ;# Is data still valid???
if {$n == 2} {
INFO "Reusing existing mountain data"
return
}
# Generate each main triangle recursively
InitMountains $n
INFO "Calculating the [comma [= {1 + $M(N)}]] points in the display"
IterCalc 0 $M(D) $M(N) [= {$S(maxIter)+1}]
IterCalc [= {$M(S) * $M(D)}] $M(N) 0 [= {$S(maxIter)+1}]
NormalizeMap
CopyParameters w d ;# Parameters for our data
return
}
##+##########################################################################
#
# CompareParameters: returns TRUE if data is still ok for S(w,*) params
# 0 - total mismatch
# 1 - new depth is greater
# 2 - compatible
#
proc CompareParameters {} {
global M S
if {$M(d,depth) == -1} {return 0} ;# No map data
foreach v [array names S w,*] {
if {$v == "w,depth"} continue
if {$v == "w,xTilt"} continue ;# Only visual affects
if {$v == "w,flood"} continue ;# Only visual affects
foreach {a b} [split $v ,] break
if {$M(d,$b) != $S(w,$b)} { return 0}
}
if {$S(w,depth) <= $M(d,depth)} { return 2} ;# Less deep, okay
return 1
}
##+##########################################################################
#
# InitMountains
#
# Creates the initial grid for our mountain.
#
proc InitMountains {up} {
global map M S MIN_INT
if {$up} {
set map2 $map ; set D $M(d,depth) ; set MD $M(D) ; set MS $M(S)
}
= {srand($S(seed))}
set M(D) [= {1 << $S(w,depth)}]
set M(S) [= {$M(D) + 1}] ;# Points along side of triangle
set M(N) [= {$M(S) * $M(S) - 1}] ;# Last point in our grid
set S(normalHeight) [= {$S(normalHeightBase) * $S(w,nHeight)}]
set map [string repeat " $MIN_INT" [= {1+$M(N)}]] ;# Our mountain
if {$up} {
GoDeeper $map2 $D $MD $MS
return
}
# Generate starting profile to build on
set q [MaxDeviation [= {$S(maxIter)+1}]]
set q [= {$q / 2}]
set nq [= {-$q}]
set d2 [= {$M(D) / 2}]
if {$S(w,profile) == 1} { ;# Back up, front down, corner 0
LMAP 0 0 $q
LMAP $M(D) 0 0
LMAP 0 $M(D) 0
LMAP $M(D) $M(D) $nq
} elseif {$S(w,profile) == 2} { ;# Back up; side/corners 0
LMAP 0 0 $q
LMAP $M(D) 0 0
LMAP 0 $M(D) 0
LMAP $M(D) $M(D) 0
if {$d2 > 0} {
LMAP $d2 $d2 0
LMAP $d2 $M(D) 0
LMAP $M(D) $d2 0
}
} elseif {$S(w,profile) == 3} { ;# front down, corners 0
LMAP 0 0 0
LMAP $M(D) 0 0
LMAP 0 $M(D) 0
LMAP $M(D) $M(D) $nq
} elseif {$S(w,profile) == 4} {
LMAP 0 0 0
LMAP $M(D) 0 0
LMAP 0 $M(D) 0
LMAP $M(D) $M(D) 0
if {$d2 > 0} {
LMAP $d2 $d2 [= {$q/2}]
LMAP $d2 0 $q
LMAP 0 $d2 $q
}
} elseif {$S(w,profile) == 5} {
LMAP 0 0 $q
LMAP $M(D) 0 0
LMAP $d2 0 [= {$q / 2}]
LMAP 0 $M(D) 0
LMAP $M(D) $M(D) $nq
} else {
error "profile out of range (1-4): $S(w,profile)"
}
}
##+##########################################################################
#
# GoDeeper - Transfers all elevation info from old map at level D
# into the current map. IterCalc still needs to be called to fill
# in the rest of the slots.
#
proc GoDeeper {map2 D MD MS} {
global map S M
set step [= {1 << ($S(w,depth) - $D)}]
set idx -1
for {set y 0} {$y < $M(S)} {incr y $step} {
for {set x 0} {$x < $M(S)} {incr x $step} {
LMAP $x $y [lindex $map2 [incr idx]]
}
}
}
##+##########################################################################
#
# MaxDeviation
#
# Returns the maximum deviation allowed for a given recursion depth.
# The function is strictly decreasing monotonic as depth increases.
#
proc MaxDeviation {ic} {
global S
if {$S(w,roughness) == 0} { return 100000 }
return [= {int(8.0 * pow ($S(w,roughness), $ic-1))}]
}
##+##########################################################################
#
# NormalizeMap
#
# Scales all heights to be w/i normalHeight and applies contour transformation.
#
proc NormalizeMap {} {
global map S M MIN_INT
set max [lindex $map 0] ;# Get max height
foreach v $map {
if {$v > $max} { set max $v}
}
if {$max <= 0} {set max 10000} ;# All water, avoid divide by 0
set z [= {pow($max, $S(w,contour))}]
set z [= {$S(normalHeight) / $z}]
set map2 {}
set min [set max 0]
foreach k $map {
if {$k >= 0} {
set i [= {pow($k, $S(w,contour)) * $z}]
set val [= {int($i)}]
if {$val > $max} {set max $val}
} else {
set i [= {pow(-$k, $S(w,contour)) * $z}]
set val [= {int(-$i)}]
if {$val < $min} {set min $val}
}
lappend map2 $val
}
set map $map2
set M(min) $min
set M(max) $max
return
}
##+##########################################################################
#
# IterCalc
#
# Given three points of a triangle it calculates the midpoints of each
# side and recurses. Parameter c is the depth.
#
proc IterCalc {s1 s2 a c} {
global map MIN_INT
incr c -1 ;# Decrement iteration count
set ns1 [= {($s1 + $a) / 2}] ;# Midpoints of sub-triangle
set ns2 [= {($s2 + $a) / 2}]
set na [= {($s1 + $s2) / 2}]
set vs1 [RMAP1 $s1]
set vs2 [RMAP1 $s2]
set va [RMAP1 $a]
if {[RMAP1 $ns1] == $MIN_INT} {
LMAP1 $ns1 [= {($vs1 + $va) / 2}]
DeviatePoint $ns1 $c
}
if {[RMAP1 $ns2] == $MIN_INT} {
LMAP1 $ns2 [= {($vs2 + $va) / 2}]
DeviatePoint $ns2 $c
}
if {[RMAP1 $na] == $MIN_INT} {
LMAP1 $na [= {($vs1 + $vs2) / 2}]
DeviatePoint $na $c
}
# Recurse on sub-triangles if we haven't bottomed out
if {$ns1 + 1 >= $ns2} return
IterCalc $s1 $na $ns1 $c
IterCalc $na $s2 $ns2 $c
IterCalc $ns1 $ns2 $na $c
IterCalc $ns1 $ns2 $a $c
}
##+##########################################################################
#
# DeviatePoint
#
# Deviates a point up or down by a random amount between
# -MaxDeviation to +MaxDeviation.
#
proc DeviatePoint {o ic} {
global map S
if {$S(w,roughness) < 0} return
set v [MaxDeviation $ic]
set r [Rand [= {-$v}] $v]
LMAP1 $o [= {[RMAP1 $o] + $r}]
}
##+##########################################################################
#
# Rand
#
# Returns a random number between first and last.
#
proc Rand {first last} {
set delta [= {$last - $first + 1}]
set r [= {$first + int(rand() * $delta)}]
return $r
}
proc PrintData {} {
global map M
set cnt 0
foreach v $map {
if {$v == 0x80000000} {
puts -nonewline [format "%9s" --]
} else {
puts -nonewline [format "% 9ld" $v]
}
if {([incr cnt] % $M(S)) == 0} { puts ""}
}
}
#
# Drawing routines
#
##+##########################################################################
#
# DrawMountains
#
# Sets up the transformation variables and then draws all the triangles.
#
proc DrawMountains {{lvl ""}} {
global tm M S xc sc wx wy
global l dlist
set dlist {}
if {$lvl == ""} { ;# Called from Go
set lvl $S(w,depth)
update
if {$S(draw) == 0} return
}
if {$lvl > $M(d,depth)} { error "ERROR: Can't display level $lvl" }
if {$lvl <= 0} {
set lvl [= {$M(d,depth) + $lvl}]
if {$lvl < 0} { set lvl 0 }
}
set D [= {1 << $lvl}] ;# Nodes per side
set step [= {1 << ($M(d,depth) - $lvl)}] ;# Step size for this data set
INFO "Drawing the [comma [= {2*$D*$D}]] triangles in the display"
set S(draw) 1
set wx [winfo width .gl]
set wy [winfo height .gl]
set wd [expr {$wx > $wy ? $wy : $wx}]
set xc [= {0.4073 * (1 << ($S(maxIter) - $S(w,depth)))}]
set xc [= {0.4073 * (1 << ($S(maxIter) - $M(d,depth)))}]
set sc [= {$wd / 630.0}]
# Make transformation matrix for rotating around x axis
set tm(0,0) 1
set tm(1,0) 0
set tm(2,0) 0
set tm(0,1) 0
set tm(1,1) [= {cos(-$S(w,xTilt) * $::DEG2RAD)}]
set tm(2,1) [= {sin(-$S(w,xTilt) * $::DEG2RAD)}]
set tm(0,2) 0
set tm(1,2) [= {-sin(-$S(w,xTilt) * $::DEG2RAD)}]
set tm(2,2) [= {cos(-$S(w,xTilt) * $::DEG2RAD)}]
# Figure out water level
set S(water) [= {$M(min) + $S(w,flood) * ($M(max) - $M(min)) / 100.0}]
# Go back to front, left to right, and draw each triangle
# .c delete triag2
for {set y 0} {$y < $M(D)} {incr y $step} {
set y1 [= {$y + $step}]
for {set x 0} {$x < $M(D)} {incr x $step} {
set x1 [= {$x + $step}]
DrawTriangle $x $y $x $y1 $x1 $y1
DrawTriangle $x $y $x1 $y1 $x1 $y
}
ProgressBar $y $M(D)
update
if {! $S(draw)} break
}
ProgressBar 1 0
eval .gl newlist $l $dlist
.gl redraw
# set sr [.c bbox all]
}
##+##########################################################################
#
# DrawTriangle
#
# Draw a given triangle. This routine is mainly concerned with the
# possibility that a triangle could span the waterline. If this
# occurs, this procedure breaks it up into three smaller triangles,
# each of which is either above or below water. All actual drawing or
# coloration is delegated to _DrawTriangle.
#
proc DrawTriangle {x0 y0 x1 y1 x2 y2} {
global S
set z0 [RMAP $x0 $y0]
set z1 [RMAP $x1 $y1]
set z2 [RMAP $x2 $y2]
# Easy cases: all underwater or all above water
if {$z0 <= $S(water) && $z1 <= $S(water) && $z2 <= $S(water)} {
_DrawTriangle $x0 $y0 $S(water) $x1 $y1 $S(water) $x2 $y2 $S(water)
} elseif {$z0 >= $S(water) && $z1 >= $S(water) && $z2 >= $S(water)} {
_DrawTriangle $x0 $y0 $z0 $x1 $y1 $z1 $x2 $y2 $z2
} else { ;# Spans the water line
set p0 [list $x0 $y0 $z0]
set p1 [list $x1 $y1 $z1]
set p2 [list $x2 $y2 $z2]
set w(0) [= {$z0 < $S(water)}]
set w(1) [= {$z1 < $S(water)}]
set w(2) [= {$z2 < $S(water)}]
if {$w(0) != $w(1) && $w(0) != $w(2)} {
set ap $p0
set s0 $p1
set s1 $p2
} elseif {$w(1) != $w(0)} {
set s1 $p0
set ap $p1
set s0 $p2
} else {
set s0 $p0
set s1 $p1
set ap $p2
}
foreach {apx apy apz} $ap break
foreach {s(0,x) s(0,y) s(0,z)} $s0 break
foreach {s(1,x) s(1,y) s(1,z)} $s1 break
# At this point, ap is the "odd man out" - either it is above
# water and the other two are below, or it is below and the
# other two are above. Which corner s[0] is and which s[1] is
# *is* important - if we get the wrong order, the normal
# vector used to find the shading coefficient is the wrong
# sign. This is true whenever we are manipulating corners -
# the ordering is always important.
# Find the "midpoints" between ap and s[0]&s[1] - this is
# where we split our big triangle into smaller triangles.
# Actually it is not a normal midpoint, but a weighted
# midpoint, such that the z component is 0 - waterline.
foreach n {0 1} {
set f($n) [= {-1.0 * ($apz - $S(water)) / ($s($n,z) - $apz)}]
set m($n,x) [= {$apx - ($apx - $s($n,x)) * $f($n)}]
set m($n,y) [= {$apy - ($apy - $s($n,y)) * $f($n)}]
set m($n,z) $S(water)
}
# Set whichever triangles are below water to 0 altitude
if {$apz < $S(water)} {set apz $S(water)} else {
set s(0,z) $S(water); set s(1,z) $S(water)}
# Draw our three triangles
_DrawTriangle $apx $apy $apz $m(0,x) $m(0,y) $m(0,z) \
$m(1,x) $m(1,y) $m(1,z)
_DrawTriangle $m(0,x) $m(0,y) $m(0,z) $s(0,x) $s(0,y) $s(0,z) \
$s(1,x) $s(1,y) $s(1,z)
_DrawTriangle $m(0,x) $m(0,y) $m(0,z) $s(1,x) $s(1,y) $s(1,z) \
$m(1,x) $m(1,y) $m(1,z)
}
}
##+##########################################################################
#
# _DrawTriangle
#
# This routine actually draws a triangle, given by a set of three
# (x,y,z) triplets. It determines the color and shading according to
# altitude and lighting, and draws the triangle.
#
variable ::UseShadingModel 1
proc _DrawTriangle {x1 y1 z1 x2 y2 z2 x3 y3 z3} {
global S dlist UseShadingModel
# Figure out what color we want: blue, green or gray
if {$z1 == $S(water) && $z2 == $S(water) && $z3 == $S(water)} {
set color ".6 .6 1" ;# water
} elseif {$UseShadingModel} {
set treeline [expr {.4 * $S(normalHeight) + 10000}]
set snowcap [expr {$treeline + 19000}]
set az [expr {($z1 + $z2 + $z3) / 3.0}] ;# Average height
if {$az > $snowcap} {
set color 150 ;# Gray
} elseif {$az < $treeline} {
set color 0 ;# Green
} else {
set color [expr {($az - $treeline) / (($snowcap - $treeline)/150)}]
}
# Compute cosine of angle of triangle normal to "light direction"
set dx1 [expr {$x2-$x1}]
set dy1 [expr {$y2-$y1}]
set dz1 [expr {($z2-$z1)/20000}] ;# Fudge factor
set dx2 [expr {$x3-$x1}]
set dy2 [expr {$y3-$y1}]
set dz2 [expr {($z3-$z1)/20000}] ;# Fudge factor
set nx [expr {$dy1*$dz2 - $dz1*$dy2}]
set ny [expr {$dz1*$dx2 - $dx1*$dz2}]
set nz [expr {$dx1*$dy2 - $dy1*$dx2}]
set nlen [expr {hypot(hypot($nx, $ny), $nz)}]
set cosangle [expr {abs(($nz*.8+$nx*.6)/($nlen+.00001))}]
# Blend to brown and white over treeline (work in hsv color model)
set C [expr {(150-$color) / 150.0}]
set h [expr {$C * (120 - 45) + 45}] ;# 120 -> 45
set s $C ;# 1 -> 0
set v [expr {.9 - $C * (.94-2.0/3) - (1.-$cosangle)/3}] ;# .94 -> .667
set color [hsv2rgb $h $s $v]
} else {
set treeline [= {.4 * $S(normalHeight) + 10000}]
set snowcap [= {$treeline + 19000}]
set az [= {($z1 + $z2 + $z3) / 3.0}] ;# Average height
if {$az > $snowcap} {
set color 150 ;# Gray
} elseif {$az < $treeline} {
set color 0 ;# Green
} else {
set color [= {($az - $treeline) / (($snowcap - $treeline)/150)}]
}
# Blend to brown and white over treeline (work in hsv color model)
set C [= {(150-$color) / 150.0}]
set h [= {$C * (120 - 45) + 45}] ;# 120 -> 45
set s $C ;# 1 -> 0
set v [= {.94 - $C * (.94 - 2.0/3)}] ;# .94 -> .667
set color [hsv2rgb $h $s $v]
}
append dlist " -color $color \
-begin triangles \
-vertex $x1 $y1 $z1 \
-vertex $x2 $y2 $z2 \
-vertex $x3 $y3 $z3 \
-end "
}
##+##########################################################################
#
# hsv2rgb
#
# Convert from HSV color model to RGB model. h is 0.0 to 360.0, s and v
# are 0.0 to 1.0.
#
proc hsv2rgb {h s v} {
set v [= {double($v)}]
set r [set g [set b 0.0]]
if {$h == 360 || $h == -1} { set h 0 }
set h [= {$h/60}]
set i [= {int(floor($h))}]
set f [= {$h - $i}]
set p1 [= {$v*(1-$s)}]
set p2 [= {$v*(1-($s*$f))}]
set p3 [= {$v*(1-($s*(1-$f)))}]
switch -- $i {
0 { set r $v ; set g $p3 ; set b $p1 }
1 { set r $p2 ; set g $v ; set b $p1 }
2 { set r $p1 ; set g $v ; set b $p3 }
3 { set r $p1 ; set g $p2 ; set b $v }
4 { set r $p3 ; set g $p1 ; set b $v }
5 { set r $v ; set g $p1 ; set b $p2 }
}
return [list $r $g $b]
}
#
# GUI stuff
#
proc DoDisplay {} {
wm title . "Fractal Mountains"
wm protocol . WM_DELETE_WINDOW exit
DoMenus
frame .bottom -bd 2 -relief ridge
OGLwin .gl -width 600 -height 600
global l
set l [.gl newlist]
set ax [.gl newlist \
-begin lines \
-vertex 0 0 0 -vertex 500 0 0 \
-vertex 495 5 0 -vertex 505 -5 0 \
-vertex 495 -5 0 -vertex 505 5 0 \
-vertex 0 0 0 -vertex 0 500 0 \
-vertex -5 505 0 -vertex 5 500 0 \
-vertex 5 505 0 -vertex -5 495 0 \
-vertex 0 0 0 -vertex 0 0 500 \
-end ]
set lt [.gl newlist \
-light light0 diffuse 0.9 0.9 0.7 \
-light light0 specular 1 1 1 \
-light light0 position 1000 1000 1000 \
-light light0 spotdirecion -1 -1 -1 \
]
.gl mainlist -clear colorbuffer depthbuffer -call $ax -call $l -call $lt
.gl eval -matrixmode projection \
-loadidentity \
-ortho -50 50 -50 50 -80 50 \
-rotate 135 0 0 -1 \
-rotate 315 -1 1 0 \
-disable lighting \
-enable light0 \
-enable colormaterial -enable depthtest
canvas .msg -bd 1 -relief sunken -height 20 -highlightthickness 0
.msg xview moveto 0 ; .msg yview moveto 0
.msg create text 5 2 -tag txt -anchor nw
pack .bottom -side right -fill y
pack .msg -side bottom -fill x
pack .gl -side top -fill both -expand 1
proc rescale {args} {
global px1 px2 py1 py2 pz1 pz2
.gl eval -matrixmode modelview \
-loadidentity \
-scale $pz2 $pz2 $pz2 \
-rotate 180 1 0 0
.gl redraw
}
# bindings for GL window
set ::lenable 0
focus .gl
bind .gl <space> {
if {$lenable} {
.gl eval -disable lighting
.gl redraw
set lenable 0
} else {
.gl eval -enable lighting
.gl redraw
set lenable 1
}
}
bind .gl <Button-1> { set x %x ; set y %y }
set ::pmode fill
bind .gl <B1-Motion> {
set xrot [expr %x - $x]
set yrot [expr %y - $y]
set x %x
set y %y
.gl eval -matrixmode projection \
-rotate $xrot 0 0 1\
-rotate $yrot -1 1 0
.gl redraw
}
bind .gl <Button-3> {
if {$pmode=="fill"} { set pmode line } else { set pmode fill }
.gl eval -polygonmode frontandback $pmode
.gl redraw
}
set ::moving 0
bind .gl <ButtonPress-2> {
set ::moving 1
after 0 move
}
bind .gl <ButtonRelease-2> {
set ::moving 0
}
proc move {} {
if {!$::moving} return
.gl eval -matrixmode projection \
-translate 0 0 1
.gl redraw
after 10 move
}
myOptMenu .f1 Iterations S(v,depth) 1 2 3 4 5 6 7 8 9
myOptMenu .f2 Contour S(v,contour) \
0.25 0.50 0.75 1.00 1.25 1.50 1.75 2.00 3.00 5.00
myOptMenu .f3 Smoothness S(v,roughness) \
1.00 1.25 1.50 1.75 2.00 2.25 2.75 3.50 5.00
myOptMenu .f4 Height S(v,nHeight) 1 2 3 4 5 6 7 8 9
myOptMenu .f5 Profile S(v,profile) 1 2 3 4 5
myScale .f6 " Water\n Level" S(v,flood) 0 100
frame .spacer
button .go -text "Draw Mountain" -command {Go 1} -bd 4
button .redraw -text "Redraw Mountain" -command {Go 2} -bd 4 -state disabled
button .stop -text "Stop Drawing" -command Stop -bd 4 -state disabled
.go configure -font "[font actual [.go cget -font]] -weight bold"
.redraw configure -font [.go cget -font]
.stop configure -font [.go cget -font]
grid .f1 - - -in .bottom -sticky ew -row 0
grid .f2 - - -in .bottom -sticky ew
grid .f3 - - -in .bottom -sticky ew
grid .f4 - - -in .bottom -sticky ew
grid .f5 - - -in .bottom -sticky ew
grid .f6 - - -in .bottom -sticky ew
grid .spacer -in .bottom -pady 10 -row 50
grid x .go x -in .bottom -sticky ew
grid x .redraw x -in .bottom -sticky ew
grid x .stop x -in .bottom -sticky ew -pady 10
grid rowconfigure .bottom 100 -weight 1
bind all <Alt-c> {console show}
update
}
proc myScale {f lbl var from to} {
frame $f -bd 2 -relief raised
label $f.lbl -text $lbl -bd 0 -anchor w
label $f.lbl2 -text "value%"
scale $f.s -orient h -from $from -to $to -showvalue 0 -variable $var
$f.s config -command [list myScale2 $f.lbl2]
pack $f.lbl -side left -expand 1 -fill x
pack $f.lbl2 -side top
pack $f.s -side bottom
return $f
}
proc myScale2 {w value} {
$w config -text "$value%"
}
proc DoMenus {} {
. configure -menu [menu .m -tearoff 0]
.m add cascade -menu [menu .m.file -tearoff 0] -label "File" -underline 0
.m add cascade -menu [menu .m.help -tearoff 0] -label "Help" -underline 0
.m.file add command -label "Draw Mountain" -under 0 -command {Go 1}
.m.file add command -label "Redraw Mountain" -under 0 -command {Go 2}
.m.file add command -label "Stop Drawing" -under 0 -command {Go 0}
.m.file add separator
.m.file add command -label Exit -under 0 -command exit
.m.help add command -label Help -under 0 -command Help
.m.help add separator
.m.help add command -label About -under 0 -command About
}
set SplashData {
{{ 56 35 93 50 74 32} E2E2E2} {{ 93 50 112 33 74 32} D8D8D8}
{{ 93 50 130 56 112 33} CED19D} {{130 56 149 56 112 33} 97C35A}
{{162 87 159 89 168 89} 9f9fff} {{149 56 130 56 162 87} 00A700}
{{130 56 159 89 162 87} 00A700} {{174 86 162 87 168 89} 9f9fff}
{{186 64 149 56 174 86} 00A200} {{149 56 162 87 174 86} 00A200}
{{174 86 193 84 186 64} 00A700} {{168 89 205 89 174 86} 9f9fff}
{{205 89 193 84 174 86} 9f9fff} {{223 82 193 84 205 89} 9f9fff}
{{186 64 193 84 223 82} 00A500} {{ 37 57 74 66 56 35} D4D6A4}
{{ 74 66 93 50 56 35} DCDCB0} {{ 74 66 112 59 93 50} 6FA13F}
{{112 59 130 56 93 50} 88B251} {{144 93 140 95 149 95} 9f9fff}
{{130 56 112 59 144 93} 00A800} {{112 59 140 95 144 93} 00A800}
{{144 93 159 89 130 56} 00A900} {{149 95 168 89 144 93} 9f9fff}
{{168 89 159 89 144 93} 9f9fff} {{149 95 186 95 168 89} 9f9fff}
{{186 95 205 89 168 89} 9f9fff} {{ 19 81 56 82 37 57} 009B00}
{{ 56 82 74 66 37 57} 00A100} {{ 56 82 93 90 74 66} 00A000}
{{ 93 90 112 59 74 66} 009200} {{ 93 90 130 101 112 59} 00A400}
{{140 95 132 101 149 95} 9f9fff} {{112 59 130 101 140 95} 00A500}
{{130 101 132 101 140 95} 00A500} {{131 102 132 101 130 101} 00A500}
{{168 102 149 95 131 102} 9f9fff} {{149 95 132 101 131 102} 9f9fff}
{{168 102 186 95 149 95} 9f9fff} {{ 33 107 5 108 37 108} 9f9fff}
{{ 19 81 5 108 33 107} 00A000} {{ 5 108 5 108 33 107} 9f9fff}
{{ 42 107 33 107 37 108} 9f9fff} {{ 56 82 19 81 42 107} 009C00}
{{ 19 81 33 107 42 107} 009C00} {{ 55 108 42 107 37 108} 9f9fff}
{{ 74 102 56 82 55 108} 008A00} {{ 56 82 42 107 55 108} 008A00}
{{ 74 102 93 90 56 82} 009E00} {{100 104 83 108 112 108} 9f9fff}
{{ 93 90 74 102 100 104} 00AA00} {{ 74 102 83 108 100 104} 00AA00}
{{130 102 100 104 112 108} 9f9fff} {{130 101 93 90 130 102} 00A400}
{{ 93 90 100 104 130 102} 00A400} {{130 102 131 102 130 101} 00A900}
{{112 108 149 108 130 102} 9f9fff} {{149 108 131 102 130 102} 9f9fff}
{{131 102 131 102 130 101} 00A900} {{149 108 168 102 131 102} 9f9fff}
{{168 102 131 102 131 102} 9f9fff}}
##+##########################################################################
#
# Splash
#
# Draws our startup screen
#
proc Splash {{w .c}} {
$w delete all
font create myfont -family Times -size 72
foreach cmd $::SplashData {
$w create poly [lindex $cmd 0] -fill "\#[lindex $cmd 1]" \
-tag [list triag [lindex $cmd 1]]
}
foreach {l t r b} [$w bbox triag] break
set x $r
set y [= {($t + $b)/2}]
$w create text $x $y -text "Fractal" -anchor w -font myfont -tag {L1 txt}
set x [= {[winfo width $w] / 2}]
if {$x == 0} { set x [= {[winfo reqwidth $w] / 2}]}
foreach {l t r b} [$w bbox L1] break
set y [= {$y + $b - $t}]
$w create text $x $y -text "Mountains" -anchor c -font myfont -tag {L2 txt}
foreach {l t r b} [$w bbox L2] break
set y [= {$y + $b - $t}]
$w create text $x $y -text "by" -font {Times 24} -tag by
foreach {l t r b} [$w bbox by] break
set y [= {$y + $b - $t}]
$w create text $x $y -text "Keith Vetter" -font {Times 24}
set y [= {$y + $b - $t}]
$w create text $x $y -text "Version $::S(version) $::S(date)" \
-font {Times 12}
font delete myfont
}
##+##########################################################################
#
# About - simple about dialog
#
proc About {} {
catch {destroy .about}
toplevel .about
wm title .about "About Fractal Mountains"
button .about.dismiss -text "Dismiss" -command {destroy .about}
canvas .about.c -bd 2 -relief raised -width 600 -height 450
pack .about.dismiss -side bottom -pady 10
pack .about.c -side top -fill both -expand 1
Splash .about.c
}
##+##########################################################################
#
# Help -- a simple help screen
#
proc Help {} {
catch {destroy .help}
toplevel .help
wm title .help "Fractal Mountains Help"
wm geom .help "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
text .help.t -relief raised -wrap word -width 70 -height 23 \
-padx 10 -pady 10 -cursor {} -yscrollcommand {.help.sb set}
scrollbar .help.sb -orient vertical -command {.help.t yview}
button .help.dismiss -text Dismiss -command {destroy .help}
pack .help.dismiss -side bottom -pady 10
pack .help.sb -side right -fill y
pack .help.t -side top -expand 1 -fill both
set bold "[font actual [.help.t cget -font]] -weight bold"
set italic "[font actual [.help.t cget -font]] -slant italic"
.help.t tag config title -justify center -foregr red -font "Times 20 bold"
.help.t tag configure title2 -justify center -font "Times 12 bold"
.help.t tag configure bullet -font $bold
.help.t tag configure ital -font $bold -lmargin1 15
.help.t tag configure bn -lmargin1 15 -lmargin2 15
.help.t tag configure bn2 -lmargin1 15 -lmargin2 40
.help.t insert end "Fractal Mountains\n" title
.help.t insert end "by Keith Vetter\n\n" title2
set m "Fractal Mountains displays a landscape generated using fractals. "
append m "It is based on code and article by Ben Haller at "
append m "http://www.mactech.com/articles/mactech/ "
append m "Vol.07/07.05/FractalMountains/.\n\n"
.help.t insert end $m
.help.t insert end "Display Parameters\n" bullet
.help.t insert end "Iterations" ital
.help.t insert end "how detailed the mountain will be.\n" bn2
.help.t insert end "Contour" ital
.help.t insert end "controls relative steepness at different " bn2
.help.t insert end "heights, with higher numbers giving steep peaks " bn2
.help.t insert end "and flatter lowlands.\n" bn2
.help.t insert end "Smoothness" ital
.help.t insert end "controls how jagged the sides of the mountains " bn2
.help.t insert end "will be.\n"
.help.t insert end "Height" ital
.help.t insert end "controls the overall height of the mountain.\n" bn2
.help.t insert end "Profile" ital
.help.t insert end "selects from a number of initial shapes.\n" bn2
.help.t insert end "Tilt" ital
.help.t insert end "selects the viewing angle.\n" bn2
.help.t insert end "Water Level" ital
.help.t insert end "selects altitude for the water as a percantage " bn2
.help.t insert end "of maximun height or depth.\n\n" bn2
set m "Fractal Mountains starts with two side-by-side equilateral "
append m "triangles in the shape of a parallelogram and assigns an "
append m "altitude to each vertex. Next, each triangle is subdivided "
append m "into four similar smaller triangles by adding vertices at the "
append m "midpoint of each side. These new vertices are given an altitude "
append m "which is the average of the two vertices at the end of that side "
append m "with a random deviation added in. Thus, each iteration "
append m "quadruples the number of triangles, thereby increasing the "
append m "details of the mountain.\n\n"
.help.t insert end "Generating a Fractal Mountain\n" bullet $m bn
set m "Redraw lets you see the affects of changing different parameters on "
append m "the same shaped mountain. For example, you could change the "
append m "height parameter, hit Redraw Mountain, and see the same mountain "
append m "at different heights. For all parameters except iterations, "
append m "this can be done by using the same sequence of random numbers. "
append m "For iterations we must do something different. If we decrease "
append m "iterations, we sub-sample the existing data. If we increase it, "
append m "we transfer existing data into the new template and call our "
append m "fractal engine to fill in the missing slots.\n\n"
append m "The ability to redraw at an increased depth is very useful in "
append m "generating pretty mountains at high detail. You can't tell if "
append m "a random scene is a good one until you've drawn it, but at "
append m "level 7 and above this takes a long time. The solution is to "
append m "draw the scene at a lower level, say 5 or 6, then if you like "
append m "the basic shape, increase the iteration level and redraw it.\n\n"
.help.t insert end "Redraw Mountain Button\n" bullet $m bn
.help.t config -state disabled
}
##+##########################################################################
#
# myOptMenu - creates a label and optionMenu combination
#
proc myOptMenu {f lbl var args} {
frame $f -bd 2 -relief raised
label $f.lbl -text " $lbl" -bd 0 -anchor w
eval tk_optionMenu $f.opt $var $args
$f.opt config -bd 0 -highlightthickness 0
pack $f.lbl -side left -fill x -expand 1
pack $f.opt -side right
return $f
}
##+##########################################################################
#
# ProgressBar -- draws colored progress bar the right length in .msg
#
proc ProgressBar {num max} {
global state
set w .msg
$w delete progress
if {$max == 0} return
set width [winfo width $w]
set height [winfo height $w]
set x [= {$num * $width / double($max)}]
$w create rect 0 0 $x $height -tag progress -fill cyan -outline cyan
$w lower progress
}
##+##########################################################################
#
# ToggleButtons -- enables/disables command buttons
#
proc ToggleButtons {onoff} {
set offon [= {! $onoff}]
array set state {0 disabled 1 normal}
.go config -state $state($offon)
.m.file entryconfig 0 -state $state($offon)
.redraw config -state $state($offon)
.m.file entryconfig 1 -state $state($offon)
.stop config -state $state($onoff)
.m.file entryconfig 2 -state $state($onoff)
}
proc INFO {txt} {
.msg itemconfig txt -text $txt
update
}
proc clear {} {
# .c delete all
ProgressBar 1 0
}
##+##########################################################################
#
# comma -- adds commas to a number
#
proc comma {n} {
while {[regsub {^([-+]?\d+)(\d{3})} $n {\1,\2} n]} {}
return $n
}
##+##########################################################################
#
# Duration - Prints out seconds in a nice format
#
proc Duration { int_time } {
if {$int_time == 0} {return "0 secs"}
set timeList [list]
foreach div {86400 3600 60 1} mod {0 24 60 60} name {day hr min sec} {
set n [expr {$int_time / $div}]
if {$mod > 0} {set n [expr {$n % $mod}]}
if {$n > 1} {
lappend timeList "$n ${name}s"
} elseif {$n == 1} {
lappend timeList "$n $name"
}
}
return [join $timeList]
}
DoDisplay