2009-07-10 - Just another pong!

To control the pads use 'q', 'a', 'p' and 'l' keys. 

[http://1.bp.blogspot.com/_FDA3N96YFtA/SSylsKA2p4I/AAAAAAAAAAw/I62t0ZWgncg/s400/tkpong-screenshoot.png]
----
# Copyright (c) 2008, 2009 Héctor Francisco Hernández <hectorfh@gmail.com>
#
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

package require Tk

canvas .canvas -width 520 -height 390 -bg green4
label .lblbtm -textvariable lblbtm
pack .canvas
pack .lblbtm -fill x

.canvas create rectangle 10 156 25 234 -tag pad1 -fill gray -outline gray
.canvas create rectangle 495 156 510 234 -tag pad2 -fill gray -outline gray
.canvas create oval 255 190 265 200 -tag ball -fill white -outline white

wm title . "tkpong"
wm protocol . WM_DELETE_WINDOW exit

bind . <Escape> exit
bind . <KeyPress-q> {set pad1ay -0.001}
bind . <KeyPress-a> {set pad1ay 0.001}
bind . <KeyRelease-q> {set pad1ay 0}
bind . <KeyRelease-a> {set pad1ay 0}
bind . <KeyPress-p> {set pad2ay -0.001}
bind . <KeyPress-l> {set pad2ay 0.001}
bind . <KeyRelease-p> {set pad2ay 0}
bind . <KeyRelease-l> {set pad2ay 0}

while 1 {
  set pad1y 195
  set pad1ay 0
  set pad1vy 0
  set pad2y 195
  set pad2ay 0
  set pad2vy 0
  set plyr1pts 0
  set plyr2pts 0

  set lblbtm "Press \"Return\" to start or \"Esc\" to exit."
  bind . <Return> {set sleep {}}
  tkwait variable sleep
  bind . <Return> {}

  while {10 > $plyr1pts && 10 > $plyr2pts} {
    set n 0
    set ballx 260
    set bally 195
    set ballvx [expr {rand () < 0.5 ? -0.2 : 0.2}]
    set ballvy [expr {rand () * 0.1 - 0.05}]

    set lblbtm "$plyr1pts - $plyr2pts"

    while {-5 < $ballx && 525 > $ballx} {
      set pad1vy [expr {0 < $pad1y && 390 > $pad1y \
          || 0 >= $pad1y && 0 <= $pad1vy && 0 < $pad1ay \
          || 390 <= $pad1y && 0 >= $pad1vy && 0 > $pad1ay \
          ? $pad1vy + $pad1ay : 0}]
      set pad1y [expr {$pad1y + $pad1vy}]

      set pad2vy [expr {0 < $pad2y && 390 > $pad2y \
          || 0 >= $pad2y && 0 <= $pad2vy && 0 < $pad2ay \
          || 390 <= $pad2y && 0 >= $pad2vy && 0 > $pad2ay \
          ? $pad2vy + $pad2ay : 0}]
      set pad2y [expr {$pad2y + $pad2vy}]

      set ballx [expr {$ballx + $ballvx}]
      set bally [expr {$bally + $ballvy}]

      set ballvy [expr {5 > $bally && 0 > $ballvy
        || 385 < $bally && 0 < $ballvy ? -$ballvy : $ballvy}]

      if {25 > $ballx && 20 < $ballx && 0 > $ballvx} {
        if {$pad1y - 45 < $bally && $pad1y + 45 > $bally} {
          set ballvx [expr {-$ballvx + 0.01}]
          set ballvy [expr {$ballvy + ($bally - $pad1y) / 45.0 * 0.15 + \
              $pad1vy * 0.4}]
        }
      } elseif {500 > $ballx && 495 < $ballx && 0 < $ballvx} {
        if {$pad2y - 45 < $bally && $pad2y + 45 > $bally} {
          set ballvx [expr {-$ballvx - 0.01}]
          set ballvy [expr {$ballvy + ($bally - $pad2y) / 45.0 * 0.15 + \
              $pad2vy * 0.4}]
        }
      }

      if {0 == $n % 20} {
        .canvas coords pad1 10 [expr {$pad1y - 39}] 25 [expr {$pad1y + 39}]
        .canvas coords pad2 495 [expr {$pad2y - 39}] 510 [expr {$pad2y + 39}]
        .canvas coords ball [expr {$ballx - 5}] [expr {$bally - 5}] \
            [expr {$ballx + 5}] [expr {$bally + 5}]

        after 20 {set sleep {}}
        tkwait variable sleep
      }

      incr n
    }

    set plyr1pts [expr {525 < $ballx ? $plyr1pts + 1 : $plyr1pts}]
    set plyr2pts [expr {-5 > $ballx ? $plyr2pts + 1 : $plyr2pts}]

  }

  tk_messageBox -parent . -title "Congratulations!" \
      -message "Player [expr {10 == $plyr1pts ? "one" : "two"}] wins."
}
----
!!!!!!
%| [Category Games] | [Category Application] | [Category Graphics] |%
!!!!!!