[RS] 2003-09-04 - This unfinished pinball game has been sitting on
my hard disk for a while. As [GPS] showed interest, I now put it on the
Wiki - beware that it often works, but at times the ball behaves very
badly. Play with cursor keys: <Down> to pull trigger, <Left>/<Right> for
the paddles.

[WikiDbImage pinball.jpg]

Maybe fellow Tclers can fix the bugs?
======
 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 var g(perc) w ".c itemconfig $id -text \$g(perc);#"
    trace var g(score) w {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 == "-"} {
        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
    set g(h) 1.57079632679 ;# ball will travel straight upwards
    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 == ""} {
        set next [$w find closest $x $y 7 ball]
    }
    if {$next != "" && $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]=="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}
======

<<categories>> Application | Games