Version 0 of Over and Out

if 0 {Richard Suchenwirth 2003-07-06 - Yet another little game runnable on PocketPC and elsewhere, for a single player. In Germany it's called "Solitär", but to avoid confusion with the popular card game, I made up the name "Over and Out" which tells the only rule: jump over a peg (into a hole) to take it out. The aim is to take out all but the last peg, but I haven't reached that yet... Maximum score is 43, my best is 40 so far.

}

 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+0