set about "Over and Out
R.Suchenwirth 2003
Powered by Tcl/Tk!
A peg jumps into a hole over a neighboring peg, to remove it.
Click first on peg, then on hole.
Try to remove all pegs but the last.
All moves can be undone in reverse order."
package require Tk
proc main {} {
frame .f
label .f.1 -text Score:
label .f.2 -bg white -textvar g(score) -width 6
button .f.n -text New -command {reset .c}
button .f.u -text Undo -command {undo .c}
button .f.a -text About -command {tk_messageBox -message $about}
button .f.x -text X -command exit
eval pack [winfo children .f] -side left
pack .f [canvas .c -bg orange]
foreach {rows cols} {
{1 2 3} {4 5 6}
{4 5 6} {1 2 3 4 5 6 7 8 9}
{7 8 9} {4 5 6}
} {
foreach row $rows {
foreach col $cols {
drawHole .c $row $col
}
}
}
reset .c
}
proc reset w {
putPeg $w all
pullPeg $w 5,5 ;# hole in center
array set ::g {peg {} score 0 stack {}}
$w bind peg <1> {markPeg %W}
$w bind hole <1> {markHole %W}
}
proc drawHole {w row col} {
set dia 20 ; set gap 6
set x0 [expr {($col-1)*($dia+$gap)+$gap}]
set x1 [expr {$x0+$dia}]
set y0 [expr {($row-1)*($dia+$gap)+$gap}]
set y1 [expr {$y0+$dia}]
oval $w $x0 $y0 $x1 $y1 -tag $row,$col -outline black
}
proc pullPeg {w tag} {
$w itemconfig $tag -fill orange3
$w dtag $tag peg
$w addtag hole withtag $tag
}
proc putPeg {w tag} {
$w itemconfig $tag -fill white
$w dtag $tag hole
$w addtag peg withtag $tag
}
proc markPeg w {
set id [$w find withtag current]
$w itemconfig $id -fill yellow
$w itemconfig $::g(peg) -fill white
set ::g(peg) [lindex [$w gettags $id] 0]
}if 0 {This evaluates the validity of a move (I'm proud to (ab)use hypot() to make this test very short), executes and stacks it for undo:} proc markHole w {
global g
if {$g(peg)==""} return
set id [$w find withtag current]
set rc [lindex [$w gettags $id] 0]
foreach {hr hc} [split $rc ,] break
foreach {pr pc} [split $g(peg) ,] break
if {hypot($hr-$pr,$hc-$pc)==2.} {
pullPeg $w $g(peg)
set over [expr {($hr+$pr)/2}],[expr {($hc+$pc)/2}]
pullPeg $w $over
putPeg $w $rc
lappend g(stack) $g(peg) $over $rc
set g(peg) {}
incr g(score)
} else { #indicate invalid move
$w itemconfig $g(peg) -fill red
after 500 $w itemconfig $g(peg) -fill white
}
}
proc undo w {
global g
if {[llength $g(stack)]<3} return
foreach i {pull put put} {
${i}Peg $w [pop g(stack)]
}
incr g(score) -1
}if 0 {A generic stack routine - made very easy with the K combinator. Pushing is simply done with lappend.} proc pop varName {
upvar 1 $varName v
K [lindex $v end] [set v [lrange $v 0 end-1]]
}
proc K {a b} {set a}if 0 {This oval workaround using regular polygons is only needed for the Keuchel CE port, which can't draw circles.} proc rp {x0 y0 x1 y1 {n 0} } {
set xm [expr {($x0+$x1)/2.}]
set ym [expr {($y0+$y1)/2.}]
set rx [expr {$xm-$x0}]
set ry [expr {$ym-$y0}]
if {$n==0} {
set n [expr {round(($rx+$ry))}]
}
set step [expr {atan(1)*8/$n}]
set res ""
set th [expr {atan(1)*6}]
for {set i 0} {$i<$n} {incr i} {
lappend res \
[expr {$xm+$rx*cos($th)}] \
[expr {$ym+$ry*sin($th)}]
set th [expr {$th+$step}]
}
set res
}
proc oval {w x0 y0 x1 y1 args} {
eval $w create poly [rp $x0 $y0 $x1 $y1] $args
}#--------- let's go!main wm geometry . 240x268+0+0if 0 {MG May 27th 2004 - Very nice game. :) There seems to be a couple of small bugs in it, though; first, if you select a peg, it turns yellow. If you then try to perform a 'bad' move, the select peg turns red to show that; afterwards, it should turn yellow again, as the peg is still selected, but instead it turns white (the same as an unselected peg).Also, you seem to be able to jump a peg over an empty hole, whereas you should (I believe) only be able to jump a single peg. In fact, it seems you can jump multiple empty holes, as long as there aren't any pegs between where you start and the destination. }
Category Games | Category Graphics | Category Application
