# MH: w zmiennej root umiesc toplevel, w ktorym ma dzialac gra...
#     (przed source mancala_vnc.tcl)
#     patametry c niektorych proc jest bezuzyteczny!
#

package re Tk

 # 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 {([$::root.c cget -width] / 8) - ($padx/2)}]
     set pit_height [expr {([$::root.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}]

     $::root.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)}]

 	    $::root.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]
 	    $::root.c bind stone-$tag <ButtonPress> \
 		[list tk-move $::root.c $side $tag]
 	}
     }
     set x [expr {($pit_width*7)+$padx2}]
     $::root.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 $::root.c $b($side,$pit) $side,$pit
 	}
     }
     tk-stone $::root.c $b(a,S) a,S
     tk-stone $::root.c $b(b,S) b,S
 }

 proc tk-stone {c stone_cnt side,pit} {
     global coords
     $::root.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 $::root.c $stone_cnt $x $y $width stone-${side,pit}
 	$::root.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} {
 	$::root.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 $::root.c $MAIN_BOARD
     if {[tk-game-over $::root.c $MAIN_BOARD]} {
 	return
     }
     if {$go_again} {
 	$::root.f.status configure -text "Your move (again)."
 	return
     }
     set go_again 1
     $::root.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 $::root.c $MAIN_BOARD]} {
 	    return
 	}
 	if {$go_again} {
 	    $::root.f.status configure -text "My move (again). Thinking..."
 	    update idletasks
 	    after 1000
 	}
     }
     $::root.f.status configure -text "Your move."
 }

 proc tk-game-over {c board} {
     if {[game-over? $board]} {
 	set board [sweep $board]
 	tk-draw-stones $::root.c $board
 	foreach {a b} [tally-score $board] break
 	set winner [expr {$a <= $b ? ($a == $b ? "nobody" : "you")
 			  : "the computer"}]
 	$::root.f.status configure -text  "Game over! $winner won!!"
 	return 1
     }
     return 0
 }

 proc tk-game {} {
     global MAIN_BOARD LEVEL

     canvas $::root.c -width 480 -height 380
     frame $::root.f
     button $::root.f.new -text "New Game" -command {
 	set MAIN_BOARD [make-board];
 	tk-make-board $::root.c $MAIN_BOARD;
 	tk-draw-stones $::root.c $MAIN_BOARD
     }

     label $::root.f.level_l -text " Play Level : "
     tk_optionMenu $::root.f.level LEVEL 0 1 2 3 4 5 6
     label $::root.f.status -text "Your move." -fg brown
     button $::root.f.quit -text "Quit" -command {
 	if {$::root==""} exit
	destroy $::root
     }

     pack $::root.f.new -side left
     pack $::root.f.level_l -side left
     pack $::root.f.level -side left
     pack $::root.f.status -side left -fill x -expand yes
     pack $::root.f.quit -side right
     pack $::root.c -fill both -expand yes
     pack $::root.f -fill x -expand yes
     $::root.f.new invoke

 }

 if {![info exists root]} {set root ""}
 set LEVEL 2
 tk-game