'''I was going to do a sophisticated implementation in Lisp, but Tcl let me hack this together in two nights...'''

Mancala (or Mankala) is an ancient african board game with many variations. Here is an implementation based on an Egyptian version. It doesn't have a sophisticated computer play algorithm (''proc gen-best-move'' is my excuse for recursive look ahead intelligence), but is yet another example of [Street Programming] in Tcl. -- [Todd Coram]

 set HELPMSG {
 Mancala - an ancient african board game. Version 0.99a
     By Todd Coram (tcoram@pobox.com)
 
 I couldn't find anyone to play Mancala with me, so I thought that I would
 teach a computer how to. Sad, isn't it?
 
  Mancala is played on a board with 12 pits (cups, bowls, whatever) and
  2 stores (which hold captured stones). There are 2 players and each
  is presented with 6 pits and 1 store (positioned to the right of the
  pits). In each pit there are initially 3 stones.
 
 Rules (This implementation follows the Egyptian rules):
 
  The goal is to get as many of these stones into your store as possible.
  The player with the most stones at the end of the game wins. The game
  is over when one player's 6 pits are empty.
 
  A player moves by taking all of the stones from a pit and dropping them
  (one by one) into the pits to the right. If the player runs out of pits,
  a stone is dropped into the store. If there are still more stones, the player
  continues distributing the stones in a counter-clockwise fashion into the
  opponents pits (or store).
 
  During a play, if the last stone you drop is placed into an empty pit
  on your side, you capture your opponents stones in the pit opposite your
  empty pit. If you do capture some opponent stones, you take them and your
  last stone and place them all into your store. If your last stone is dropped
  in your store, you get to move again.
 
  At the end of the game, just to make things more interesting, the player
  with stones remaining in their pits may take all of those stones and add them 
  to their own store! You just can't try to clear out your side of the board. 
  You may lose by doing so. 
 
 How to play this simulation:
 
  Choose a Level (the higher the number, the longer it takes the computer to
  make a move) and press "New Game". You move first. You make a move by 
  clicking on any of the stones in the bottom row. 
 }
 
 
 # Create a board as an array with sides (players) 'a' and 'b'. Each pit
 # is indexed as 'side,pit' (e.g a,1 a,2 a,3 a,4, a,5 a,6). The stores are
 # a,S and b,S. Return the array flattened into a list.
 #
 proc make-board {} {
     foreach side {a b} {
 	foreach pit {1 2 3 4 5 6} {
 	    set board($side,$pit) 3
 	}
 	set board($side,S) 0
     }
     return [array get board]
 }
 
 # The basic mechanism behind making a legal move.  
 # Given board as a list (flattened array) and a target pit to move
 # (e.g. a,3) and an optional update command, make a move.
 # -1 is returned if the player tries and move an empty pit.
 # Otherwise a modified board is returned as a flattened array along with
 # a flag indicating whether or not the player can play again.
 #
 proc move {board player,pit {update_stones {}}} {
     set go_again 0
     array set b $board
     foreach {player pit} [split ${player,pit} \,] break
     set side $player
     set stones [set b($side,$pit)]
     if {$stones == 0} {
 	error "no stones! $player,$pit"
     }
     set orig_pit $pit
     set orig_side $side
     set opp [opponent $side]
     incr pit
     while {$stones > 0} {
 	incr stones -1
 	incr b($orig_side,$orig_pit) -1
 	if {$pit > 6} {
 	    incr b($side,S)
 	    set side $opp
 	    set pit 1
 	    set go_again 1
 	} else {
 	    set go_again 0
 	    incr b($side,$pit)
 	    # See if we captured any opponent stones
 	    #
 	    if {$stones==0 && $player==$side && [set b($side,$pit)] == 1} {
 		if {$update_stones != {}} {
 		    eval $update_stones [list [array get b]]
 		    update idletasks
 		    after 500
 		}
 		array set b \
 		    [capture_opposite [array get b] $side $opp $pit]
 	    }
 	    incr pit
 	}
 	if {$update_stones != {}} {
 	    eval $update_stones [list [array get b]]
 	    update idletasks
 	    after 500
 	}
     }
     return [list $go_again [array get b]]
 }
 
 proc capture_opposite {board side opp my_pit} {
     array set b $board
     set their_pit [expr {abs($my_pit-((6)+1))}]
     if {[set b($opp,$their_pit)] != 0} {
 	incr b($side,S) \
 	    [expr {[set b($opp,$their_pit)]+[set b($side,$my_pit)]}]
 	set b($side,$my_pit) 0
 	set b($opp,$their_pit) 0
     }
     return [array get b]
 }
 
 # The computer's algorithm for making a move. If you have a better algorithm
 # this is where you would plug it in.
 # Given a board, the player you are generating the move for, an initial side
 # (usually the player) and a a nesting level (the number of moves to 
 # look ahead), return a list consisting of the 'pit' and 'profit' chosen
 # as the best move.
 #
 proc gen-best-move {board player side {nest 2}} {
     set best {-1 -100};			# {pit profit}
     array set b $board
     foreach pit {1 2 3 4 5 6} {
 	update;				# give up CPU once in a while
 	if {[set b($side,$pit)] != 0} {
 	    if {[lindex $best 0] == -1} {
 		set best [list $pit -100];# worst case: we have a valid pit
 	    }
 	    foreach {go_again mod_board} [move $board $side,$pit] break
 	    if {$nest == 0} {
 		# We have exhausted all moves starting at this pit...
 		set profit [profit $mod_board $player]
 		if {[lindex $best 1] < $profit} {
 		    set best [list $pit $profit];# save the best profit of all
 		}
 	    }
 	    if {$nest > 0} {
 		# try next move as opponent (or self if you can go again).
 		set opp [expr {$go_again ? $side : [opponent $side]}]
 		foreach {c profit} \
 		    [gen-best-move $mod_board $player $opp [expr {$nest-1}]] \
 		    break
 		if {[lindex $best 1] < $profit} {
 		    set best [list $pit $profit];# best profit for pit
 		}
 	    }
 	}
     }
     return $best
 }
 
 # Every move has a 'profit'. A profit is the number of player's stones in their
 # store minus the number of opponent's stones in their store.
 #
 proc profit {board player} {
     if {[game-over? $board]} {
 	set board [sweep $board]
     }
     foreach {a b}  [tally-score $board] break
     return [expr {$player == "a" ? ($a - $b) : ($b - $a)}]
 }
 
 proc make-best-move {board player {nest 2} {update {}}} {
     foreach {pit profit} [gen-best-move $board $player $player $nest] break
     puts "best move pit=$pit, profit=$profit"
     if {$pit <= 0} {
 	return $board
     } else {
 	return [move $board $player,$pit $update]
     }
 }
 
 proc game-over? {board} {
     foreach {side_a side_b} [sum-sides $board] {
 	return [expr {$side_a == 0 || $side_b == 0}]
     }
 }
 
 proc tally-score {board} {
     array set b $board
     return [list $b(a,S) $b(b,S)]
 }
 
 proc sum-sides {board} {
     array set brd $board
     foreach side {a b} {
 	set $side 0
 	foreach pit {1 2 3 4 5 6} {
 	    incr $side [set brd($side,$pit)]
 	}
     }
     return [list $a $b]
 }
 
 # Sweep remaining stones into their owner's store.
 #
 proc sweep {board} {
     array set brd $board
     foreach side {a b} {
 	foreach pit {1 2 3 4 5 6} {
 	    incr brd($side,S) [set brd($side,$pit)]
 	    set brd($side,$pit) 0
 	}
     }
     return [array get brd]
 }
 
 
 # Who is my opponent?
 #
 proc opponent {player} {
     return [expr {$player == "a" ? "b" : "a"}]
 }
 
 ################################################################
 # Start of the Tk GUI stuff..
 #
 package require Tk
 proc tk-make-board {c board} {
     global coords
     set padx 4
     set padx2 [expr {$padx * 2}]
     set pady 4
     set pit_width [expr {([$c cget -width] / 8) - ($padx/2)}]
     set pit_height [expr {([$c cget -height] / 2) - ($pady/2)}]
     set coords(width) $pit_width
     set coords(height) $pit_height
 
     set S_offset_y [expr {$pady+($pit_height/4)}]
     set coords(height,S) [expr {$pit_height*2}]
 
     $c create rectangle $padx2 $S_offset_y \
 	$pit_width [expr {$coords(height,S)-$S_offset_y}] \
 	-fill white \
 	-tags a,S
     set coords(a,S) [list $padx2 $S_offset_y]
 
     foreach {row side direction}  {0 a reverse 1 b forward} {
 	foreach pit {1 2 3 4 5 6} {
 	    if {$direction == "reverse"} {
 		set tag $side,[expr {abs($pit-7)}]
 	    } else {
 		set tag $side,$pit
 	    }
 	    set x [expr {($pit_width*$pit)+$padx2}] 
 	    set y [expr {$pady+($row*$pit_height)}] 
 
 	    $c create rectangle $x $y \
 		[expr {$x + $pit_width-$padx2}] \
 		[expr {$y + $pit_height-$pady}] \
 		-fill white \
 		-tags [list $tag pit]
 	    set coords($tag) [list $x $y]
 	    $c bind stone-$tag <ButtonPress> \
 		[list tk-move $c $side $tag]
 	}
     }
     set x [expr {($pit_width*7)+$padx2}] 
     $c create rectangle $x  $S_offset_y \
 	[expr {($pit_width*8)}] [expr {$coords(height,S)-$S_offset_y}] \
 	-fill white \
 	-tags b,S
     set coords(b,S) [list  $x $S_offset_y]
 }
 
 proc tk-draw-stones {c board} {
     array set b $board
     foreach {row side} {0 a 1 b} {
 	foreach pit {1 2 3 4 5 6} {
 	    tk-stone .c $b($side,$pit) $side,$pit
 	}
     }
     tk-stone .c $b(a,S) a,S
     tk-stone .c $b(b,S) b,S
 }
 
 proc tk-stone {c stone_cnt side,pit} {
     global coords
     .c delete stone-${side,pit}
     foreach {x y} [set coords(${side,pit})] {
 	incr x [expr {$coords(width)/2}]
 	incr y [expr {$coords(height)-12}]
 	set width [expr {$coords(width)-16}]
 	tk-stack-stones $c $stone_cnt $x $y $width stone-${side,pit}
 	.c create text $x $y -text $stone_cnt \
 	    -tags  stone-${side,pit}
     }
 }
 
 proc tk-stack-stones {c cnt x y width tag} {
     for {set i 1} {$i <= $cnt} {incr i} {
 	.c create oval [expr {$x - ($width/2)}] \
 	    [expr {$y - ($i*10)}]  \
 	    [expr {$x + ($width/2)}] \
 	    [expr {$y - ($i*10)-20}] \
 	    -fill brown -tags $tag
     }
 }
 
 proc tk-move {c player side,pit} {
     global MAIN_BOARD LEVEL
     if {[catch {
 	# catch illegal moves. (empty pits)
 	foreach {go_again MAIN_BOARD} \
 	    [move $MAIN_BOARD ${side,pit} [list tk-draw-stones $c]] \
 	    break
     } err] != 0} {
 	return
     }
     tk-draw-stones $c $MAIN_BOARD
     if {[tk-game-over $c $MAIN_BOARD]} {
 	return
     }
     if {$go_again} { 
 	.f.status configure -text "Your move (again)." 
 	return
     }
     set go_again 1
     .f.status configure -text "My move. Thinking..."
     while {$go_again} {
 	update idletasks
 	foreach {go_again MAIN_BOARD} \
 	    [make-best-move $MAIN_BOARD [opponent $player] $LEVEL \
 		 [list tk-draw-stones $c]] \
 	    break
 	update idletasks
 	if {[tk-game-over $c $MAIN_BOARD]} {
 	    return
 	}
 	if {$go_again} { 
 	    .f.status configure -text "My move (again). Thinking..." 
 	    update idletasks
 	    after 1000
 	}
     }
     .f.status configure -text "Your move."
 }
 
 proc tk-game-over {c board} {
     if {[game-over? $board]} {
 	set board [sweep $board]
 	tk-draw-stones $c $board
 	foreach {a b} [tally-score $board] break
 	set winner [expr {$a <= $b ? ($a == $b ? "nobody" : "you") 
 			  : "the computer"}]
 	set res [tk_messageBox -message "Game over! $winner won"]
 	return 1
     }
     return 0
 }
 
 proc tk-game {} {
     global MAIN_BOARD LEVEL
 
     canvas .c -width 480 -height 480
     frame .f
     button .f.new -text "New Game" -command {
 	set MAIN_BOARD [make-board];
 	tk-make-board .c $MAIN_BOARD;
 	tk-draw-stones .c $MAIN_BOARD
     }
 
     label .f.level_l -text " Play Level : "
     tk_optionMenu .f.level LEVEL 0 1 2 3 4 5 6
     label .f.status -text "Your move." -fg brown
     button .f.help -text "Help" -command { print-help .f.help}
     button .f.quit -text "Quit" -command {
 	exit
     }
 
     pack .f.new -side left
     pack .f.level_l -side left
     pack .f.level -side left
     pack .f.status -side left -fill x -expand yes
     pack .f.quit -side right
     pack .f.help -side right
     pack .c -fill both -expand yes
     pack .f -fill x -expand yes
     .f.new invoke
 
 }
 
 proc print-help {w} {
     global HELPMSG
     if {[winfo exists .h]} {
 	wm state .h normal
 	raise .h .f
 	return
     }
     toplevel .h
     wm title .h "Mancala Help"
     frame .h.f
 
     frame .h.f.tb
     text .h.f.tb.t -width 80 -height 25 -bg white -wrap word \
 	-yscrollcommand {.h.f.tb.s set}
     .h.f.tb.t insert end $HELPMSG
     .h.f.tb.t configure -state disabled
     scrollbar .h.f.tb.s -orient vertical -command {.h.f.tb.t yview}
     pack .h.f.tb.s -fill y -side right
     pack .h.f.tb.t -fill both -expand yes
 
     button .h.f.b -text "Ok" -command {destroy .h}
     focus .h.f.b
     bind .h.f.b <Return> [list .h.f.b invoke]
     pack .h.f.tb -expand yes -fill both
     pack .h.f.b -side bottom -anchor c
     pack .h.f -expand yes -fill both
 }
 
 set LEVEL 2
 tk-game