#!/bin/sh
# Copyright (C) 2005, Peter da Silva		All rights reserved.
#\
exec tclsh "$0" ${1+"$@"}
package require Tk

set license {
  Copyright (C) 2005, Peter da Silva

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:
  1. Redistributions of source code must retain the above copyright
     notice, this list of conditions and the following disclaimer.
  2. Redistributions in binary form must reproduce the above copyright
     notice, this list of conditions and the following disclaimer in the
     documentation and/or other materials provided with the distribution.
  3. The name of the author may not be used to endorse or promote
     products derived from this software without specific prior written
     permission.

  THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE
  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
  OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
  EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}

proc wind {canvas object} {
  global objects

  lappend objects $canvas $object
}

proc poof {delay} {}

proc blower {delay} {
  global objects abort
  set dt [expr {int($delay/8)}]
  foreach {canvas object} $objects {
    if $abort break
    set nudge 0
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      if {$x2 - $x1 < 64 || $y2 - $y1 < 64} {
        set nudge 1
      }
    }
    if !$nudge {
      $canvas delete $object
      update
      after $delay
      continue
    }
    set dx [expr rand() - 0.5]
    set dy [expr rand() - 0.5]
    foreach tick {1 2 3 4 5 6 7 8} {
      $canvas move $object $dx $dy
      update
      set dx [expr $dx * 2]
      set dy [expr $dy * 2]
      after $dt
    }
    $canvas delete $object
    update
  }
  set objects {}
}

proc acid {delay} {
  sorted $delay -decreasing
}

proc erode {delay} {
  sorted $delay -increasing
}

proc sorted {delay order} {
  global objects abort
  set layers {}
  foreach {canvas object} $objects {
    if $abort break
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      set size [expr {$x2-$x1 + $y2-$y1}]
      lappend layers [list $size $canvas $object]
    }
  }
  set objects {}
  foreach layer [lsort $order -index 0 -real $layers] {
    if $abort break
    foreach {size canvas object} $layer {
      $canvas delete $object
      update
      after $delay
      continue
    }
  }
}

proc hightide {delay} {
  byheight $delay -decreasing
}

proc sunlamp {delay} {
  byheight $delay -increasing
}

proc byheight {delay order} {
  global objects abort
  set layers {}
  foreach {canvas object} $objects {
    if $abort break
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      set height [expr {$y2+$y1}]
      lappend layers [list $height $canvas $object]
    }
  }
  set objects {}
  foreach layer [lsort $order -index 0 -real $layers] {
    if $abort break
    foreach {height canvas object} $layer {
      $canvas delete $object
      update
      after $delay
      continue
    }
  }
}

proc tsunami {delay} {
  global objects abort param
  set layers {}
  foreach {canvas object} $objects {
    if $abort break
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      set height [expr {$y2+$y1+$x2+$y2+$y2+rand()*$param(y) / 3}]
      lappend layers [list $height $canvas $object]
    }
  }
  set objects {}
  foreach layer [lsort -decreasing -index 0 -real $layers] {
    if $abort break
    foreach {height canvas object} $layer {
      $canvas delete $object
      update
      after [expr {int($delay * (rand()/2+0.5))}]
      continue
    }
  }
}

proc dissolve {delay} {
  global objects abort param
  set centers {}
  set count [random {1 1 1 2 2 2 3 3 4 4 5 6}]
  for {set i 0} {$i < $count} {incr i} {
    lappend centers [expr {rand() * $param(x)}] [expr {rand() * $param(y)}]
  }
  set layers {}
  foreach {canvas object} $objects {
    if $abort break
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      set min -1
      foreach {x0 y0} $centers {
	set x [expr {($x1 + $x2) / 2}]
	set y [expr {($y1 + $y2) / 2}]
	set d2 [expr {($x-$x0)*($x-$x0)+($y-$y0)*($y-$y0)}]
	if {$min < 0 || $d2 < $min} {
	  set min $d2
	}
      }
      set s [expr {($x2-$x1)*($y2-$y1)}]
      lappend layers [list [expr {$min + $min*rand()/4 - $s}] $canvas $object]
    }
  }
  set objects {}
  foreach layer [lsort -increasing -index 0 -real $layers] {
    if $abort break
    foreach {d2 canvas object} $layer {
      $canvas delete $object
      update
      after [expr {int($delay * (rand()/2))}]
      continue
    }
  }
}

proc shuffle {delay} {
  global objects abort
  set dt [expr {int($delay/6)}]
  set delay [expr {int($delay/3)}]
  set jigglers {}
  foreach {canvas object} $objects {
    if $abort break
    set nudge 0
    foreach {x1 y1 x2 y2} [$canvas bbox $object] {
      if {$x2 - $x1 < 32 || $y2 - $y1 < 32} {
        set nudge 1
        set size [expr {$x2-$x1 + $y2-$y1}]
      }
    }
    if !$nudge {
      $canvas delete $object
      update
      after $delay
      continue
    }
    set dx [expr {(rand() - 0.5) * 5}]
    set dy [expr {(rand() - 0.5) * 5}]
    $canvas move $object $dx $dy
    update
    lappend jigglers $canvas $object $dx $dy $size
    after $dt
  }
  set objects {}
  if $abort return
  set max 64
  foreach mul {2 4 8} {
    if $abort break
    set work $jigglers
    set jigglers {}
    foreach {canvas object dx dy size} $work {
      if $abort break
      set dx [expr $dx * 2]
      set dy [expr $dy * 2]
      $canvas move $object $dx $dy
      update
      after $dt
      if {$max > $size} {
        lappend jigglers $canvas $object $dx $dy $size
      } else {
	$canvas delete $object
	update
	after $delay
      }
    }
    incr delay -$dt
    set max [expr $max / 2]
  }
}

proc unwind {delay} {
  global objects abort
  foreach {canvas object} $objects {
    if $abort break
    $canvas delete $object
    update
    after $delay
  }
  set objects {}
}

proc divide {c x1 y1 x2 y2 paint} {
  global abort param
  set min $param(size)
  set rat $param(irregular)

  if $param(mosaic) {
    set paint 1
  }
  set count 0

  if {$abort != 0 || $x2 - $x1 < $min && $y2 - $y1 < $min} {return 0}

  if {$paint && rand() * 10 < $param(complete)} {
    if [llength $param(colors)] {
      set c1 [random $param(colors)]
    } else {
      set c1 [randomcolor]
    }
    set extra {}
    switch -glob -- $param(outline) {
      none {
        set c2 $c1
      }
      random {
        if [llength $param(colors)] {
	  set c2 [random $param(colors)]
        } else {
          set c2 [randomcolor]
        }
      }
      bold* {
	set c2 [lindex $param(outline) 1]
	lappend extra -width 2
      }
      default {
        set c2 $param(outline)
      }
    }
    if {$param(scatter) > 0} {
      set s $param(scatter)
      set sx [expr {$s * rand() - $s / 2}]
      set sy [expr {$s * rand() - $s / 2}]
      set x1 [expr {$x1 + $sx}]
      set x2 [expr {$x2 + $sx}]
      set y1 [expr {$y1 + $sy}]
      set y2 [expr {$y2 + $sy}]
    }
    set cmd [list $c create rectangle $x1 $y1 $x2 $y2 -fill $c1 -outline $c2]
    set cmd [concat $cmd $extra]
    if !$param(mosaic) {
      wind $c [eval $cmd]
      update
      after 100
    }
  }

  if {$x2 - $x1 < $min} {
    set div 1
  } elseif {$y2 - $y1 < $min} {
    set div 0
  } elseif {($x2 - $x1) * $param(unsquare) < $y2 - $y1} {
    set div 1
  } elseif {($y2 - $y1) * $param(unsquare) < $x2 - $x1} {
    set div 0
  } elseif {rand() < 0.5} {
    set div 1
  } else {
    set div 0
  }
    
  if {$div == 0} {
    set x [expr {$x1 + rand() * ($x2 - $x1 - $min / $rat) + $min / ($rat * 2)}]
    if {rand() < 0.5} {
      incr count [
	divide $c $x1 $y1 $x $y2 $paint
      ]
      incr count [
        divide $c $x $y1 $x2 $y2 [expr 1 - $paint]
      ]
    } else {
      incr count [
	divide $c $x $y1 $x2 $y2 $paint
      ]
      incr count [
	divide $c $x1 $y1 $x $y2 [expr 1 - $paint]
      ]
    }
  } else {
    set y [expr {$y1 + rand() * ($y2 - $y1 - $min / $rat) + $min / ($rat * 2)}]
    if {rand() < 0.5} {
      incr count [
	divide $c $x1 $y1 $x2 $y $paint
      ]
      incr count [
	divide $c $x1 $y $x2 $y2 [expr 1 - $paint]
      ]
    } else {
      incr count [
	divide $c $x1 $y $x2 $y2 $paint
      ]
      incr count [
	divide $c $x1 $y1 $x2 $y [expr 1 - $paint]
      ]
    }
  }
  if {[info exists cmd] && $param(mosaic)} {
    if {$count == 0} {
      wind $c [eval $cmd]
      update
      after 100
    }
  }
  return 1
}

proc random {list} {
  set ix [expr {int(rand() * [llength $list])}]
  return [lindex $list $ix]
}

proc randomcolor {} {
  return [format #%02x%02x%02x \
		[expr {int(rand() * 256)}] \
		[expr {int(rand() * 256)}] \
		[expr {int(rand() * 256)}] ]
}

proc divider {c x y} {
  global abort param
  set abort 0
  canvas $c -width $x -height $y
  if [llength $param(colors)] {
    set color [random $param(colors)]
  } else {
    set color [randomcolor]
  }
  $c create rectangle 0 0 $x $y -fill $color -outline $color
  pack $c
  divide $c 0 0 $x $y 1
  dumper $c
}

set themes {
  {"Polychrome"}
  {"Red White and Blue" red white blue}
  {"Greyscale" gray10 gray20 gray30 gray40 gray50 gray60 gray70 gray80 gray90}
  {"Monochrome" white gray90 gray20 black}
  {"Blues" #000022 #000033 #000044 #000055 #000066 #000077 #000088
           #000099 #0000AA #0000BB #0000CC #0000DD #0000EE #0000FF}
  {"Australia II" green1 green2 gold1 gold2}
  {"Primary Shades" red pink lightblue blue yellow orange}
  {"RGB" red green blue}
  {"RGB Plus" red green blue cyan magenta yellow}
  {"Pinky" #ffaaaa #ffbbbb #ffcccc #ffdddd #ffeeee}
  {"Urban Camo" #222200 #444400 #666600 #888800 #AAAA00 #CCCC00 #FFFF00}
  {"Seascape" #002222 #004444 #006666 #008888 #00AAAA #00CCCC #00FFFF
	      #4444FF #8888FF #BBBBFF #88FFFF #88EEEE #88DDDD #88CCCC}
  {"Inferno" #440000 #660000 #880000 #AA0000 #CC0000 #EE0000 #FF6600
	     #FF0000 #FF4400 #FF8800 #FFAA00 #FFBB00 #FFFF00 #FFDD00}
  {"Southwest" bisque1 bisque2 bisque3 bisque4
	       gold1 gold2 gold3 gold4
	       tan1 tan2 tan3 tan4
	       wheat1 wheat2 wheat3 wheat4
	       orange1 orange2 orange3 orange4
	       chocolate1 chocolate2 chocolate3 chocolate4
	       AntiqueWhite1 AntiqueWhite2 AntiqueWhite3
	       LemonChiffon1 LemonChiffon2 LemonChiffon3 LemonChiffon4
	       black white white white white}
}

lappend colors "Velvet Tapestry"
foreach r {00 44 88 BB} {
  foreach g {00 44 88 BB} {
    foreach b {00 44 88 BB} {
      lappend colors #$r$g$b
    }
  }
}
lappend themes $colors
set colors {}

lappend colors "Pastel"
foreach r {AA BB CC DD} {
  foreach g {AA BB CC DD} {
    foreach b {AA BB CC DD} {
      lappend colors #$r$g$b
    }
  }
}
lappend themes $colors
set colors {}

lappend colors "Lilacs and Violets"
foreach r {EE FF CC DD} {
  foreach g {EE FF CC DD} {
    foreach b {EE FF} {
      lappend colors #$r$g$b
    }
  }
}
lappend themes $colors
set colors {}

lappend colors "Wildflowers" black lightblue red orange yellow yellow yellow
foreach r {00 22} {
  foreach g {88 AA EE FF CC DD} {
    foreach b {00 11 22} {
      lappend colors #$r$g$b
    }
  }
}
lappend themes $colors
set colors {}

# Figure out the screen borders, by OS. Tweak these numbers so the edges line
# up nicely in full screen mode... which isn't necessarily exactly the same
# as the window decoration width, depending on the OS. The UNIX stuff will
# need further tweaking depending on the window manager. Windows probably
# depends on whether you're under XP or 2000.

set delta(x) 0
set delta(y) 0
set menubar 0
switch $tcl_platform(platform) {
        unix {
                if {"$tcl_platform(os)" == "Darwin"} {;# Mac OS X
                        set delta(x) 13
			set delta(y) 6
			set menubar 1
                } else {
			set delta(x) 8;# For fvwm, 0 for Windowmaker, ...
			set delta(y) 18;# For fvwm, 16 for Windowmaker, ...
                }
        }
        windows {;# For XP
		set delta(x) 0
		set delta(y) 18
        }
        macintosh {;# Mac OS 9
		set delta(x) 15
		set delta(y) 12
		set menubar 1
        }
}

# Make sure there's a window to work from, then see how big it can get.
update
foreach {x y} [wm maxsize .] {
  if {$x > 2*$y} {
    set x [expr $x / 2]
  } else {
    incr x $delta(x)
  }
  incr y $delta(y)
  set param(x) $x
  set param(y) $y
}

frame .f -height $y -width $x
pack .f
bind . <Any-Escape> exit
bind . <Any-space> {set abort 1}
bind . <Any-Tab> redecorate
proc redecorate {{new -1}} {
  global decor title
  if ![info exists decor] {
    set decor 1
  }
  if {$new != -1} {
    if {$new == $decor} {
      return
    }
  }
  if $decor {
    wm overrideredirect . 1
    wm geometry . +0+0
    set decor 0
  } else {
    wm overrideredirect . 0
    wm geometry . +16+16
    if [info exists title] {
      wm title . $title
    }
    set decor 1
  }
}
redecorate
proc title {text} {
  global decor title
  set title $text
  if $decor {
    wm title . $title
  }
}

set dumpfile {}
set dumping 0
proc setdump {{getname 0}} {
  global dumpfile dumping
  if {$getname || "$dumpfile" == ""} {
    if {"$dumpfile" == ""} {
      set oldfile "Division.ps"
    } else {
      set oldfile $dumpfile
    }
    set newfile [
      tk_getSaveFile -initialfile $oldfile -defaultextension ps \
        -message "Save next completed image as a Postscript file" \
        -title "Save file"
    ]
    if {"$newfile" == ""} {
      return
    }
    set dumpfile $newfile
  }
  set dumping 1
}
proc dumper {canvas} {
  global dumpfile dumping abort
  if {$dumping && !$abort} {
    $canvas postscript -file $dumpfile
    set dumping 0
  }
}

proc setmenu {{comments {}}} {
  .m delete 0 end
  .m add command -command {set abort 1} -label "Skip" 
  foreach row $comments {
    .m add command -state disabled -label $row
  }
  .m add separator
  .m add command -command {setdump} -label "Save"
  .m add command -command {setdump 1} -label "Save as..."
  .m add separator
  .m add command -command {exit} -label "Quit"
}
menu .m -tearoff 0
if $menubar {
  menu .mb -tearoff 0
  .mb add cascade -menu .m -label File
  . configure -menu .mb
}
bind . <ButtonPress-2> {+.m post %X %Y}
bind . <ButtonPress-1> {+.m unpost}
bind . <Control-ButtonPress-1> {+.m post %X %Y}
setmenu

if [catch {
  while 1 {
    set param(outline) [
      random {black black gray gray white white blue none random
		"bold black" "bold white" "bold gray"}
    ]
    set param(size) [random {12 16 24 32 48 64 96 128}]
    set param(unsquare) [random {1 1.125 1.25 1.5 2 3 4 6 10}]
    set param(irregular) [random {1 1.25 1.5 1.75 2 2.33 2.67 3 3.5 4}]
    if [string match "bold *" $param(outline)] {
      set param(scatter) [random {0 0 0 0 0.33 0.5 0.67 1 1 1 1.33 1.67 2 2.67}]
    } else {
      set param(scatter) [random {0 0 0 0 0 0 0 0.25 0.5 1 1 1.5 2}]
    }
    set param(complete) [random {
	0.1 0.2 0.5 1 1 1 2 2 2 3 3 3 4 4 5 5 5 6 7 8 8 9 9 9.5 9.75 9.9
	10 10 10 10 10 10 10 10 10 10 10 10 10 10
    }]
    if {$param(complete) < 5 && $param(size) >= 48} {
      set param(size) 32
    }
    if {$param(complete) < 1} {
      set param(size) 12
    }
    set theme [random $themes]
    set param(name) [lindex $theme 0]
    set param(colors) [lrange $theme 1 end]
    if [string match R* $param(name)] {
      if {"$param(outline)" == "none" || "$param(outline)" == "blue" || "$param(outline)" == "random"} {
        set param(outline) black
      }
    }
    set param(mosaic) [random {0 0 0 0 1}]
    if $param(mosaic) {
      set cleaners {blower unwind poof sunlamp hightide tsunami dissolve}
    } else {
      set cleaners {blower unwind shuffle poof acid erode sunlamp hightide
		 tsunami dissolve}
    }
    set param(clean) [random $cleaners]
    if {"$param(clean)" == "shuffle" && $param(size) >= 64} {
      set param(size) 48
    }

    set comments {}
    lappend comments "size=$param(size)"
    foreach {par def} {
      unsquare 1 irregular 1 scatter 0 complete 10 outline black
    } {
      if {"$param($par)" != "$def"} {
        set text $param($par)
        if ![string is double $text] {
	  set text '$text'
	}
        lappend comments "$par=$text"
      }
    }
    if {$param(mosaic)} {
      lappend comments mosaic
    }
    lappend comments "clean='$param(clean)'"

    setmenu [concat [list $param(name)] $comments]
    title "$param(name) ([join $comments ", "])"

    divider .f.c $x $y
    after 1000
    set abort 0
    $param(clean) $param(size)
    destroy .f.c
    set objects {}
  }
} err] {
  # global errorInfo
  # puts stderr $errorInfo
}

exit