'''[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?
** Changes **
[PYK]: Updated to more modern Tcl syntax. See [https://wiki.tcl-lang.org/revision/buggy+Pinball?V=4%|%version 4] of this page for older syntax.
** Code **
======
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}
======
<<categories>> Application | Games