if 0 {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



----
[Category Games] | [Category Graphics] | [Category Application]