#
# Colliding Spheres by David Easton, https://wiki.tcl-lang.org/9860
# Based on: Colliding Coins by Leszek Holenderski, https://wiki.tcl-lang.org/8709
#           Spheres by Ulis, https://wiki.tcl-lang.org/9847
#
package require Tk 8.4
# configurable parameters
#
set canvasWidth  600 ;# in pixels
set canvasHeight 500 ;# in pixels
set numOfCoins    20
set minRadius     10 ;# in pixels
set maxRadius     40 ;# in pixels
set maxVelocity    5 ;# in pixels, per one animation step
set delay         20 ;# in milliseconds, per one animation step
set colours [list 1,1,1 1,1,0 1,0,1 0,1,1 1,0,0 0,1,0 0,0,1 0,0.5,0]
set light 1.0
set source 0.0

# Gradient proc from Ulis, https://wiki.tcl-lang.org/9847
#
proc gradient {image relief light source red green blue} {
    set sunken [string match sun* $relief]
    set light [expr {$light * 96 + 32}]
    set source [expr {0.5 + $source / 2.0}]
    set D [image width $image]
    set R [expr {$D / 2}]
    set R2 [expr {$R * $R}]
    for {set y 0} {$y < $D} {incr y} \
    {
        set Dy2 [expr {($y - $R) * ($y - $R)}]
        set dy [expr {($y * $source - $R)}]
        set dy2 [expr {$dy * $dy}]
        for {set x 0} {$x < $D} {incr x} \
        {
            set Dx2 [expr {($x - $R) * ($x - $R)}]
            set Dxy [expr {$Dx2 + $Dy2}]
            if {$Dxy <= $R2} \
            {
                set dx [expr {($x * $source - $R)}]
                set dx2 [expr {$dx * $dx}]
                set dxy [expr {$dx2 + $dy2}]
                set color [expr {int(127 + $light * (1.0 - ($dxy / $R2 / 1.5)))}]
                if {$sunken} { set color [expr {int(127 + $light * 2 - $color)}] }
                set color [format "#%02x%02x%02x" [expr {int($color*$red)}] \
                                                                                    [expr {int($color*$green)}] \
                                                                                    [expr {int($color*$blue)}]]
                $image put $color -to [expr {$D - $x}]  [expr {$D - $y}]
            }
        }
    }
}

# coins are identified by their canvas id, and not special tags
#
proc createCoin {} {
    # pick random radius and colour
    set r [expr {$::minRadius+int(rand()*($::maxRadius-$::minRadius))}]
    set d [expr {2*$r}]
    # to simulate Big Bang, all coins are created in the canvas' center
    set x [expr {$::canvasWidth/2.0}]
    set y [expr {$::canvasHeight/2.0}]
    set c [lindex $::colours [expr {int(rand()*[llength $::colours])}]]
    lassign [split $c ,] red green blue
    set image [image create photo -width $d -height $d]
    gradient $image raised $::light $::source $red $green $blue
    set coin [$::canvas create image $x $y -anchor c -image $image]
    # pick random velocity
    set u [expr {$::maxVelocity*(2*rand()-1)}]
    set v [expr {$::maxVelocity*(2*rand()-1)}]
    # store coin's attributes
    global State
    set State($coin,pos)  [list $x $y]
    set State($coin,vel)  [list $u $v]
    set State($coin,mass) [expr {double($r*$r)}] ;# mass ~ area
    return [list $coin $r]
}
# collide a given coin with all other coins that overlap with it
#
proc collide {coin radius} {
    # find coin's center
    lassign [$::canvas coords $coin] x y
    # find other coins that overlap with the given coin
    set overlap [list]
    $::canvas raise $coin ;# not sure if really needed
    set next $coin
    while {[set next [$::canvas find closest $x $y $radius $next]] != $coin} {
        # Check that centres are within collision range (i.e. not just bbox of image)
        lassign [$::canvas coords $next] x2 y2
        if {[expr {hypot($x2-$x,$y2-$y) - $radius - $::coinToRad($next)}] < 0} {
                lappend overlap $next
        }
    }
    # collide the given coin with other coins
    foreach other $overlap { collideCoins $coin $other }
}
# recalculate velocities after collision
#
proc collideCoins {coin1 coin2} {
    global State
    # get positions and velocities of each coin
    lassign $State($coin1,pos) x1 y1
    lassign $State($coin2,pos) x2 y2
    lassign $State($coin1,vel) u1 v1
    lassign $State($coin2,vel) u2 v2
    # compute the angle of the collision axis
    if { $x1 != $x2 } {
        set phi [expr {atan(double($y2-$y1)/double($x2-$x1))}]
    } else {
        set phi [expr {asin(1)}] ;# 90 degrees
    }
    set sin [expr {sin($phi)}]
    set cos [expr {cos($phi)}]
    # project velocities on the axis of collision
    # (i.e., get the parallel and perpendicular components)
    set par1 [expr {$u1*$cos + $v1*$sin}]
    set per1 [expr {$u1*$sin - $v1*$cos}]
    set par2 [expr {$u2*$cos + $v2*$sin}]
    set per2 [expr {$u2*$sin - $v2*$cos}]
    # return if the coins are not going towards each other
    if { $x1 != $x2 } {
        if { $x1<$x2 && $par2>$par1 || $x1>$x2 && $par2<$par1 } return
    } else {
        if { $y1<$y2 && $par2>$par1 || $y1>$y2 && $par2<$par1 } return
    }
    # compute parallel velocities after collision
    # (note that perpendicular velocities do not change)
    set m1 $State($coin1,mass)
    set m2 $State($coin2,mass)
    set v [expr {2*($m1*$par1+$m2*$par2)/($m1+$m2)}]
    set par1 [expr {$v-$par1}]
    set par2 [expr {$v-$par2}]
    # convert new velocities back to x and y coordinates
    set u1 [expr {$par1*$cos + $per1*$sin}]
    set v1 [expr {$par1*$sin - $per1*$cos}]
    set u2 [expr {$par2*$cos + $per2*$sin}]
    set v2 [expr {$par2*$sin - $per2*$cos}]
    # update velocities
    set State($coin1,vel) [list $u1 $v1]
    set State($coin2,vel) [list $u2 $v2]
}
# perform one animation step
# (no collisions during first $BigBang steps)
#
proc animate {BigBang} {
    global State
    foreach {coin radius} $::coins {
        lassign $State($coin,vel) u v
        lassign $State($coin,pos) x y
        set newPos [list [expr {$x+$u}] [expr {$y+$v}]]
        # bounce off the edges
        $::canvas move $coin $u $v
        lassign [$::canvas bbox $coin] x1 y1 x2 y2
        if { $x1<=0 && $u<0 || $x2>=$::canvasWidth && $u>0} {
            set u [expr {-$u}]
        }
        if { $y1<=0 && $v<0 || $y2>=$::canvasHeight && $v>0} {
            set v [expr {-$v}]
        }
        set State($coin,vel) [list $u $v]
        # collide with other coins
        if {!$BigBang} { collide $coin $radius }
        # update position
        set State($coin,pos) $newPos
    }
    if {$BigBang > 0} {
        after $::delay "animate [incr BigBang -1]"
    } else {
        after $::delay "animate 0"
    }
}
# create canvas
wm title . "Colliding Spheres"
set canvas [canvas .c -width $canvasWidth -height $canvasHeight]
# get new canvas size whenever canvas is resized
bind $canvas <Configure> {
    set canvasWidth  [winfo width  %W]
    set canvasHeight [winfo height %W]
}
# create coins
for {set i 0} {$i < $numOfCoins} {incr i} {
    eval lappend coins [createCoin]
}
array set coinToRad $coins
# start animation: first Big Bang then collisions

bind $canvas <Map> {
animate $numOfCoins
}
pack $canvas -fill both -expand true