if 0 { Derived from [L1 ]. I changed seven lines to create the triangle version of this puzzle. 99% of code is due to Richard Suchenwirth }
set about "Over and Out
R.Suchenwirth 2003
mods by RAI 2016
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} {
{3} {3}
{4} {3 4}
{5} {3 4 5}
{6} {3 4 5 6}
{7} {3 4 5 6 7}
} {
foreach row $rows {
foreach col $cols {
drawHole .c $row $col
}
}
}
reset .c
}
proc reset w {
putPeg $w all
pullPeg $w 3,3 ;# 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 x0 [expr {$x0 + ((7-$row)*($dia+$gap))/2}]
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
puts " ::g(peg) [lindex [$w gettags $id] 0] " ; update
set ::g(peg) [lindex [$w gettags $id] 0]
}if 0 {This evaluates the validity of a move. Richard used hypot is capture up-down, left-right moves. I've added the other direction.
Also added check for middle position being a peg!}
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
set isValid 0
if {hypot($hr-$pr,$hc-$pc)== 2.} {set isValid 1}
if {$hr-$pr== 2 && $hc-$pc== 2} {set isValid 1}
if {$hr-$pr== -2 && $hc-$pc== -2} {set isValid 1}
set midr [expr ($hr+$pr)/2]
set midc [expr ($hc+$pc)/2]
set cid [.c find withtag $midr,$midc]
if {[.c itemcget $cid -fill] != "white"} {set isValid 0}
if {$isValid==1} {
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+0