console show

set depth 9
set wobble 9.5
expr srand(1024)

# set depth 10
# set wobble 3.5

set size 2
for {set i 1} {$i < $depth} {incr i} {set size [expr 2*$size]}
incr size

set nocolor green
array set pixel {}
set top [expr $size-1]
set initialPoints "0,0 0 $top,0 0 0,$top 0 $top,$top 0 [expr $top/2],[expr $top/2] 255 [expr $top/2],0 120"

trace variable pixel w "pixelWrite 0"

proc initImg {} {
  global size 
  image create photo im -width $size -height $size
  canvas .canvas -width $size -height $size
  .canvas create image 0 0 -image im -anchor nw
  pack .canvas
  update
  wm protocol . WM_DELETE_WINDOW exit
}

proc clearImg {} {
  global size pixel nocolor
  for {set w 0} {$w < $size} {incr w} {
    update
    for {set h 0} {$h < $size} {incr h} {
      set pixel($w,$h) $nocolor
    }
  }
}

proc pixelWrite {debug name1 name2 op} {
  # All we really care about is name2
  global pixel
  foreach {w h} [split $name2 ,] { }
  set color $pixel($name2)
  if {$debug} {puts "$w $h -> $color"}
  if {[string is integer $color]} {
    im put #[format %02x%02x%02x $color $color $color] -to $w $h
  } else {
    im put $color -to $w $h
  }
}

proc updatePixel {w h c} {
  global pixel nocolor
  if {$pixel($w,$h) == $nocolor} {
    set pixel($w,$h) $c
    update
  }
}

proc calcColor {width args} {
  global wobble top
  set x [join $args +]
  set avg [expr ($x)/[llength $args]]
  set min 9999 ; set max -1
  foreach i $args {
    if {$i < $min} {set min $i}
    if {$max < $i} {set max $i}
  }
  set bobble [expr {double($width)/double($top) * $wobble * 250.0 * (0.5 - rand())}]
  set val [expr {int($avg+$bobble)}]
  if {$val < 0} {set val 0}
  if {255 < $val} {set val 255}
  return $val
}

proc fractate {botW botH topW topH} {
  global pixel nocolor
  set c1 $pixel($botW,$botH)
  set c2 $pixel($botW,$topH)
  set c3 $pixel($topW,$botH)
  set c4 $pixel($topW,$topH)
  # puts "Fractate: $botW $botH $topW $topH -> $c1 $c2 $c3 $c4" ; update
  set wide [expr {$topW-$botW}]
  set high [expr {$topH-$botH}]
  if {$wide != $high} {error "wide!=high $botW $botH $topW $topH"}
  set range $wide
  set centerW [expr {$botW+($wide/2)}]
  set centerH [expr {$botH+($high/2)}]
  set centerC [calcColor $range $c1 $c2 $c3 $c4]
  updatePixel $centerW $centerH $centerC
  set range [expr {$range / 2}]
  set centerC $pixel($centerW,$centerH)
  updatePixel $centerW $topH [calcColor $range $c2 $c4]
  updatePixel $centerW $botH [calcColor $range $c1 $c3]
  updatePixel $topW $centerH [calcColor $range $c3 $c4]
  updatePixel $botW $centerH [calcColor $range $c1 $c2]

  if {$topW - $botW <= 2} return
  if {$topH - $botH <= 2} return

  fractate $botW $botH $centerW $centerH
  fractate $centerW $centerH $topW $topH
  fractate $centerW $botH $topW $centerH
  fractate $botW $centerH $centerW $topH
}

proc saveAnswer {} {
  global pixel size wobble
  if {0} {
    set fd [open xyzzy.txt w] 
    for {set h 0} {$h < $size} {incr h} {
      # puts "Row $h"
      update
      for {set w 0} {$w < $size} {incr w} {
	puts $fd "$w $h $pixel($w,$h)"
      }
    } ; close $fd ; puts "Saved raw!" ; update
  }
  set fd [open height.ppm w] 
  puts $fd "P3 $size $size 255"
  # puts $fd "# wobble = $wobble"
  for {set h 0} {$h < $size} {incr h} {
    puts "Row $h"
    update
    for {set w 0} {$w < $size} {incr w} {
      puts $fd "$pixel($w,$h) $pixel($w,$h) $pixel($w,$h)"
    }
  } ; close $fd ; puts "Saved ppm!" ; update
}

initImg
clearImg
# trace variable pixel w "pixelWrite 1"
array set pixel $initialPoints
update

fractate 0 0 $top $top
saveAnswer
after 3000 {exit}