package require Tk

proc main {} {
    global g
    array set g {left - right - h 0}
    pack [canvas .c -width 320 -height 510]
    set paddlec blue
    paddle .c 120 500 25  $paddlec
    paddle .c 180 500 -25 $paddlec
    bind . <Left>             {flip .c left -0.8}
    bind . <KeyRelease-Left>  {flip .c left 0.8}
    bind . <Right>            {flip .c right 0.8}
    bind . <KeyRelease-Right> {flip .c right -0.8}

    #.c create poly 0 450 110 495 110 600 0 600 -fill white \
        -outline black
    reflector .c 0 450 115 495
    #.c create poly 300 450 190 495 190 600 300 600 -fill white \
        -outline black
    reflector .c 185 495 300 450
    reflector .c 305 75 316 120
    .c create line 0 450 0 250 0 50 160 0 322 50 322 250 322 500 \
        -width 10 -smooth 1 -tag bump
    .c create line 300 160 300 500 -width 1 -tag reflect
    
    bumper .c 215 215 100  yellow
    bumper .c 115 215 1000 orange
    bumper .c 170 120 50   green
    reflector .c 50 250 100 300
    set x 80
    foreach c [split TkPinball {}] {
        light .c $x 350 $c
        incr x 20
    }
    set id [.c create text 280 480]
    trace add variable g(perc) write ".c itemconfig $id -text \$g(perc);#"
    trace add variable g(score) write {after idle [list wm title . $::g(score)];#}
    newBall .c 308 440
    .c raise reflect
}


proc paddle {w x y length color} {
    $w create oval [expr {$x - 5}] [expr {$y - 5}] [
        expr {$x + 5}] [expr {$y + 5}] -fill black -tag {paddle bump}
    set coords [list $x $y $x [expr {$y - 5}]]
    set x1 [expr {$x + $length}]
    lappend coords $x1 [expr {$y - 2}] $x1 [expr {$y + 2}] $x [expr {$y + 5}]
    set name [expr {$length > 0 ? {left} : {right}}]
    set sign [expr {$length > 0 ? 1 : -1}]
    $w create poly $coords -fill $color -tag "$name paddle"
    $w create line $x [expr {$y - 5}] $x1 [expr {$y - 2}] -tag "$name reflect"
    flip $w $name [expr {0.4 * $sign}]
}


proc flip {w name angle} {
    global g
    if {$g($name) != $angle} {
         set g($name) $angle
         rotate $w $name $angle
         if {$angle > 0} {set g(h) [expr {$g(h) + 0.1}]}
    }
}


proc rotate {w name angle} {
    foreach item [$w find withtag $name] {
        foreach {x0 y0} [$w coords $item] break
        set coords {}
        foreach {x y} [$w coords $item] {
            set r [expr {hypot($x - $x0, $y - $y0)}]
            set th [expr {atan2($y - $y0,$x - $x0) + $angle}]
            lappend coords [expr {$x0 + cos($th) * $r}] [
                expr {$y0 + sin($th) * $r}]
        }
        $w coords $item $coords
    }
}


proc bumper {w x y value color} {
    $w create oval [expr {$x - 15}] [expr {$y - 15}] [expr {$x + 15}] [
        expr {$y + 15}] -fill $color -tag "bump p$value"
    $w create text $x $y -text $value
}


proc reflector {w x0 y0 x1 y1} {
    $w create line $x0 $y0 $x1 $y1 -width 4 -fill red -tag reflect
}


proc light {w x y char} {
    global g
    $w create rect [expr {$x - 10}] [expr {$y - 10}] [expr {$x + 10}] [
        expr {$y + 10}] -fill yellow -tag light
    $w create text $x $y -text $char -font {Helvetica 15}
}


proc newBall {w {x -} {y -}} {
    global g
    array set g {score 0 last - start 1}
    if {$x eq {-}} {
        set x $g(tx); set y $g(ty)
    } else {
        set g(tx) $x; set g(ty) $y
    }
    $w delete trigger
    after cancel [after info]
    $w create oval [expr {$x - 5}] [expr {$y - 5}] [expr {$x + 5}] [
        expr {$y + 5}] -fill white -tag {ball trigger}
    set y6 [expr {$y + 6}]
    $w create line [expr {$x - 5}] $y6 [
        expr {$x + 5}] $y6 -width 3 -tag {trigger bump}
    $w create line $x $y6 $x [expr {$y + 150}] -width 3 -tag trigger
    set g(perc) 0
    # ball will travel straight upwards
    set g(h) 1.57079632679
    bind . <Down> "if {$g(start) && \$g(perc) < 100} {
        incr g(perc) 5; $w move trigger 0 3}"
    bind . <KeyRelease-Down> "if \$g(start) {
        $w move trigger 0 -\$g(perc); roll $w}"
    $w itemconfig light -fill yellow
}


proc roll w {
    global g
    foreach {x0 y0 x1 y1} [$w coords ball] break
    if {$y0 > $g(ty) + 100} {
        newBall $w
        return
    }
    set xm [expr {($x0 + $x1) / 2.}]
    set ym [expr {($y0 + $y1) / 2.}]
    if {$g(start) && $ym < 160} {
        set g(h) [expr {$g(h) + 0.09}]
    }
    if {$ym > 160} {set g(start) 0}
    set speed [expr {$g(perc) / 20.}]
    set dx [expr {cos($g(h)) * $speed}]
    set dy [expr {-sin($g(h)) * $speed}]
    if {!$g(start)} {collide? $w $xm $ym $dx $dy}
    if {$speed < 10} {
        set g(perc) [expr {round($g(perc) + $dy / 10.)}]
    }
    $w move ball $dx $dy
    after 25 roll $w
}


proc collide? {w x y dx dy} {
    global g
    set next [$w find closest [expr {$x + $dx}] [expr {$y + $dy}] 7 ball]
    if {$next eq {}} {
        set next [$w find closest $x $y 7 ball]
    }
    if {$next ne {} && $next != $g(last)} {
        set g(last) $next
        set g(start) 0
        set tags [$w gettags $next]
        if {[in $tags reflect]} {
            set coords [$w coords $next]
            foreach {x0 y0 x1 y1} $coords break
            set tg [expr {atan2($y1 - $y0,$x1 - $x0) + 1.57079632679}]
            set delta [expr {$g(h) - $tg}]
            set g(h) [expr {fmod($g(h) + 2 * $delta, 6.28284)}]
        } elseif {[in $tags bump]} {
            set g(h) [expr {fmod($g(h) + 3.14142, 6.28284)}]
            set g(perc) 100
        } elseif {[in $tags light]} {
            if {[$w itemcget $next -fill] eq {yellow}} {
                $w itemconfig $next -fill grey
                incr g(score) 25
            }
        }
        if [in $tags p50] {incr g(score) 50}
        if [in $tags p100] {incr g(score) 100}
        if [in $tags p1000] {incr g(score) 1000}
    } 
}


proc in {list value} {expr {[lsearch $list $value] >= 0}}

#---------------------------------------------------------------------
main

raise .
wm geometry . +0+0
bind .c <Motion> {wm title . %x,%y}

bind . <Escape> {exec wish $argv0 &; exit}