# Mandelbrot shader using GPGPU techniques
#
# Author: Gabriel Zachmann, June 2007
#
# The code is derived from ../fbo_demo/saxpy.cpp
#
# The original code can be found at:
# http://zach.in.tu-clausthal.de/teaching/cg2_08/downloads/simple_glsl_demos.tar.gz
#
# Modified and extended for Tcl3D by Paul Obermeier 2009/01/04
# See www.tcl3d.org for the Tcl3D extension.
package require Tk
package require Img
package require tcl3d
tcl3dConsoleCreate .tcl3dOutputConsole "# " "Info Messages"
# Font to be used in the Tk listbox.
set g_listFont {-family {Courier} -size 10}
set g_WinWidth 512
set g_WinHeight 512
set g_Stopwatch [tcl3dNewSwatch]
tcl3dStartSwatch $::g_Stopwatch
# command line options
set g_Opts(NumIter) 50 ; # Number of function iterations
set g_Opts(RangeCenter,0) -0.6
set g_Opts(RangeCenter,1) 0.0
set g_Opts(RangeSize) 3.0 ; # Square section of the Mandelbrot set
# Stack for holding zoom parameters.
lappend gBox(stack) [list $g_Opts(RangeCenter,0) $g_Opts(RangeCenter,1) $g_Opts(RangeSize)]
# Will be set to true in CreateCallback, if all needed OpenGL extensions are available.
set g_Opts(haveOglExtensions) false
set g_Opts(TexSize,X) $::g_WinWidth ; # Resolution of the range of the M-set
set g_Opts(TexSize,Y) $::g_WinHeight ; # Resolution of the range of the M-set
set g_ColorMethods [list "Random" "Renorm"]
set g_Opts(ColorMethod) "Renorm"
set g_Opts(BackColor) #00FF00
set g_Opts(InnerColor) #FF0000
set g_Opts(OuterColor) #0000FF
set g_Opts(BandFrequ) 0.02
set gBox(x1) 100
set gBox(x2) 300
set gBox(y1) 100
set gBox(y2) 300
set gBox(draw) 0
set attachmentpoints [list $::GL_COLOR_ATTACHMENT0_EXT $::GL_COLOR_ATTACHMENT1_EXT]
# Determine the directory of this script.
set g_ScriptDir [file dirname [info script]]
# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
# Print info message into widget a the bottom of the window.
proc PrintGeneralInfo {} {
global tcl_platform
if { ! [winfo exists .fr.info] } {
return
}
if { $::g_Opts(RenderMethod) eq "GLSL" } {
.fr.info configure -text [tcl3dOglGetInfoString]
} elseif { $::g_Opts(RenderMethod) eq "Tcl" } {
.fr.info configure -text \
[format "Running on %s with a Tcl implementation (Tcl %s)" \
$tcl_platform(os) [info patchlevel]]
} else {
.fr.info configure -text \
[format "Running on %s with a C implementation (Tcl %s)" \
$tcl_platform(os) [info patchlevel]]
}
#update
}
proc PrintTiming { secs } {
puts [format "%d x %d (%d pixels) with %d iterations: %.3f secs" \
$::g_Opts(TexSize,X) $::g_Opts(TexSize,Y) \
[expr $::g_Opts(TexSize,X) * $::g_Opts(TexSize,Y)] \
$::g_Opts(NumIter) $secs]
}
proc CheckExtProc { extProc } {
if { ![tcl3dOglHaveFunc $extProc] } {
puts "Extension procedure $extProc not available"
return false
}
return true
}
proc CheckGLErrors { msg } {
set errMsg [tcl3dOglGetError]
if { $errMsg eq "" } {
return
}
puts "$msg: $errMsg"
}
# Check framebuffer status.
# Copied directly out of the spec, modified to deliver a return value.
proc CheckFramebufferStatus {} {
set status [glCheckFramebufferStatusEXT GL_FRAMEBUFFER_EXT]
if { $status == $::GL_FRAMEBUFFER_COMPLETE_EXT } {
return true
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT } {
puts "Framebuffer incomplete, incomplete attachment"
return false
} elseif { $status == $::GL_FRAMEBUFFER_UNSUPPORTED_EXT } {
puts "Unsupported framebuffer format"
return false
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT } {
puts "Framebuffer incomplete, missing attachment"
return false
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT } {
puts "Framebuffer incomplete, attached images must have same dimensions"
return false
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT } {
puts "Framebuffer incomplete, attached images must have same format"
return false
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT } {
puts "Framebuffer incomplete, missing draw buffer"
return false
} elseif { $status == $::GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT } {
puts "Framebuffer incomplete, missing read buffer"
return false
} else {
puts "Unknown status $status"
return false
}
}
# Set up a floating point texture with NEAREST filtering.
# (mipmaps etc. are unsupported for floating point textures)
proc SetupTexture { texID } {
# make active and bind
glBindTexture GL_TEXTURE_2D $texID
# turn off filtering and wrap modes!
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP
# define texture with floating point format
glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA32F_ARB \
$::g_Opts(TexSize,X) $::g_Opts(TexSize,Y) 0 GL_RGBA GL_FLOAT NULL
# check if that worked
CheckGLErrors "SetupTexture"
}
# Transfer data to texture.
# Check web page for detailed explanation on the difference between ATI and NVIDIA.
proc TransferToTexture { data texID } {
# version (a): HW-accelerated on NVIDIA
glBindTexture GL_TEXTURE_2D $texID
glTexSubImage2D GL_TEXTURE_2D 0 0 0 $::g_Opts(TexSize,X) $::g_Opts(TexSize,Y) \
GL_RGBA GL_FLOAT $data
# version (b): HW-accelerated on ATI
# This version not tested with Tcl3D. Don't have a ATI card.
# glFramebufferTexture2DEXT GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT GL_TEXTURE_2D $texID 0
# glDrawBuffer GL_COLOR_ATTACHMENT0_EXT
# glRasterPos2i 0 0
# glDrawPixels $::g_Opts(TexSize,X) $::g_Opts(TexSize,Y) GL_RGBA GL_FLOAT $data
# glFramebufferTexture2DEXT GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT GL_TEXTURE_2D 0 0
}
proc CreateTextures {} {
# create textures
glGenTextures 2 $::g_TexId
# set up textures
SetupTexture [$::g_TexId get $::readTex]
SetupTexture [$::g_TexId get $::writeTex]
# set texenv mode from modulate (the default) to replace)
glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_REPLACE
# check if something went completely wrong
CheckGLErrors "CreateTextures"
}
#
# Create framebuffer object, bind it to reroute rendering operations
# from the traditional framebuffer to the off-screen buffer
#
proc InitFBO {} {
# create FBO (off-screen framebuffer)
glGenFramebuffersEXT 1 $::g_FBO
# bind offscreen framebuffer (that is, skip the window-specific render target)
glBindFramebufferEXT GL_FRAMEBUFFER_EXT [$::g_FBO get 0]
# create 'viewport' exactly with same dimensions as the texture(s)
glViewport 0 0 $::g_Opts(TexSize,X) $::g_Opts(TexSize,Y)
# orthographic projection for 1:1 pixel=texture mapping
glMatrixMode GL_PROJECTION
glLoadIdentity
gluOrtho2D 0.0 $::g_Opts(TexSize,X) 0.0 $::g_Opts(TexSize,Y)
glMatrixMode GL_MODELVIEW
glLoadIdentity
# check if something went completely wrong
CheckGLErrors "InitFBO"
}
proc ReadShaderFile { fileName } {
set pathName [file join $::g_ScriptDir $fileName]
set realPath [tcl3dGetExtFile $pathName]
set retVal [catch {open $realPath r} fp]
if { $retVal == 0 } {
set buffer [read $fp]
close $fp
} else {
error "Cannot open shader file $realPath"
}
return $buffer
}
proc LoadAttachShader { program_id shader_id filename } {
set shadersource [ReadShaderFile $filename]
tcl3dOglShaderSource $shader_id $shadersource
glCompileShader $shader_id
glAttachShader $program_id $shader_id
}
proc SetShaders { vert_source frag_source } {
set sh_prog_id [glCreateProgram]
if { $vert_source ne "" } {
set s_id [glCreateShader GL_VERTEX_SHADER]
LoadAttachShader $sh_prog_id $s_id $vert_source
}
if { $frag_source ne "" } {
set s_id [glCreateShader GL_FRAGMENT_SHADER]
LoadAttachShader $sh_prog_id $s_id $frag_source
}
glLinkProgram $sh_prog_id
glUseProgram $sh_prog_id
return $sh_prog_id
}
#
# Performs the actual calculation.
#
proc PerformComputation {} {
# attach two textures to FBO
# because it's much faster to select a new render target via glDrawBuffer(),
# than to attach a different texture
glFramebufferTexture2DEXT GL_FRAMEBUFFER_EXT \
[lindex $::attachmentpoints $::writeTex] \
GL_TEXTURE_2D [$::g_TexId get $::writeTex] 0
CheckGLErrors "perform 0"
glFramebufferTexture2DEXT GL_FRAMEBUFFER_EXT \
[lindex $::attachmentpoints $::readTex] \
GL_TEXTURE_2D [$::g_TexId get $::readTex] 0
CheckGLErrors "perform 1"
# check if that worked
if { ! [CheckFramebufferStatus] } {
puts "glFramebufferTexture2DEXT failed!"
exit
}
# 1st phase: init array with z_1 = c
set sh_prog_id [SetShaders "mandelbrot1.vert" "mandelbrot1.frag"]
set range_center_uni [glGetUniformLocation $sh_prog_id "RangeCenter"]
glUniform2f $range_center_uni $::g_Opts(RangeCenter,0) $::g_Opts(RangeCenter,1)
set range_size_uni [glGetUniformLocation $sh_prog_id "RangeSize"]
glUniform1f $range_size_uni $::g_Opts(RangeSize)
# Calling glFinish() is only neccessary to get accurate timings,
# and we need a high number of iterations to avoid timing noise.
glFinish
tcl3dResetSwatch $::g_Stopwatch
set startTime [tcl3dLookupSwatch $::g_Stopwatch]
# fill texture with initial values (z_1)
RenderScreenSizedQuad
# swap role of the two textures (read-only source becomes
# write-only target and the other way round):
SwapTextures
# 2nd phase: do the iteration to compute z_i
set sh_prog_id [SetShaders "mandelbrot2.vert" "mandelbrot2.frag"]
set zi_minus_1_uni [glGetUniformLocation $sh_prog_id "zi_minus_1"]
glUniform1i $zi_minus_1_uni 0 ; # tex unit 0
set range_center_uni [glGetUniformLocation $sh_prog_id "RangeCenter"]
glUniform2f $range_center_uni $::g_Opts(RangeCenter,0) $::g_Opts(RangeCenter,1)
set range_size_uni [glGetUniformLocation $sh_prog_id "RangeSize"]
glUniform1f $range_size_uni $::g_Opts(RangeSize)
set cur_iteration_uni [glGetUniformLocation $sh_prog_id "curIteration"]
for { set i 1 } { $i <= $::g_Opts(NumIter) } { incr i } {
# pass in new iteration value
glUniform1f $cur_iteration_uni $i
# set render destination
glDrawBuffer [lindex $::attachmentpoints $::writeTex]
# enable "read" texture (read-only), which contains results
# from last iteration
glBindTexture GL_TEXTURE_2D [$::g_TexId get $::readTex]
# make quad filled to hit every pixel/texel
RenderScreenSizedQuad
# swap role of the two textures (read-only source becomes
# write-only target and the other way round):
SwapTextures
}
# 3rd phase: compute nice colors from the iteration count stored in each texel
set sh_prog_id [SetShaders "mandelbrot3.vert" "mandelbrot3.frag"]
set zn_uni [glGetUniformLocation $sh_prog_id "zn"]
glUniform1i $zn_uni 0
set max_iter_uni [glGetUniformLocation $sh_prog_id "MaxIterations"]
glUniform1f $max_iter_uni $::g_Opts(NumIter)
set back_color_uni [glGetUniformLocation $sh_prog_id "BackColor"]
eval glUniform4f $back_color_uni [tcl3dName2rgbaf $::g_Opts(BackColor)]
set inner_color_uni [glGetUniformLocation $sh_prog_id "InnerColor"]
eval glUniform4f $inner_color_uni [tcl3dName2rgbaf $::g_Opts(InnerColor)]
set outer_color_uni [glGetUniformLocation $sh_prog_id "OuterColor"]
eval glUniform4f $outer_color_uni [tcl3dName2rgbaf $::g_Opts(OuterColor)]
set band_frequ_uni [glGetUniformLocation $sh_prog_id "BandFrequ"]
glUniform1f $band_frequ_uni $::g_Opts(BandFrequ)
set colorMethod [glGetUniformLocation $sh_prog_id "ColorMethod"]
if { $::g_Opts(ColorMethod) eq "Random" } {
glUniform1f $colorMethod 0
} else {
glUniform1f $colorMethod 1
}
glDrawBuffer [lindex $::attachmentpoints $::writeTex]
glBindTexture GL_TEXTURE_2D [$::g_TexId get $::readTex]
RenderScreenSizedQuad
SwapTextures
# done, stop timer, calc MFLOP/s if neccessary
glFinish
set endTime [tcl3dLookupSwatch $::g_Stopwatch]
PrintTiming [expr $endTime - $startTime]
# done, just do some checks if everything went smoothly.
CheckFramebufferStatus
CheckGLErrors "PerformComputation"
#puts "[tcl3dOglGetProgramInfoLog $sh_prog_id]"
}
#
# swaps the role of the two y-textures (read-only and write-only)
# Think of "pointer swapping".
#
proc SwapTextures {} {
set h $::writeTex
set ::writeTex $::readTex
set ::readTex $h
}
proc RenderScreenSizedQuad {} {
# make quad filled to hit every pixel/texel
# (should be default but we never know)
glPolygonMode GL_FRONT GL_FILL
# and render the quad with normalized texcoords
set xSize [expr $::g_Opts(TexSize,X) -0]
set ySize [expr $::g_Opts(TexSize,Y) -0]
set xoff 0.5
set yoff 0.5
set xtoff [expr (0.5) / $::g_Opts(TexSize,X)]
set ytoff [expr (0.5 + $::g_Opts(TexSize,Y)) / $::g_Opts(TexSize,Y)]
set xtoff 0.0
set ytoff 0.0
#puts "xtoff = $xtoff ytoff = $ytoff"
glBegin GL_QUADS
glTexCoord2f [expr 0.0 + $xtoff] [expr 0.0 + $ytoff] ; glVertex2f [expr 0.0 + $xoff] [expr 0.0 + $yoff]
glTexCoord2f [expr 1.0 + $xtoff] [expr 0.0 + $ytoff] ; glVertex2f [expr $xSize + $xoff] [expr 0.0 + $yoff]
glTexCoord2f [expr 1.0 + $xtoff] [expr 1.0 + $ytoff] ; glVertex2f [expr $xSize + $xoff] [expr $ySize + $yoff]
glTexCoord2f [expr 0.0 + $xtoff] [expr 1.0 + $ytoff] ; glVertex2f [expr 0.0 + $xoff] [expr $ySize + $yoff]
glEnd
}
proc CalculateWithGLSL {} {
Reset
InitFBO ; # init off-screen framebuffer
CreateTextures ; # create textures for vectors
PerformComputation ; # and start computation
# show final result, which is in the "read" texture
glUseProgram 0 ; # use fixed-function pipeline
}
proc GetRenormalizedColor { re im n } {
if { $n >= $::g_Opts(NumIter) } {
return $::g_Opts(BackColor)
}
set innerColor [tcl3dName2rgb $::g_Opts(InnerColor)]
set outerColor [tcl3dName2rgb $::g_Opts(OuterColor)]
set len [expr {sqrt ($re*$re + $im*$im)}]
set f [expr {$n + 1.0 - log (log ($len)) / log(2) }]
set mix1 [expr {$f * $::g_Opts(BandFrequ)}]
if { $mix1 > 1.0 } {
set mix1 1.0
}
set mix2 [expr {1.0 - $mix1}]
return [tcl3dRgb2Name \
[expr {int ($mix2 * [lindex $innerColor 0] + \
$mix1 * [lindex $outerColor 0])}] \
[expr {int ($mix2 * [lindex $innerColor 1] + \
$mix1 * [lindex $outerColor 1])}] \
[expr {int ($mix2 * [lindex $innerColor 2] + \
$mix1 * [lindex $outerColor 2])}]]
}
proc GetRandomColor { n } {
global g_Colors
return $g_Colors($n)
}
proc SetupRandomColors {} {
global g_Colors
set randomGen [tcl3dNewRandomGen 0]
for { set i 0 } { $i < $::g_Opts(NumIter) } { incr i } {
set g_Colors($i) [tcl3dRgb2Name \
[tcl3dGetRandomInt $randomGen 0 255] \
[tcl3dGetRandomInt $randomGen 0 255] \
[tcl3dGetRandomInt $randomGen 0 255]]
}
set g_Colors($::g_Opts(NumIter)) $::g_Opts(BackColor)
tcl3dDeleteRandomGen $randomGen
}
proc CalculateWithC {} {
PhotoImage blank
PhotoImage config -width $::g_Opts(TexSize,X) -height $::g_Opts(TexSize,Y)
foreach { br bg bb } [tcl3dName2rgb $::g_Opts(BackColor)] { break }
foreach { ir ig ib } [tcl3dName2rgb $::g_Opts(InnerColor)] { break }
foreach { or og ob } [tcl3dName2rgb $::g_Opts(OuterColor)] { break }
tcl3dResetSwatch $::g_Stopwatch
set startTime [tcl3dLookupSwatch $::g_Stopwatch]
tcl3dUtilFractalToPhoto PhotoImage $::g_Opts(ColorMethod) \
$::g_Opts(TexSize,X) $::g_Opts(TexSize,Y) \
$::g_Opts(RangeCenter,0) $::g_Opts(RangeCenter,1) $::g_Opts(RangeSize) \
$::g_Opts(NumIter) $::g_Opts(BandFrequ) \
$br $bg $bb \
$ir $ig $ib \
$or $og $ob
set endTime [tcl3dLookupSwatch $::g_Stopwatch]
PrintTiming [expr $endTime - $startTime]
update
}
proc CalculateWithTcl {} {
PhotoImage blank
PhotoImage config -width $::g_Opts(TexSize,X) -height $::g_Opts(TexSize,Y)
SetupRandomColors
set xScale [expr {$::g_Opts(RangeSize) / $::g_Opts(TexSize,X)}]
set yScale [expr {$::g_Opts(RangeSize) / $::g_Opts(TexSize,Y)}]
set Rmin [expr {$::g_Opts(RangeCenter,0) - $::g_Opts(RangeSize)*0.5}]
set Imin [expr {$::g_Opts(RangeCenter,1) - $::g_Opts(RangeSize)*0.5}]
tcl3dResetSwatch $::g_Stopwatch
set startTime [tcl3dLookupSwatch $::g_Stopwatch]
set step 4 ;# Do interlaced drawing
set numIter $::g_Opts(NumIter)
for {set start 0} {$start < $step} {incr start} {
for {set x $start} {$x < $::g_Opts(TexSize,X)} {incr x $step} {
set c_re [expr {$Rmin + $x * $xScale}]
set data [list]
for {set y [expr {$::g_Opts(TexSize,Y)-1}]} {$y >= 0} {incr y -1} {
set c_im [expr {$Imin + $y * $yScale}]
set z_re $c_re
set z_im $c_im
for {set n 0} {$n < $numIter} {incr n} {
set z_re2 [expr {$z_re * $z_re}] ; # Have we escaped yet?
set z_im2 [expr {$z_im * $z_im}]
if {($z_re2 + $z_im2) > 4} {
break
}
set z_im [expr {2 * $z_re * $z_im + $c_im}]
set z_re [expr {$z_re2 - $z_im2 + $c_re}]
}
if { $::g_Opts(ColorMethod) eq "Random" } {
lappend data [GetRandomColor $n]
} else {
lappend data [GetRenormalizedColor $z_re $z_im $n]
}
}
PhotoImage put $data -to $x 0
}
update
}
set endTime [tcl3dLookupSwatch $::g_Stopwatch]
PrintTiming [expr $endTime - $startTime]
}
proc Update {} {
set ::g_Opts(TexSize,X) $::g_Opts(TexSize)
set ::g_Opts(TexSize,Y) $::g_Opts(TexSize)
if { $::g_Opts(RenderMethod) eq "GLSL" } {
CalculateWithGLSL
DisplayCallback .fr.toglwin
} elseif { $::g_Opts(RenderMethod) eq "Tcl" } {
CalculateWithTcl
} else {
CalculateWithC
}
}
proc CreateCallback { toglwin } {
global g_Opts
set g_Opts(haveOglExtensions) true
if { ![tcl3dOglHaveExtension $toglwin "GL_EXT_framebuffer_object"] } {
puts "Extension GL_EXT_framebuffer_object missing"
set g_Opts(haveOglExtensions) false
}
if { ![tcl3dOglHaveExtension $toglwin "GL_ARB_texture_float"] } {
puts "Extension GL_ARB_texture_float missing"
set g_Opts(haveOglExtensions) false
}
if { ! [tcl3dOglHaveExtension $toglwin "GL_ARB_texture_non_power_of_two"] } {
puts "Extension GL_ARB_texture_non_power_of_two missing"
set g_Opts(haveOglExtensions) false
}
set maxColorAttachments [tcl3dOglGetIntegerState GL_MAX_COLOR_ATTACHMENTS_EXT]
if { $maxColorAttachments < 2 } {
puts "Number of color attachments available is: $maxColorAttachments"
puts "Needed for GLSL fractal generation are 2."
set g_Opts(haveOglExtensions) false
}
set texSizeX $::g_Opts(TexSize,X)
set texSizeY $::g_Opts(TexSize,Y)
# check whether we can actually load textures of that size on the GPU
glTexImage2D GL_PROXY_TEXTURE_2D 0 $::GL_RGBA32F_ARB \
$texSizeX $texSizeY 0 $::GL_RGBA GL_FLOAT NULL
set realWidth [tcl3dVector GLint 1]
glGetTexLevelParameteriv GL_PROXY_TEXTURE_2D 0 GL_TEXTURE_WIDTH $realWidth
if { [$realWidth get 0] == 0 } {
puts [format "Can't load textures of type GL_RGBA32F_ARB (Size %d x %d)." \
$texSizeX $texSizeY]
set g_Opts(haveOglExtensions) false
}
$realWidth delete
if { ! [CheckExtProc "glGenFramebuffersEXT"] } {
set g_Opts(haveOglExtensions) false
}
if { ! [CheckExtProc "glDeleteFramebuffersEXT"] } {
set g_Opts(haveOglExtensions) false
}
if { ! [CheckExtProc "glFramebufferTexture2DEXT"] } {
set g_Opts(haveOglExtensions) false
}
if { ! $g_Opts(haveOglExtensions) } {
puts "GLSL mode disabled because of missing prerequisites."
}
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
global g_Opts
if { $g_Opts(RenderMethod) eq "GLSL" } {
set w [$toglwin width]
set h [$toglwin height]
}
set ::g_WinWidth $w
set ::g_WinHeight $h
if { 0 && $g_Opts(RenderMethod) eq "GLSL" } {
glViewport 0 0 $fractalSize $fractalSize
glMatrixMode GL_PROJECTION
glLoadIdentity
gluOrtho2D 0.0 $fractalSize 0.0 $fractalSize
glMatrixMode GL_MODELVIEW
glLoadIdentity
}
}
proc DisplayCallback { toglwin } {
# no clear necessary, since we draw the whole screen, and without z
glMatrixMode GL_MODELVIEW
glLoadIdentity
# default for camera = 0,0,0; looking at -z; near = -1; far = +1
# restore render destination to regular frame buffer
glBindFramebufferEXT GL_FRAMEBUFFER_EXT 0
glEnable GL_TEXTURE_2D
glBindTexture GL_TEXTURE_2D [$::g_TexId get $::readTex]
# texture states; just to make sure
glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_REPLACE
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP
glColor3f 1 1 0
RenderScreenSizedQuad
DrawBoxTogl
# no swap buffers here, because we don't animate anything
glFinish
}
proc Reset {} {
Cleanup false
# Texture identifiers
set ::g_TexId [tcl3dVector GLuint 2]
# Framebuffer object identifier
set ::g_FBO [tcl3dVector GLuint 1]
# ping pong management vars
set ::writeTex 0
set ::readTex 1
}
proc Cleanup { { fullCleanup true } } {
if { [info exists ::g_TexId] } {
glDeleteTextures 2 [$::g_TexId get 0]
$::g_TexId delete
}
if { [info exists ::g_FBO] } {
glDeleteFramebuffersEXT 1 [$::g_FBO get 0]
$::g_FBO delete
}
if { $fullCleanup } {
tcl3dDeleteSwatch $::g_Stopwatch
foreach var [info globals g_*] {
uplevel #0 unset $var
}
}
}
proc ExitProg {} {
exit
}
proc Center2Box {} {
global gBox g_Opts
set cx $g_Opts(RangeCenter,0)
set cy $g_Opts(RangeCenter,1)
set size $g_Opts(RangeSize)
set gBox(x1) [expr {$cx - $size/2}]
set gBox(y1) [expr {$cy - $size/2}]
set gBox(x2) [expr {$cx + $size/2}]
set gBox(y2) [expr {$cy + $size/2}]
}
proc Box2Center {} {
global gBox g_Opts
set x1 $gBox(x1)
set y1 $gBox(y1)
set x2 $gBox(x2)
set y2 $gBox(y2)
set dx [expr {$x2 - $x1}]
set dy [expr {$y2 - $y1}]
set g_Opts(RangeCenter,0) [expr {$x1 + $dx/2}]
set g_Opts(RangeCenter,1) [expr {$y1 + $dy/2}]
set g_Opts(RangeSize) [expr $dx>$dy? $dx : $dy]
}
proc Canvas2Z { winType x y } {
global gBox g_Opts
set xScale [expr {double($g_Opts(RangeSize)) / $::g_Opts(TexSize,X)}]
set yScale [expr {double($g_Opts(RangeSize)) / $::g_Opts(TexSize,Y)}]
set xMin [expr {$g_Opts(RangeCenter,0) - $g_Opts(RangeSize)/2}]
set yMin [expr {$g_Opts(RangeCenter,1) - $g_Opts(RangeSize)/2}]
set re [expr {$xMin + $xScale * $x}]
if { $winType eq "Togl" } {
set im [expr {$yMin + $yScale * $y}]
} else {
set im [expr {$yMin + $yScale * ($::g_WinHeight -1 - $y)}]
}
return [list $re $im]
}
proc ZoomOut { winType w } {
global gBox g_Opts
if { [llength $gBox(stack)] < 2 } {
return
}
set a [lindex $gBox(stack) end-1]
set gBox(stack) [lrange $gBox(stack) 0 end-1]
foreach {g_Opts(RangeCenter,0) g_Opts(RangeCenter,1) g_Opts(RangeSize)} $a break
Update
}
proc ZoomIn { winType w } {
global gBox g_Opts
foreach {Rmin Imin} [Canvas2Z $winType $gBox(x1) $gBox(y1)] break
foreach {Rmax Imax} [Canvas2Z $winType $gBox(x2) $gBox(y2)] break
set g_Opts(RangeCenter,0) [expr $Rmin + ($Rmax - $Rmin)/2]
set g_Opts(RangeCenter,1) [expr $Imin + ($Imax - $Imin)/2]
set g_Opts(RangeSize) [expr $Rmax - $Rmin]
puts "ZoomIn $g_Opts(RangeCenter,0) $g_Opts(RangeCenter,1) $g_Opts(RangeSize)"
lappend gBox(stack) [list $g_Opts(RangeCenter,0) $g_Opts(RangeCenter,1) $g_Opts(RangeSize)]
set gBox(draw) 0
if { $winType eq "Canvas" } {
DrawBoxCanvas $w
}
Update
}
# Draw an interactive zoom box on a Togl window. Used for GLSL render mode.
proc DrawBoxTogl {} {
global gBox
if { ! $gBox(draw) } {
return
}
glDisable GL_LIGHTING
glMatrixMode GL_PROJECTION
glPushMatrix
glLoadIdentity
gluOrtho2D 0 $::g_Opts(TexSize,X) 0 $::g_Opts(TexSize,Y)
glMatrixMode GL_MODELVIEW
glPushMatrix
glLoadIdentity
glColor3f 1 1 1
glBegin GL_LINE_LOOP
glVertex2f $gBox(x1) $gBox(y1)
glVertex2f $gBox(x2) $gBox(y1)
glVertex2f $gBox(x2) $gBox(y2)
glVertex2f $gBox(x1) $gBox(y2)
glEnd
glPopMatrix
glMatrixMode GL_PROJECTION
glPopMatrix
glMatrixMode GL_MODELVIEW
glEnable GL_LIGHTING
}
# Draw an interactive zoom box on a canvas widget. Used for Tcl and C render mode.
proc DrawBoxCanvas { w } {
global gBox
$w delete box
if { $gBox(draw) } {
$w create rect $gBox(x1) $gBox(y1) $gBox(x2) $gBox(y2) \
-outline white -tag box \
-dash 1
}
}
# Handle the interactive zoom box. Used for all render modes.
proc HandleBox { what winType w x y} {
global gBox
if { $what == 0 } { ; # Button down
set gBox(draw) 0
set gBox(x1) $x
set gBox(y1) $y
if { $winType eq "Togl" } {
set gBox(y1) [expr $::g_WinHeight -1 - $y]
}
} else { ; # Button motion
set gBox(draw) 1
set gBox(x2) $x
set gBox(y2) $y
if { $winType eq "Togl" } {
set gBox(y2) [expr $::g_WinHeight -1 - $y]
}
}
if { $winType eq "Togl" } {
$w postredisplay
} else {
DrawBoxCanvas $w
}
}
# Choose a color for
proc GetColor { buttonId which } {
global gPo
set newColor [tk_chooseColor -initialcolor $::g_Opts($which)]
if { $newColor ne "" } {
set ::g_Opts($which) $newColor
$buttonId configure -background $newColor
}
Update
}
proc InitPhoto {} {
catch { image delete PhotoImage }
image create photo PhotoImage -width $::g_Opts(TexSize,X) -height $::g_Opts(TexSize,Y)
}
proc InitCanvas {} {
catch { destroy .fr.toglwin }
if { $::g_Opts(RenderMethod) eq "GLSL" } {
togl .fr.toglwin -width $::g_Opts(TexSize,X) -height $::g_Opts(TexSize,Y) \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
set mode "Togl"
} else {
InitPhoto
canvas .fr.toglwin -width $::g_Opts(TexSize,X) -height $::g_Opts(TexSize,Y) \
-borderwidth 0 -relief flat -highlightthickness 0
.fr.toglwin create image 0 0 -image PhotoImage -anchor nw -tag Image
bind .fr.toglwin <Configure> "ReshapeCallback .fr.toglwin %w %h"
set mode "Canvas"
}
bind .fr.toglwin <Button-1> [list HandleBox 0 $mode %W %x %y]
bind .fr.toglwin <B1-Motion> [list HandleBox 1 $mode %W %x %y]
bind .fr.toglwin <ButtonRelease-1> [list ZoomIn $mode %W]
bind .fr.toglwin <Button-2> [list ZoomOut $mode %W]
bind .fr.toglwin <Button-3> [list ZoomOut $mode %W]
bind .fr.toglwin <Control-Button-1> [list ZoomOut $mode %W]
bind . <Key-minus> [list ZoomOut $mode %W]
grid .fr.toglwin -row 0 -column 0 -sticky sw
}
proc InitRenderMethods {} {
global g_RenderMethods g_Opts
togl .fr.toglwin -width $::g_WinWidth -height $::g_WinHeight \
-createcommand CreateCallback
set g_RenderMethods [list "Tcl"]
set g_Opts(RenderMethod) [lindex $g_RenderMethods end]
if { [info commands tcl3dUtilFractalToPhoto] ne "" } {
lappend g_RenderMethods "C"
set g_Opts(RenderMethod) [lindex $g_RenderMethods end]
}
if { $g_Opts(haveOglExtensions) } {
lappend g_RenderMethods "GLSL"
set g_Opts(RenderMethod) [lindex $g_RenderMethods end]
}
destroy .fr.toglwin
}
proc ResetCanvas { args } {
InitCanvas
PrintGeneralInfo
Update
}
proc SaveScreenShot { w fileName } {
. configure -cursor watch
update
# Create a name on the file system, if running from within a Starpack.
set fileName [tcl3dGenExtName $fileName]
set imgName [file rootname $fileName]
set imgExt ".ppm"
set imgFmt "PPM"
set imgOpt ""
append imgName $imgExt
after 300
tcl3dWidget2File $w $imgName "" $imgFmt $imgOpt
puts "Screenshot written to: $imgName"
. configure -cursor top_left_arrow
}
proc SaveImg { w } {
global g_Opts
set fileName [format "mandelshot-%s" $g_Opts(RenderMethod)]
SaveScreenShot $w $fileName
}
frame .fr
pack .fr -expand 1 -fill both
InitRenderMethods
Reset
InitCanvas
frame .fr.btns
listbox .fr.usage -font $::g_listFont -height 2
label .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.btns -row 0 -column 1 -sticky news
grid .fr.usage -row 1 -column 0 -sticky news -columnspan 2
grid .fr.info -row 2 -column 0 -sticky news -columnspan 2
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
.fr.usage insert end "Mouse-L Zoom in"
.fr.usage insert end "Mouse-R Step back"
frame .fr.btns.frTexSize
label .fr.btns.frTexSize.l -text "Texture size:"
tk_optionMenu .fr.btns.frTexSize.m g_Opts(TexSize) 512 256 128
pack .fr.btns.frTexSize -fill x -side top
pack .fr.btns.frTexSize.l .fr.btns.frTexSize.m -side left -expand 1 -fill x
trace add variable g_Opts(TexSize) write ResetCanvas
frame .fr.btns.frIter
label .fr.btns.frIter.l -text "Iterations:" -anchor w
spinbox .fr.btns.frIter.e -textvariable ::g_Opts(NumIter) \
-command Update -width 10 \
-from 10 -to 1000 -increment 10
bind .fr.btns.frIter.e <Key-Return> Update
pack .fr.btns.frIter -side top -fill x
pack .fr.btns.frIter.l -side left -expand 1 -fill x
pack .fr.btns.frIter.e -side left -expand 1 -fill x
frame .fr.btns.frCenterRe
label .fr.btns.frCenterRe.l -text "Center Re:" -anchor w
spinbox .fr.btns.frCenterRe.e -textvariable ::g_Opts(RangeCenter,0) \
-command Update -width 10 \
-from -3.0 -to 3.0 -increment 0.1
bind .fr.btns.frCenterRe.e <Key-Return> Update
pack .fr.btns.frCenterRe -side top -fill x
pack .fr.btns.frCenterRe.l -side left -expand 1 -fill x
pack .fr.btns.frCenterRe.e -side left -expand 1 -fill x
frame .fr.btns.frCenterIm
label .fr.btns.frCenterIm.l -text "Center Im:" -anchor w
spinbox .fr.btns.frCenterIm.e -textvariable ::g_Opts(RangeCenter,1) \
-command Update -width 10 \
-from -3.0 -to 3.0 -increment 0.1
bind .fr.btns.frCenterIm.e <Key-Return> Update
pack .fr.btns.frCenterIm -fill x -side top
pack .fr.btns.frCenterIm.l .fr.btns.frCenterIm.e -side left -expand 1 -fill x
frame .fr.btns.frRangeSize
label .fr.btns.frRangeSize.l -text "Box size:" -anchor w
spinbox .fr.btns.frRangeSize.e -textvariable ::g_Opts(RangeSize) \
-command Update -width 10 \
-from 0.05 -to 5 -increment 0.05
bind .fr.btns.frRangeSize.e <Key-Return> Update
pack .fr.btns.frRangeSize -fill x -side top
pack .fr.btns.frRangeSize.l .fr.btns.frRangeSize.e -side left -expand 1 -fill x
labelframe .fr.btns.frRenderMethod -text "Render Method"
pack .fr.btns.frRenderMethod -fill x -side top -padx 2
foreach cmd $g_RenderMethods {
radiobutton .fr.btns.frRenderMethod.b_$cmd -text $cmd -value $cmd \
-variable g_Opts(RenderMethod) -command ResetCanvas
pack .fr.btns.frRenderMethod.b_$cmd -fill x -side left
}
labelframe .fr.btns.frColorMethod -text "Coloring Method"
pack .fr.btns.frColorMethod -fill x -side top -padx 2
foreach cmd $g_ColorMethods {
radiobutton .fr.btns.frColorMethod.b_$cmd -text $cmd -value $cmd \
-variable g_Opts(ColorMethod) -command ResetCanvas
pack .fr.btns.frColorMethod.b_$cmd -fill x -side left
}
set frRenormOpts .fr.btns.frRenormOpts
set frColor $frRenormOpts.frColor
set frFrequ $frRenormOpts.frFrequ
labelframe $frRenormOpts -text "Renorm Options"
frame $frColor
frame $frFrequ
pack $frRenormOpts -fill x -side top -padx 2
pack $frColor $frFrequ -fill x -side top
label $frColor.l -text "Colors:" -anchor w
button $frColor.bi -text "..." -bg $::g_Opts(InnerColor) \
-command "GetColor $frColor.bi InnerColor"
button $frColor.bo -text "..." -bg $::g_Opts(OuterColor) \
-command "GetColor $frColor.bo OuterColor"
pack $frColor.l $frColor.bi $frColor.bo \
-side left -expand 1 -fill x
label $frFrequ.l -text "Band frequency:" -anchor w
spinbox $frFrequ.e -textvariable ::g_Opts(BandFrequ) \
-command Update -width 10 \
-from 0.001 -to 0.1 -increment 0.005
bind $frFrequ.e <Key-Return> Update
pack $frFrequ.l $frFrequ.e -side left -expand 1 -fill x
frame .fr.btns.frSaveImg
button .fr.btns.frSaveImg.b -text "Save as image" -command [list SaveImg .fr.toglwin]
pack .fr.btns.frSaveImg -fill x -side top
pack .fr.btns.frSaveImg.b -side left -expand 1 -fill x
set appName "Tcl3D demo: Mandelbrot"
wm title . $appName
# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
#update
Update
PrintGeneralInfo
|
