#
# Exploding Balls
# Based on Colliding Balls by David Easton.
# Author: David Easton
#   mods by Jeff Hobbs just to brace expr's (improve speed)
#     and clean up some foreach usage
#   mods by Peter da Silva: fix collision logic, add gravity, friction,
#     elasticity, make FPS a constant, and smooth refresh.
#   more mods by Peter da Silva: Incorporate some of LH's changes.
#     Add a bunch of parameters. And make balls fade away if
#     ignored, or swell and burst when poked.
#   and post-wiki mods: make mass a function of r^3. Little balls SHOULD
#     shoot up high!
#

package require Tk

#### Settings
# Set frames per second (if much less than 20, it's not very smooth)
set State(fps) 20.0

# Set gravity - 9.8 pixels per second per second
set State(gravity) 9.8

# Set friction - 10% of velocity per second
set State(friction) 0.1

# Set elasticity - 95%
set State(bounce) 0.95
#set State(bounce,walls) 0.80
set State(bounce,balls) 1.05

# How much do balls expand when they hit
set State(grow) 1.01

# How much do balls shrink when left alone, per second
set State(shrink) 0.025

# Size of balls
set State(minSize) 20
set State(maxSize) 50

# # balls
set State(balls) 8

# Color palette for balls
# set State(colours) {
#     red yellow darkgreen green blue lightblue orange pink purple white
# }
for {set r 63} {$r < 256} {incr r 16} {
  for {set g 63} {$g < 256} {incr g 16} {
    for {set b 63} {$b < 256} {incr b 16} {
      lappend State(colours) [format #%02X%02X%02X $r $g $b]
    }
  }
}

#
# Fade color as fraction
#
proc fade {colour level {target white}} {
    global rgb
    global divideColors
    if ![info exists rgb($colour)] {
        set rgb($colour) [winfo rgb . $colour]
    }
    if ![info exists rgb($target)] {
        set rgb($target) [winfo rgb . $target]
    }
    if ![info exists divideColors] {
        if ![info exists rgb(white)] {
            set rgb(white) [winfo rgb . white]
        }
        set divideColors [expr {[lindex $rgb(white)] > 255}]
    }
    if {$level > 1.0} {
        set level 1.0
    } elseif {$level < 0.0} {
        set level 0.0
    }
    set new "#"
    foreach c $rgb($colour) t $rgb($target) {
        if {$divideColors} {
            set c [expr {$c / 256}]
            set t [expr {$t / 256}]
        }
        append new [format %02X [expr {int($c * $level + $t * (1 - $level))}]]
    }
    return $new
}

#
# Return an entry from the list at random
#
proc randFromList {inputList} {
    return [lindex $inputList [expr {int(rand() * [llength $inputList])}]]
}

#
# Given the initial velocities and radii
# calculates velocities following a collision
#
proc postColVels {u1 u2 r1 r2} {
   set m1 [expr {$r1*$r1*$r1}]
   set m2 [expr {$r2*$r2*$r2}]
   set u [expr {2*($m1*$u1+$m2*$u2)/($m1+$m2)}]
   list [expr {$u-$u1}] [expr {$u-$u2}]
}



proc createBall { tag {init 1}} {
    global State

    set radius [expr {int(($State(sizeRange) * rand()) + $State(minSize))}]
    set diam   [expr {2 * $radius}]

    set canvasHeight [winfo height $State(canvas)]
    set canvasWidth  [winfo width $State(canvas)]

    set xpos [expr {$radius + int(($canvasWidth - $diam) * rand())}]
    if {$init} {
        set ypos [expr {$radius + int(($canvasHeight - $diam) * rand())}]
    } else {
        set ypos $diam
    }

    set x1 [expr {$xpos - $radius}]
    set x2 [expr {$xpos + $radius}]
    set y1 [expr {$ypos - $radius}]
    set y2 [expr {$ypos + $radius}]

    # Random colour
    set colour [randFromList $State(colours)]
    set border [randFromList $State(colours)]
    set width [expr {(rand() + 0.5) * (($radius * 4.0) / $State(minSize))}]

    # Now create or configure ball
    if {$init} {
        set id [$State(canvas) create oval $x1 $y1 $x2 $y2 \
                -outline $border -fill $colour -width $width \
                -tags [list $tag ball]]

        set State(id2tag,$id) $tag
         set State(tag2id,$tag) $id

        set xvel [expr {(rand() * 8.0) -2}]
        set yvel [expr {(rand() * 8.0) -2}]
    } else {
         set id $State(tag2id,$tag)
         $State(canvas) coords $id $x1 $y1 $x2 $y2
         $State(canvas) itemconfigure $id \
                -fill $colour -outline $border -width $width

        set xvel [expr {(rand() * 8.0) -4}]
        set yvel [expr {(rand() * 4.0)}]
    }

    set State(vel,$tag) [list $xvel $yvel]
    set State(rad,$tag) $radius
    set State(col,$tag) $colour
    set State(bdr,$tag) $border
    set State(wid,$tag) $width
}

#
# Check if we have collided with another ball
#
# Returns: 1 - If there was a collision
#          0 - If no collision
#
proc checkForCollision { tag } {
    global State
    set c $State(canvas)
    set r $State(rad,$tag)

    foreach { x1 y1 x2 y2 } [$c coords $tag] break
    set x [expr {($x1+$x2)/2.0}]
    set y [expr {($y1+$y2)/2.0}]

    set overlapList [list]
    set id [set ourId [$c find withtag $tag]]
    $c raise $tag ;# not sure whether really needed
    while { [set id [$c find closest $x $y $r $id]] != $ourId } {
        lappend overlapList $id
    }

    if { [llength $overlapList] > 0 } {
        foreach id $overlapList {
            collide $tag $State(id2tag,$id)
        }
        return 1
    }

    return 0
}

proc moveBalls { } {

    global State
    global hot

    # Cancel any "lost" frames
    if [info exists State(id)] {
        after cancel $State(id)
    }

    # Reschedule at the beginning to keep updates smooth
    set State(id) [after $State(delay) moveBalls]

    set canvasHeight [winfo height $State(canvas)]
    set canvasWidth  [winfo width $State(canvas)]

    foreach ball $State(ballList) {

        foreach {xvel yvel} $State(vel,$ball) {}

        if {[info exists State(gravity)]} {
          set yvel [expr {$yvel + $State(gravity)}]
        }

        if {[info exists State(friction)]} {
            set yvel [expr {$yvel * (1.0 - $State(friction))}]
            set xvel [expr {$xvel * (1.0 - $State(friction))}]
        }

        $State(canvas) move $ball $xvel $yvel

        # Bounce off the edges
        foreach {x1 y1 x2 y2} [$State(canvas) bbox $ball] {}

        # Has something moved us through the wall?
        if {$x2 < 0 || $x1 > $canvasWidth || $y2 < 0 || $y1 > $canvasHeight} {
            lappend reanimate $ball
        }

        # Left edge
        if { $x1 < 0 && $xvel < 0} {
            set xvel [expr {-$State(bounce,walls) * $xvel}]
        }
       # Right edge
        if { $x2 > $canvasWidth && $xvel > 0} {
            set xvel [expr {-$State(bounce,walls) * $xvel}]
        }
       # Top edge
        if { $y1 < 0 && $yvel < 0} {
            set yvel [expr {-$State(bounce,walls) * $yvel}]
        }
        # Bottom edge
        if { $y2 > $canvasHeight && $yvel > 0} {
            if {[info exists State(gravity)]} {
               if {
                    $State(shrink) == 1.0 &&
                    $yvel < $State(gravity) &&
                    abs($xvel) < $State(gravity)
                } {
                    lappend reanimate $ball
                }

               # Make the bottom border a bit tougher if we have gravity, OK?
               $State(canvas) move $ball 0 [expr {$canvasHeight - $y2}]
           }
            set yvel [expr {-$State(bounce,walls) * $yvel}]

        }


        # Update for new velocity
        set State(vel,$ball) [list $xvel $yvel]

        # If haven't collided with anyone, shrink
        if {![checkForCollision $ball] && [info exists State(shrink)]} {
            set r [expr {$State(rad,$ball) * $State(shrink)}]
            set State(rad,$ball) $r
            if {$r < $State(minSize)} {
                set fade [expr {$r / $State(minSize)}]
                if {$fade < 0.5} {
                    lappend reanimate $ball
                } else {
                    set fade [expr {2.0 * $fade - 1.0}]
                    $State(canvas) itemconfigure $ball \
                        -fill [fade $State(col,$ball) $fade] \
                        -outline [fade $State(bdr,$ball) $fade] \
                        -width [expr {$State(wid,$ball) * $fade}]
                }
            }
            set xpos [expr {($x1 + $x2) / 2}]
            set ypos [expr {($y1 + $y2) / 2}]
            $State(canvas) scale $ball $xpos $ypos $State(shrink) $State(shrink)
       } else {
            set r $State(rad,$ball)
        }
        if {$r > $State(maxSize)} {
            set hot($ball) 1
        } elseif {[info exists hot($ball)]} {
            set hot($ball) 0
        }
        if {[info exists hot($ball)]} {
            if {!$hot($ball)} {
                unset hot($ball)
            }
            set fade [expr {$r / $State(maxSize)}]
            if {$fade > 2.0} {
                lappend reanimate $ball
            } else {
                set fade [expr {2.0 - $fade}]
                $State(canvas) itemconfigure $ball \
                        -fill [fade $State(col,$ball) $fade red] \
                        -outline [fade $State(bdr,$ball) $fade red] \
                        -width [expr {$State(wid,$ball) * (2.0 - $fade)}]
            }
        }
    }

    # Reanimate one ball per frame
    if [info exists reanimate] {
        createBall [lindex $reanimate 0] 0
    }
}

proc collide { tag1 tag2 } {
    global State

    # Calculate position of balls (don't track them because of rounding error)
    foreach {bx1 by1 bx2 by2} [$State(canvas) coords $tag1] break
    set x1 [expr {($bx1 + $bx2) / 2}]
    set y1 [expr {($by1 + $by2) / 2}]

    foreach {bx1 by1 bx2 by2} [$State(canvas) coords $tag2] break
    set x2 [expr {($bx1 + $bx2) / 2}]
    set y2 [expr {($by1 + $by2) / 2}]

    # Get velocity of each ball

    foreach {ux1 uy1} $State(vel,$tag1) {ux2 uy2} $State(vel,$tag2) {}

    # Work out the angle along the axis of collision

    if { $x1 != $x2 } {
        set phi [expr {atan(double($y2-$y1)/double($x2-$x1))}]
    } else {
        set phi [expr {asin(1)}] ;# 90 degrees
    }

    # Now work out the velocity parallel and perpendicular

    set uparr1 [
        expr {(($ux1 * cos($phi)) + ($uy1 * sin($phi))) * $State(bounce,balls)}
    ]
    set uperp1 [expr {($ux1 * sin($phi)) - ($uy1 * cos($phi))}]

    set uparr2 [
        expr {(($ux2 * cos($phi)) + ($uy2 * sin($phi))) * $State(bounce,balls)}
    ]
    set uperp2 [expr {($ux2 * sin($phi)) - ($uy2 * cos($phi))}]

    # If they are not going towards each other, then they will not collide
    if { $x1 != $x2 } {
        if { $x1<$x2 && $uparr2>$uparr1 || $x1>$x2 && $uparr2<$uparr1 } return
    } else {
        if { $y1<$y2 && $uparr2>$uparr1 || $y1>$y2 && $uparr2<$uparr1 } return
    }

    foreach {vparr1 vparr2} [
        postColVels $uparr1 $uparr2 $State(rad,$tag1) $State(rad,$tag2)
    ] break

    # Perpendicular velocites are unchanged

    set vperp1 $uperp1
    set vperp2 $uperp2

    # Now convert back into x and y movements
    set vx1 [expr {($vparr1 * cos($phi)) + ($vperp1 * sin($phi))}]
    set vy1 [expr {($vparr1 * sin($phi)) - ($vperp1 * cos($phi))}]

    set vx2 [expr {($vparr2 * cos($phi)) + ($vperp2 * sin($phi))}]
    set vy2 [expr {($vparr2 * sin($phi)) - ($vperp2 * cos($phi))}]

    # Update for new velocities

    set State(vel,$tag1) [list $vx1 $vy1]
    set State(vel,$tag2) [list $vx2 $vy2]

    # If growing, grow
    if [info exists State(grow)] {
        set State(rad,$tag1) [expr {$State(rad,$tag1) * $State(grow)}]
        $State(canvas) scale $tag1 $x1 $y1 $State(grow) $State(grow)
        set State(rad,$tag2) [expr {$State(rad,$tag2) * $State(grow)}]
        $State(canvas) scale $tag2 $x2 $y2 $State(grow) $State(grow)
    }
}

# Seed random number generator
expr {srand([clock clicks])}

# Window things
wm title . "Bouncing balls"

# Create canvas
set State(canvas) [canvas .c -width 500 -height 400]
pack $State(canvas) -fill both -expand true

#### check settings!
# Set delay to 1000, will be scaled by fps
set State(delay) 1000

# Some variables scale by frame rate
foreach v {gravity friction delay shrink} {
  if [info exists State($v)] {
    set State($v) [expr {$State($v) / $State(fps)}]
  }
}

# If FPS is real low, increase grow rate.
if {[info exists $State(grow)] && $State(fps) < 20.0} {
  set State(grow) [expr {1 + ($State(grow) - 1.0) * 20.0 / $State(fps)}]
}

# delay is an integer
set State(delay) [expr {int($State(delay))}]

# Convert shrink to ratio
if [info exists State(shrink)] {
  set State(shrink) [expr {1 - $State(shrink)}]
}

# Calculate size range
set State(sizeRange) [expr {$State(maxSize) - $State(minSize)}]

# Set missing elasticity values
foreach object {balls walls} {
  if ![info exists State(bounce,$object)] {
    if [info exists State(bounce)] {
      set State(bounce,$object) $State(bounce)
    } else {
      set State(bounce,$object) 1.0
    }
  }
}

update

# Create balls
for {set i 0} {$i < $State(balls)} {incr i} {
  lappend State(ballList) ball$i
  createBall ball$i
}

moveBalls