Bonjour,
Le fait de placer un shell dans /usr/local/bin ne suffit pas toujours �
ce qu'il puisse �tre lanc� d'un clic de souris sur Kfm ou Disk
Navigator.
Je n'ai pas trouv� de solution avec le programme ci-joint (que je lance
correctement en console par ./tkataxx.tcl2).
Je vous le laisse ci-joint pour que vous ayez toutes les infos
permettant de comprendre (� signaler que je n'ai pas eu ce probl�me avec
un autre programme en Tcl Tk).
Cordialement.
--
Alain Beyrand
#!/bin/bash
# the next line restarts using wish \
exec wish "$0" "$@"
#################################################################
#
# TkAtaxx
#
# by Keith P. Vetter ([EMAIL PROTECTED])
# Copyright (c) 1995 Keith P. Vetter
#
# TkAtaxx is tcl/tk implementation of the Ataxx arcade game. It is
# written solely in tcl/tk. The computer uses a multi-level game tree
# search routine with alpha-beta pruning.
#
# Revision history:
# Keith Vetter 1/6/95 - Initial revision
# Keith Vetter 5/16/95 - Added help and cleaned up code
# Keith Vetter 8/22/95 - Ported to tk 4.0
# Keith Vetter 1/25/96 - Minor cleanup, found but didn't fix resize bug
# - fixed bug when player has no moves deep in the search tree.
#
if {[info tclversion] < 7.0 || $tk_version < 3.3} {
puts stdout ""
puts stdout "You need TCL version 7.0 and TK version 3.3 for this program."
puts stdout ""
exit
}
puts ""
puts "TkAtaxx 1.05 by Keith Vetter"
puts ""
# To Do
# go/stop button when both are computers
# multi-level hint
# remove recursion in do_move/robot
# check turn in mousing, change cursor
#
##+#########################################################################
##
## Init
##
## Sets up some global variables
##
proc init {{cs 50}} {
global state newb
set state(cs) $cs ;# Size of a cell
set state(bs) [expr round($cs * .9)] ;# Size of a blob
set state(brd) -1 ;# Last board used
set state(c,1) Red ;# Colors for each player
set state(c,2) Green
set state(1) 0 ;# Human
set state(2) 1 ;# Computer
set state(skill) Greedy ;# Skill level
set state(Verbose) 1 ;# Verbosity on
set state(conf) 0 ;# Configuring size flag
;#
;# Various boards to play on
;#
set newb(0) {{2 0} {4 0} {2 1} {4 1} {0 2} {6 2} {0 3} \
{3 3} {6 3} {0 4} {6 4} {2 5} {4 5} {2 6} {4 6}}
set newb(1) {{3 0} {3 1} {3 2} {0 3} {1 3} {2 3} \
{4 3} {5 3} {6 3} {3 4} {3 5} {3 6}}
set newb(2) {{3 0} {1 2} {2 2} {4 2} {5 2} {0 3} {1 3} \
{5 3} {6 3} {1 4} {2 4} {4 4} {5 4} {3 6}}
set newb(3) {{1 0} {5 0} {0 1} {6 1} {3 3} {0 5} {6 5} {1 6} {5 6}}
set newb(4) {{2 0} {4 0} {2 1} {4 1} {0 3} {6 3} {2 5} {4 5} {2 6} {4 6}}
set newb(5) {{3 0} {3 1} {0 3} {1 3} {5 3} {6 3} {3 5} {3 6}}
set newb(6) {{3 1} {2 2} {4 2} {1 3} {5 3} {2 4} {4 4} {3 5}}
set newb(7) {{2 0} {4 0} {0 2} {6 2} {0 4} {6 4} {2 6} {4 6}}
set newb(8) {{3 0} {2 1} {4 1} {1 2} {5 2} {0 3} {6 3} {1 4} \
{5 4} {2 5} {4 5} {3 6}}
set newb(9) {{2 1} {4 1} {1 2} {5 2} {1 4} {5 4} {2 5} {4 5}}
set newb(10) {{2 0} {4 0} {2 2} {4 2} {1 3} {5 3} {2 4} {4 4} {2 6} {4 6}}
set newb(11) {{3 1} {3 2} {1 3} {2 3} {3 3} {4 3} {5 3} {3 4} {3 5}}
set newb(12) {{1 1} {2 1} {3 1} {4 1} {5 1} {1 2} \
{5 2} {1 3} {5 3} {1 4} {5 4} {1 5} {2 5} {3 5} {4 5} {5 5}}
set newb(13) {{2 1} {3 1} {4 1} {1 2} {5 2} {1 3} \
{5 3} {1 4} {5 4} {2 5} {3 5} {4 5}}
set newb(14) {{2 1} {4 1} {1 2} {2 2} {4 2} {5 2} \
{1 4} {2 4} {4 4} {5 4} {2 5} {4 5}}
set newb(15) {{1 1} {5 5} {1 5} {5 1}}
set newb(16) {{1 1} {2 1} {4 1} {5 1} {1 2} {5 2} \
{1 4} {5 4} {1 5} {2 5} {4 5} {5 5}}
set newb(17) {{3 2} {2 3} {3 3} {4 3} {3 4}}
set newb(18) {{3 2} {2 3} {4 3} {3 4}}
set newb(19) {{3 1} {3 2} {1 3} {2 3} {4 3} {5 3} {3 4} {3 5}}
set newb(20) {{2 0} {3 0} {4 0} {3 1} {0 2} {6 2} \
{0 3} {1 3} {5 3} {6 3} {0 4} {6 4} {3 5} {2 6} {3 6} {4 6}}
set newb(21) {{2 0} {4 0} {3 1} {0 2} {6 2} {1 3} \
{5 3} {0 4} {6 4} {3 5} {2 6} {4 6}}
set newb(22) {{3 1} {1 3} {3 3} {5 3} {3 5}}
set newb(23) {{1 1} {3 1} {5 1} {1 3} {3 3} {5 3} {1 5} {3 5} {5 5}}
set newb(24) {}
set newb(25) {{2 2} {4 2} {3 3} {2 4} {4 4}}
set newb(26) {{1 1} {5 1} {2 2} {4 2} {3 3} {2 4} {4 4} {1 5} {5 5}}
set newb(27) {{2 0} {3 0} {4 0} {2 1} {4 1} {0 3} \
{6 3} {2 5} {4 5} {2 6} {3 6} {4 6}}
set newb(28) {{1 0} {3 0} {5 0} {0 1} {2 1} {4 1} {6 1} \
{1 2} {3 2} {5 2} {0 3} {2 3} {4 3} {6 3} {1 4} \
{3 4} {5 4} {0 5} {2 5} {4 5} {6 5} {1 6} {3 6} {5 6}}
set newb(29) {{1 1} {5 1} {2 2} {4 2} {2 4} {4 4} {1 5} {5 5}}
set newb(30) {{3 0} {2 1} {4 1} {0 3} {6 3} {2 5} {4 5} {3 6}}
set newb(31) {{3 0} {0 3} {6 3} {3 6}}
set newb(32) {{3 1} {1 3} {5 3} {3 5}}
set newb(33) {{2 0} {3 0} {4 0} {0 2} {1 2} {3 2} {5 2} \
{6 2} {0 3} {6 3} {0 4} {1 4} {3 4} {5 4} {6 4} {2 6} {3 6} {4 6}}
set newb(34) {{2 1} {4 1} {0 2} {1 2} {3 2} {5 2} {6 2} \
{3 3} {0 4} {1 4} {3 4} {5 4} {6 4} {2 5} {4 5}}
set state(b) 35 ;# Number of boards
}
##+#########################################################################
##
## Display
##
## Sets up the display
##
proc display {} {
global state
wm title . "TkAtaxx"
frame .m ;# Frame for the menus
frame .ftop -bd 2 -relief ridge
frame .fbot
pack .m .ftop .fbot -side top -fill both
draw_menus ;# Draw the menus
draw_board ;# Draw the actual board
label .msg -relief ridge -textvariable state(msg) -anchor w
pack .msg -side top -fill x -in .fbot
frame .fsc -bd 2 -relief ridge
frame .fred
frame .fgreen
pack .fsc -side left -ipadx 5 -expand yes -fill y -in .fbot
pack .fred .fgreen -side top -in .fsc
canvas .c_p1 -width 16 -height 16 ;# Status area
.c_p1 create oval 2 2 15 15 -fill $state(c,1)
canvas .c_p2 -width 16 -height 16
.c_p2 create oval 2 2 15 15 -fill $state(c,2)
label .p1 -text "Score: "
label .p2 -text "Score: "
label .p1_sc -textvariable state(sc,1) -width 2
label .p2_sc -textvariable state(sc,2) -width 2
pack .c_p1 .p1 .p1_sc -side left -in .fred
pack .c_p2 .p2 .p2_sc -side left -in .fgreen
scale .level -o h -from 0 -to 3 -relief ridge -command level -showv 0
.level set 1
pack .level -side right -expand yes -in .fbot -fill y
bind .level <3> xx
bind .level <2> {hint -1 ; break}
bind .level <Shift-2> {hint -2 ; break}
}
##+#########################################################################
##
## Level
##
## Handles changes in the scale for the depth of search
##
proc level {v} {
global state
set l(0) Random ; set l(1) Greedy
set l(2) Brainy ; set l(3) Genius
.level config -label "Skill: $l($v)" ;# Change the label on scale
set state(skill) $l($v) ;# Update menu
}
##+#########################################################################
##
## Draw_board
##
## Draws the playing field
##
proc draw_board {{cs -1}} {
global state
if {$cs != -1} {
set state(cs) $cs ;# Resize board
set state(bs) [expr round($cs * .9)] ;# Size of a blob
}
set wi [expr $state(cs) * 7] ;# Total width
catch {destroy .c} ;# Delete old canvas
canvas .c -width $wi -height $wi
pack .c -in .ftop
set state(Grid) 1
grid
bind .c <1> {mouse_down %x %y}
return
}
##+#########################################################################
##
## Redraw_board
##
## Redraws all the pips and obstacles on the board
##
proc redraw_board {{brd ""}} {
global state bb
if {$brd != ""} {set bb $brd} ;# New board to use
.c delete blob ;# Delete any existing stuff
set state(sc,0) 0 ;# Reset the scores
set state(sc,1) 0 ;# 0 is blanks, 1 is player 1
set state(sc,2) 0 ;# 2 is player 2
set state(sc,3) 0 ;# 3 is barriers
for {set r 0} {$r < 7} {incr r} { ;# Each row and column
for {set c 0} {$c < 7} {incr c} {
set cell [lindex $bb [index $r $c]] ;# What's in the cell
incr state(sc,$cell) ;# Update score info
if {$cell == 3} { ;# Obstacle
make_obstacle $r $c
} elseif {$cell > 0} { ;# Red or green pip
make_blob $cell $r $c
}
}
}
set bb [lreplace $bb 121 end $state(sc,0) $state(sc,1) $state(sc,2) \
$state(sc,3)]
}
##+#########################################################################
##
## Resize
##
## Called when the size or position of the window changes.
##
proc resize {w h} {
global state
puts "BROKEN" return
if $state(conf) return ;# Already resizing
set state(conf) 1 ;# Set busy flag
set hh [expr [winfo reqheight .m] + [winfo reqheight .fbot]]
set sz [expr $h - $hh] ;# Assume this is minimum
if {$w < $sz} {set sz $w}
set cs [expr $sz / 7] ;# New cell size
set sz [expr 5 + 7 * $cs] ;# New total size
if {$cs != $state(cs)} {
resize_board $cs ;# Resize the board
wm geom . ${sz}x[expr $sz + $hh] ;# Resize the window
}
set state(conf) 0 ;# Clear busy flag
}
##+#########################################################################
##
## Resize_board
##
## Resizes the board with cell size CS
##
proc resize_board {cs} {
global state
draw_board $cs ;# The basic board
redraw_board ;# Add all the pips
}
##+#########################################################################
##
## Grid
##
## Toggles the display of a grid on the board
##
proc grid {} {
global state
if {! $state(Grid)} { ;# Grid already exists
.c delete grid
return
}
set wi [expr $state(cs) * 7] ;# Total width
.c create rect 0 0 $wi $wi -width 5 -fill {} -tag grid
for {set i 1} {$i < 7} {incr i} { ;# Cell dividers
set xy [expr $i * $state(cs)]
.c create line 0 $xy $wi $xy -tag grid
.c create line $xy $wi $xy 0 -tag grid
}
}
##+#########################################################################
##
## C_bbox
##
## Returns the bounding box for a given row, col cell
##
proc c_bbox {r c} {
global state
set bs2 [expr $state(bs) / 2.0] ;# Half blob size
set x [expr round(($c+.5) * $state(cs) - $bs2)];# Center less half blob
set y [expr round(($r+.5) * $state(cs) - $bs2)]
set x2 [expr $x + $state(bs)]
set y2 [expr $y + $state(bs)]
return [list $x $y $x2 $y2]
}
##+#########################################################################
##
## Make_blob
##
## Creates a new blob at location Row Col for WHO
##
proc make_blob {who r {c -1}} {
global state bb
if {$c == -1} { ;# R,C is in index format
set c [expr ($r % 11) - 2]
set r [expr ($r / 11) - 2]
}
set col $state(c,$who) ;# Color to use
set xy [c_bbox $r $c]
eval .c create oval $xy -fill ${col}3 -tag \"blob blob${r}${c}\"
eval .c create arc $xy -start 45 -extent 180 -fill ${col}1 -outline \"\" \
-tag \"blob blob${r}${c}\"
eval .c create oval [eval shrink $xy 5] -fill ${col}2 -outline \"\" \
-tag \"blob blob${r}${c}\"
set p [index $r $c] ;# Update board info
set bb [lreplace $bb $p $p $who] ;# Put new piece there
}
##+#########################################################################
##
## Shrink
##
## Shrinks rectangle specified by x,y x2,y2
##
proc shrink {x y x2 y2 n} {
set x [expr $x + $n]
set y [expr $y + $n]
set x2 [expr $x2 - $n]
set y2 [expr $y2 - $n]
return [list $x $y $x2 $y2]
}
##+#########################################################################
##
## Grow_blob
##
## Grows a blob at R,C
##
proc grow_blob {who r c} {
global state
set xy [c_bbox $r $c]
for {set i [expr $state(bs) / 2]} {$i >= 0} {incr i -1} {
set bbox [eval shrink $xy $i] ;# Bounding box of oval
eval .c create oval $bbox -tag grow -fill $state(c,$who)
update idletasks
}
make_blob $who $r $c
.c delete grow
}
##+#########################################################################
##
## Highlight
##
## Highlights cell R, C
##
proc highlight {r c} {
if {$r == -1} { ;# -1 means delete highlight
.c delete high
return
}
eval .c create rect [c_bbox $r $c] -fill \"\" -tag \"blob high\" -width 5
.c lower high
}
##+#########################################################################
##
## Delete_blob
##
## Deletes the blob from cell Row Col
##
proc delete_blob {r {c -1}} {
global bb
if {$c == -1} { ;# R,C is in index format
set c [expr ($r % 11) - 2]
set r [expr ($r / 11) - 2]
}
.c delete blob${r}${c}
set p [index $r $c] ;# Update board info
set bb [lreplace $bb $p $p 0] ;# Cell now empty
}
##+#########################################################################
##
## Make_obstacle
##
## Creates an obstacle in cell Row Col
##
proc make_obstacle {r c} {
global bb state
set xy [c_bbox $r $c] ;# Where to put it
set x [lindex $xy 0]
set y [lindex $xy 1]
set x2 [lindex $xy 2]
set y2 [lindex $xy 3]
.c create poly $x $y $x $y2 $x2 $y -fill white -tag blob
.c create poly $x2 $y2 $x $y2 $x2 $y -fill gray45 -tag blob
eval .c create rect [eval shrink $xy 2] -fill gray -outline \"\" -tag blob
set xy [eval shrink $xy [expr $state(cs) / 5]]
eval .c create rect $xy -fill $state(c,1) -out \"\" -tag \"blob center\"
}
##+#########################################################################
##
## Clean_board
##
## Deletes everything off the board
##
proc clean_board {} {
global bb
.c delete blob ;# Delete the blobs
set bb "4 4 4 4 4 4 4 4 4 4 4" ;# BB is the board info
set bb "$bb 4 4 4 4 4 4 4 4 4 4 4" ;# ...w/ 2 row/col of sentinels
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4" ;# Actual board part
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 0 0 0 0 0 0 0 4 4"
set bb "$bb 4 4 4 4 4 4 4 4 4 4 4" ;# Bottom row sentinels
set bb "$bb 4 4 4 4 4 4 4 4 4 4 4"
set bb "$bb 45 2 2"
}
##+#########################################################################
##
## Fill_board
##
## Fills all blanks board positions with a blob. Called when the game
## is over.
##
proc fill_board {who} {
global state bb
for {set r 0} {$r < 7} {incr r} { ;# Search each row, column
for {set c 0} {$c < 7} {incr c} {
set p [index $r $c]
if {[lindex $bb $p] == 0} { ;# Is cell empty?
make_blob $who $r $c ;# Yep, create a blob here
incr state(sc,$who) ;# Increase score
update idletasks ;# More visually plesing
}
}
}
}
##+#########################################################################
##
## New_board
##
## Creates a new board with obstacles of type N
##
proc new_board {{n -1}} {
global newb state bb mm ;# The boards
if {$n == -1} { ;# Get random board to use
set n [rand $state(b)] ;# Pick on at random
if {$n == $state(brd)} { ;# Same as last time
set n [rand $state(b)] ;# Pick another
}
}
set state(brd) $n ;# Remember for next time
clean_board ;# Get rid of old stuff
catch {unset mm} ;# Undo info
set xy [index 0 0] ; set bb [lreplace $bb $xy $xy 1]
set xy [index 6 6] ; set bb [lreplace $bb $xy $xy 1]
set xy [index 6 0] ; set bb [lreplace $bb $xy $xy 2]
set xy [index 0 6] ; set bb [lreplace $bb $xy $xy 2]
foreach p $newb($n) { ;# Add the obstacles
set xy [eval index $p]
set bb [lreplace $bb $xy $xy 3]
}
redraw_board
set state(init) $bb ;# Save initial position
set state(turn) 1 ;# Who's turn
set state(state) 0 ;# Where in the turn
set state(n) 0 ;# Which move
set state(msg) "" ;# Erase message area
set state(tc) 0 ;# VEB stats
set state(c) 0 ;# VEB stats
return
}
##+#########################################################################
##
## Rand [base]
##
## per Knuth 3.6:
## 65277 mod 8 = 5 (since 65536 is a power of 2)
## c/m = .5-(1/6)\sqrt{3}
## c = 0.21132*m = 13849, and should be odd.
##
## If BASE is specified, then we return < BASE
##
proc rand {{base ""}} {
global rseed
if {! [info exist rseed]} { ;# Are we seeded?
set x [lindex [time {file atime [exec tty]}] 0]
set rseed [expr ($x + [file atime [exec tty]]) % 65536]
}
set rseed [expr (65277*$rseed+13849)%65536];# New value
set rseed [expr ($rseed+65536)%65536]
set value $rseed
if {$base != ""} { ;# Return in a range
set value [expr ($value * $base)/65536]
}
return $value
}
;# proc rand {args} {
;# global rseed
;#
;# set max 259200
;# set argcnt [llength $args]
;# if { $argcnt < 1 || $argcnt > 2 } {
;# error "wrong # args: random limit | seed ?seedval?"
;# }
;# if ![string compare [lindex $args 0] seed] {
;# if { $argcnt == 2 } {
;# set rseed [lindex $args 1]
;# } else {
;# set rseed [expr ([pid]+[file atime /dev/kmem])%$max]
;# }
;# return
;# }
;# if ![info exists rseed] {
;# set rseed [expr ([pid]+[file atime /dev/kmem])%$max]
;# }
;# set rseed [expr ($rseed*7141+54773)%$max]
;# return [expr $rseed%[lindex $args 0]]
;# }
##+#########################################################################
##
## Legal_1
##
## Tests whether cell R,C is legal as a first move for player WHO. The
## cell must be in range, contain a WHO blob and can has a place to
## move.
##
proc legal_1 {r c who} {
global bb
set xy [index $r $c]
if {[lindex $bb $xy] != $who} { return 0 } ;# Is correct piece there?
foreach i {1 2 9 10 11 12 13 20 21 22 23 24} {;# Neighbors 1 & 2 cells away
if {[lindex $bb [expr $xy + $i]] == 0} { return 1}
if {[lindex $bb [expr $xy - $i]] == 0} { return 1}
}
return 0
}
##+#########################################################################
##
## Legal_2
##
## Tests whether cell R,C is legal as a second move.
## Already we know the cell is empty, so we must check that
## its within 2 of the from cell.
##
proc legal_2 {r c fr fc} {
set dr [expr abs($r - $fr)]
if {$dr > 2} { return 0 }
set dc [expr abs($c - $fc)]
if {$dc > 2} { return 0 }
if {$dr == 2 || $dc == 2} { return 2}
return 1
}
##+#########################################################################
##
## Mouse_down
##
## Called on a mouse down event. Handles moving pieces and checking
## legality.
##
proc mouse_down {x y} {
global state bb
set r [expr $y / $state(cs)]
set c [expr $x / $state(cs)]
set where [list $r $c]
set xy [index $r $c] ;# Index into board string
set cell [lindex $bb $xy] ;# What's in that cell
if {$cell == $state(turn)} {
highlight -1 -1 ;# Turn off highlight
if {$state(state) == 1 && $state(from) == $where} {;# Same cell???
set state(state) 0 ;# Then toggle it off
return
}
if [legal_1 $r $c $state(turn)] { ;# Legal to go here?
highlight $r $c
set state(state) 1 ;# Go into next state
set state(from) $where
return
}
}
if {$state(state) != 1} return ;# No selected cell yet
if {$cell != 0} return ;# Not an empty cell
set n [eval legal_2 $where $state(from)] ;# Is it legal?
if $n {
eval do_move $where $state(from) $n ;# Yep, so do the move
} else {
highlight -1 -1 ;# Turn off highlighting
}
set state(state) 0 ;# Back to normal state
}
##+#########################################################################
##
## Do_move
##
## Does the move from FR,FC to R,C. Updates the blobs, toggles any
## neighbors of the new cell and checks for end-of-game, and can move?
##
proc do_move {r c fr fc type} {
global state bb mm
set mm($state(n)) [list $state(turn) $r $c $fr $fc $type];# Undo info
incr state(n)
set who $state(turn)
set opp [expr 3 - $who]
highlight -1 -1 ;# Turn off highlighting
if {$type != -1} {
grow_blob $state(turn) $r $c ;# Put in new blob
set cnt [toggle_cells $r $c $state(turn)];# Turn things around
incr state(sc,$who) $cnt ;# I get more pips
incr state(sc,$opp) [expr -$cnt] ;# You get less
if {$type > 1} { ;# Long jump???
delete_blob $fr $fc ;# ...then delete old blob
} else {
incr state(sc,$who) ;# One more for me
incr state(sc,0) -1 ;# One less empty
}
set bb [lreplace $bb 121 123 $state(sc,0) $state(sc,1) $state(sc,2)]
update
}
if {$state(sc,0) == 0 || $state(sc,1) == 0 || \
$state(sc,2) == 0} { ;# No more empty cells
end_game
return
}
set mv [can_move $opp] ;# Can opponent move?
if {$mv == 0} { ;# How many legal moves?
set state(msg) "$state(c,$opp) can't move. "
set state(msg) "$state(msg) $state(c,$who)'s turn"
} else {
set state(turn) $opp
.c itemconfig center -fill $state(c,$state(turn))
}
update
if {$state($state(turn))} robot ;# Do the computer move
}
##+#########################################################################
##
## Toggle_cells
##
## Turns all neighbors of R,C of into WHO blobs
##
proc toggle_cells {r c who} {
global bb
set opp [expr 3 - $who] ;# The other guy
set cnt 0 ;# How many flipped
set xy [index $r $c]
foreach i {1 -1 10 -10 11 -11 12 -12} { ;# Immediate neighbors
set p [expr $xy + $i]
if {[lindex $bb $p] == $opp} { ;# Is it the opponent?
delete_blob $p ;# Yep, flip him
make_blob $who $p
incr cnt
}
}
return $cnt
}
##+#########################################################################
##
## Can_move
##
## Determines if WHO has a legal move
##
##
proc can_move {who} {
global state bb
for {set r 0} {$r < 7} {incr r} { ;# Look at each row
for {set c 0} {$c < 7} {incr c} { ;# ...and each column
set xy [index $r $c]
if {[lindex $bb $xy] != $who} continue
if [legal_1 $r $c $who] {
return 1
}
}
}
return 0 ;# Can't move
}
##+#########################################################################
##
## End_game
##
## Handles end-of-game stuff
##
proc end_game {} {
global state
if {$state(sc,0) != 0} { ;# Shut out
fill_board [expr ($state(sc,1) > $state(sc,2)) ? 1 : 2]
}
if {$state(sc,1) > $state(sc,2)} { ;# Player 1 won
set state(msg) "Game over: $state(c,1) won"
} elseif {$state(sc,2) > $state(sc,1)} { ;# Player 2 own
set state(msg) "Game over: $state(c,2) won"
} else {
set state(msg) "Game over: it's a tie"
}
#if $state(Verbose) {
##puts "total calls: $state(tc)"
#}
}
##+#########################################################################
##
## Index
##
## Given row, column returns the corresponding index into the board
## string
##
proc index {r c} {
return [expr 24 + 11*$r + $c]
}
proc rindex {i} {
set r [expr ($i / 11) - 2]
set c [expr ($i % 11) - 2]
return [list $r $c]
}
##+#########################################################################
##
## Undo
##
## Undo last move. Works by replaying all but the last moves.
##
proc undo {} {
global state mm bb
if {$state(n) == 0} {
set state(msg) "Nothing to undo"
return
}
set state(msg) "Undoing last move"
set brd $state(init) ;# Starting position
set n [expr $state(n) - 1] ;# Number of moves to undo
set w [lindex $mm($n) 0] ;# Who made last turn
if {$state($w)} { ;# Last move by computer
incr n -1 ;# So undo both moves
set w [expr 3 - $w] ;# Whose turn it is
}
for {set i 0} {$i < $n} {incr i} { ;# Re-do each move
set brd [eval move2 [list $brd] $mm($i)]
}
set state(n) $n ;# New count total
set bb $brd ;# New board
redraw_board ;# Redraw it
set state(state) 0
highlight -1 -1
set state(turn) $w
.c itemconfig center -fill $state(c,$state(turn))
}
##+#########################################################################
##
## Robot
##
## Moves the pieces for the robot player. Does a game-tree search for
## the best move.
##
proc robot {{level -1}} {
global state bb
set who $state(turn) ;# Who to move
if {$level == -1} {
set level [.level get] ;# How smart to be
}
if {$level == 0} { ;# Random skill level
set m [lindex [all_moves $who $bb] 0]
} else {
set state(c) 0
set state(msg) "Thinking ($level)" ; update idletasks
set t [time {set mv [veb $who $bb $level 10000]}];# Get best move
set state(msg) ""
if {$state(Verbose)} {
set tt [expr [lindex $t 0] / 1000000.0]
set state(msg) \
"Rating: [lindex $mv 0] ($state(c) calls in $tt seconds)"
}
incr state(tc) $state(c)
set m [lindex $mv 1]
}
eval do_move [rindex [lindex $m 1]] [rindex [lindex $m 0]] [lindex $m 2]
}
##+#########################################################################
##
## Hint
##
## Suggest a move
##
proc hint {{level -1}} {
global state bb
if {$level == -1} { ;# Was level specified?
set level [.level get] ;# Nope, read the scale
if {$level == 0} { ;# Level 0 is not a hint
set level 1
}
}
if {$level == -2} { ;# One level up from computer
set level [expr 1 + [.level get]]
if {$level > 3} { set level 3 }
}
highlight -1 -1 ;# Turn off any highlighting
set state(c) 0 ;# For keeping stats
set state(msg) "Thinking ($level)" ; update idletasks
set t [time {set mv [veb $state(turn) $bb $level 10000]}];# Find best move
set state(msg) "" ;# Erase old message
if {$state(Verbose)} {
set tt [expr [lindex $t 0] / 1000000.0]
set state(msg) "Rating: [lindex $mv 0] ($state(c) calls in $tt seconds)"
}
set m [lindex $mv 1] ;# Extract the move
set from [lindex $m 0]
set to [lindex $m 1]
eval highlight [rindex $from]
eval highlight [rindex $to]
}
##+#########################################################################
##
## All_moves
##
## Returns a list of all legal moves for WHO on board BRD. Format is
## (from to type).
##
proc all_moves {who brd} {
set m "" ;# List of valid moves
for {set i 24} {$i < 97} {incr i} { ;# Try all positions
set c [lindex $brd $i]
if {$c == 4} { ;# Is it a border cell?
incr i 3 ;# Yep, skip to next valid cell
continue
}
if {$c != $who} continue ;# Not correct occupant
foreach j {1 10 11 12 -1 -10 -11 -12} { ;# Immediate neighbors
set xy [expr $i + $j]
if {[lindex $brd $xy] == 0} {
lappend m [list $i $xy 1]
set brd [lreplace $brd $xy $xy -1];# So we don't go here twice
}
}
foreach j {2 9 13 20 21 22 23 24} { ;# Neighbors 2 away
if {[lindex $brd [expr $i + $j]] <= 0} {
lappend m [list $i [expr $i + $j] 2]
}
if {[lindex $brd [expr $i - $j]] <= 0} {
lappend m [list $i [expr $i - $j] 2]
}
}
}
set n [llength $m]
if {$n == 0} { ;# Empty list
return {{0 0 -1}}
}
set n [rand $n]
set m "[lrange $m $n end] [lrange $m 0 [expr $n - 1]]"
return $m
}
##+#########################################################################
##
## Move
##
## Returns new board with WHO moving FROM to TO on board BRD.
## Does no screen updates.
##
proc move {who brd frm to type} {
if {$type == -1} { return $brd } ;# Nop move
set opp [expr 3 - $who] ;# Opponent
set sw [lindex $brd [expr 121 + $who]]
set so [lindex $brd [expr 121 + $opp]]
set brd [lreplace $brd $to $to $who] ;# Put new blob in
if {$type == 2} {
set brd [lreplace $brd $frm $frm 0] ;# Remove old piece
} else {
incr sw ;# Added to WHO's score
set e [lindex $brd 121] ;# Empty spots
set brd [lreplace $brd 121 121 [expr $e - 1]]
}
foreach i {1 10 11 12 -1 -10 -11 -12} { ;# Immediate neighbors
set xy [expr $to + $i]
if {[lindex $brd $xy] == $opp} { ;# Is it opponent?
set brd [lreplace $brd $xy $xy $who];# Yep, so toggle it
incr sw ;# Increase WHO's score
incr so -1 ;# Decrease OPP's score
}
}
if {$who == 1} {
set brd [lreplace $brd 122 123 $sw $so]
} else {
set brd [lreplace $brd 122 123 $so $sw]
}
return $brd
}
proc move2 {brd who r c fr fc type} {
set b [move $who $brd [index $fr $fc] [index $r $c] $type]
return $b
}
##+#########################################################################
##
## E
##
## Evaluates a position for WHO
##
proc e {who brd} {
set me [lindex $brd [expr 121 + $who]]
set you [lindex $brd [expr 124 - $who]]
if {$you == 0} { return 10000 }
if {$me == 0} { return -10000 }
return [expr $me - $you]
}
##+#########################################################################
##
## Veb
##
## Game-tree search with alpha-beta pruning. See _Fundamentals of Data
## Structures_, Horowitz, page 268.
##
## Initial call: veb (who board level infinity)
##
proc veb {who brd l d} {
global state
incr state(c) ;# Stats
if {$l == 0 || [lindex $brd 121] == 0} { ;# Terminal position?
return [e $who $brd] ;# ...just evaluate position
}
set ans -10000 ;# Lower bound on value
set best "" ;# Current best move
incr l -1 ;# Go down a level
set moves [all_moves $who $brd] ;# Get all legal moves
foreach m $moves { ;# Try each possible move
set b [eval move $who [list $brd] $m] ;# Do the move
set e [veb [expr 3 - $who] $b $l [expr -$ans]]
set a [expr -[lindex $e 0]]
if {$a > $ans} { ;# Is it a better move?
set ans $a ;# Yep, so use it
##set best "[list $m] [lrange $e 1 end]"
set best [list $m]
}
if {$ans >= $d} break ;# BETA rule
}
return "$ans $best"
}
#######################################################################
#
# Draw_menus
#
# Displays the menus on the screen
#
proc draw_menus {} {
global state
set menu(0) {&Game &Hint &Undo - &Restart "&New Board" - &Quit}
set menu(1) {&Opponent "&Red - Computer" "&Green - Computer" - \
&Random &Greedy &Brainy G&enius}
set menu(2) {&Display &Grid &Verbose}
set menu(3) {&Help &Help - &About}
foreach w [winfo children .m] { ;# Destroy what's out there
catch { destroy $w }
}
.m config -bd 3 -relief ridge ;# Configure its window
set menubar .m ;# Who to add to tk_menuBar
for {set i 0} {[info exist menu($i)]} {incr i} {
set who [underline [lindex $menu($i) 0]];# Menu header
set u [lindex $who 0] ;# Underline
set who [lrange $who 1 end]
menubutton .m.m$i -text $who -menu .m.m$i.m -padx 5 \
-underline $u -relief raised
menu .m.m$i.m
foreach item [lrange $menu($i) 1 end] { ;# Add sub-commands
set item [underline $item]
set u [lindex $item 0]
set item [lrange $item 1 end]
if [string match $item "-"] {
.m.m$i.m add separator
} elseif [string match $who "Opponent"] {
if {[llength $item] > 1} {
set w 2
if [string match [lindex $item 0] "Red"] {
set w 1
}
.m.m$i.m add check -label $item -u $u \
-variable state($w) \
-command "do_menu $who $item"
} else {
.m.m$i.m add radio -label $item -u $u \
-variable state(skill) \
-command "do_menu $who $item"
}
} elseif [string match $who "Display"] {
.m.m$i.m add check -label $item -u $u \
-variable state($item) \
-command "do_menu $who $item"
} else {
.m.m$i.m add command -label $item -underline $u \
-command "do_menu $who $item"
}
}
pack .m.m$i -side left ;# Display it
lappend menubar .m.m$i
}
eval tk_menuBar $menubar ;# Make available via keyboard
focus [lindex $menubar 0] ;# Focus on the menubar
}
#######################################################################
#
# Underline
#
# Determines where in a menu item the underline should be placed. It
## goes after the '&' in the item.
#
# Value: it&em => "1 item"
# &item => "0 item"
# item => "-1 item"
#
proc underline item {
set u [string first & $item]
if {$u != -1} {
if {$u == 0} {
set item [string range $item 1 end]
} else {
set item [string range $item 0 [expr $u - 1]][string range $item \
[expr $u + 1] end]
}
}
return "$u $item"
}
#######################################################################
#
# Do_menu
#
# Process the menu commands
#
proc do_menu {cmd option args} {
global state
set option [string tolower $option] ;# Lowercase the arguments
switch $cmd {
Help -
Game {
switch $option {
hint { hint }
undo { undo }
restart { new_board $state(brd) ; start}
new { new_board ; start }
quit { exit }
about {
set msg "TkAtaxx\n\nby Keith Vetter\[EMAIL PROTECTED]"
my_dialog .about About $msg 3i
}
help { help }
}
}
Opponent {
set n [lsearch "random greedy brainy genius" $option]
if {$n != -1} {
.level set $n
} else start
}
Display { if {$option == "grid"} grid }
}
}
##+#########################################################################
##
## Start
##
## Starts/continues the game if it's the computer's turn
##
proc start {} {
global state
if {$state(sc,0) == 0 || $state(sc,1) == 0} return
if {$state($state(turn)) == 1} robot
}
##+#########################################################################
##
## Help
##
## Displays a help screen using a modified version of tk_dialog
##
proc help {} {
set msg ""
set msg "TkAtaxx\n\n\n"
set msg "${msg}DESCRIPTION"
set msg "$msg\n\nTkAtaxx is a tcl/tk implementation of the popular"
set msg "$msg arcade video Ataxx. The goal of the game is end up"
set msg "$msg with more pieces of your color than your"
set msg "$msg opponent. The game ends when there are no more"
set msg "$msg places to move."
set msg "$msg\n\nMOVING"
set msg "$msg\n\nYou can move a piece in two different ways, either"
set msg "$msg sliding or jumping. To slide a piece, click on it"
set msg "$msg with the mouse, then click on an immediately"
set msg "$msg adjacent empty cell. The piece will split and"
set msg "$msg occupy both cells. To jump a piece, click on it"
set msg "$msg with the mouse, then click on an empty cell which"
set msg "$msg is two positions away from the starting piece. The"
set msg "$msg piece will jump to the new position over any"
set msg "$msg intervening obstacles vacating the original"
set msg "$msg position. If there are no possible moves for a"
set msg "$msg player then the move if forfeited."
set msg "$msg\n\nWhen a piece moves to a new cells, all surrounding"
set msg "$msg cells of the opponent's color will be captured and"
set msg "$msg turn into your color."
set msg "$msg\n\nSKILL LEVEL"
set msg "$msg\n\nYou can adjust how smart the computer opponent"
set msg "$msg is. Random skill picks any move at"
set msg "$msg random. Greedy picks the move which maximizes how"
set msg "$msg many pieces he has at the end of the turn. Brainy"
set msg "$msg searches two moves ahead of the best move. Genius"
set msg "$msg searches three moves ahead for the best move."
set msg "$msg\n\nProgram written by Keith Vetter ([EMAIL PROTECTED])"
my_dialog .top Help $msg 6i
}
##+#########################################################################
##
## My_dialog
##
## Simplified version of tk_dialog. Forced to so we could better
## adjust the width of the dialog.
##
proc my_dialog {w title text width} {
global tk_priv
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
# 2. Fill the top part with bitmap and message.
message $w.msg -text $text -font -Adobe-Times-Medium-R-Normal-*-180-*
$w.msg config -width $width
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 5m -pady 5m
label $w.bitmap -bitmap info
pack $w.bitmap -in $w.top -side left -padx 5m -pady 5m
# 3. Create a row of buttons at the bottom of the dialog.
frame $w.default -relief sunken -bd 1
button $w.button -text " OK " -command "destroy $w"
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.button -in $w.default -padx 2m -pady 2m -ipadx 2m -ipady 1m
# 4. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
return
}
##+#########################################################################
##
##
init
display
new_board
set state(msg) "Welcome to TkAtaxx"
wm minsize . 300 300
update
;#BROKEN bind . <Configure> { resize %w %h }
proc dump {{brd ""}} {
global bb
if {$brd == ""} {set brd $bb}
for {set i 0} {$i < 11} {incr i} {
for {set j 0} {$j < 11} {incr j} {
if {$j == 2 || $j == 9} { puts -nonewline " "}
puts -nonewline "[lindex $brd [expr $i*11 + $j]] "
}
if {$i == 1 || $i == 8} {puts " "}
puts " "
}
}
proc foo {} {
global bb
set e [lindex $bb 121]
set r [lindex $bb 122]
set g [lindex $bb 123]
set o [lindex $bb 124]
set t [expr $e + $r +$g + $o]
puts "e $e r $r g $g o $o $t"
}
set xbb "4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 0 0 1 3 1 2 2 4 4 4 4 0 1 1 1
1 1 0 4 4 4 4 0 3 1 1 1 3 0 4 4 4 4 3 1 1 1 1 1 3 4 4 4 4 1 3 1 1 1 3 1 4 4 4 4 0 1 1
1 1 1 1 4 4 4 4 1 0 1 3 1 1 1 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 7 32 2 8"
return
