# Colliding Coins by Leszek Holenderski, https://wiki.tcl-lang.org/8709
# Based on Colliding Balls by David Easton, https://wiki.tcl-lang.org/8573
#
package require Tk

# 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 red yellow green blue white gray50 darkgreen black]

# 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 c [lindex $::colours [expr {int(rand()*[llength $::colours])}]]

    # 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 coin [$::canvas create oval \
                                            [expr $x-$r] [expr $y-$r] [expr $x+$r] [expr $y+$r] \
                                            -outline "" -fill $c]

    # 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] x1 y1 x2 y2
    set x [expr {($x1+$x2)/2.0}]
    set y [expr {($y1+$y2)/2.0}]

    # 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} {
        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 coords $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 Coins"
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]
}

# start animation: first Big Bang then collisions
bind $canvas <Map> {
    animate $numOfCoins
}
pack $canvas -fill both -expand true