proc help {{op stdout}} {
append all " Your aim is to complete a continuous line from top to bottom of the board -\n"
append all " joining the blue dots.\n\n"
append all " While the opponent aims to complete a continuous line from side to side,\n"
append all " joining the red dots.\n\n"
append all " Click to place a link between 2 blue dots.\n\n"
append all " Choose a smaller or larger board with the spinbox number and 'Restart'.\n\n"
append all " Once either of the players has succeeded, the other player cannot finish\n"
append all " The game can only end in victory for one or other player - draw is impossible.\n\n"
append all " Ref: Martin Gardner, Mathematical Puzzles and Diversions.\n"
tk_messageBox -message $all
puts $op $all
}
# the artificial intelligence solves a linear set of equations, so load:.
package require math::linearalgebra
#
# cells
# 1 n+1 2n+2
# 2 n+2....
# 3 n+3...
# 4...
#
#
# resistances - n2 = n*(n-1) number of vertical resistances
# 0 n+1 2n+2
# n2 n2+n
# 1 n+1....
# n2+1 n2+n+1
# 2 n+2...
# n2+2 n2+n+2
# 3...
#
# each cell forms a closed loop of resistances and has a current flowing round it
# the actual voltage across a reistance is R.(adjacent current-this current)..
proc calccurr {brd nx} { ;# make the computer's move
set nloops [expr {$nx*($nx-1)+1}]
#puts "Computer moves for $nx size board - $nloops "
# this has nx*(nx-1)+1 loops to be solved for.
# we create a matrix and solve it
set mt [math::linearalgebra::mkMatrix $nloops $nloops 0.0]
set vc [math::linearalgebra::mkVector $nloops 0.]
math::linearalgebra::setelem vc 0 1 ;# the driving voltage
set i 0
set rloop 0
while {$i<$nx} { ;# consider first loop. rshared to 'lower' side only
set iup [expr {$i*$nx}] ;# the shared resistor
set iadj [expr {$i*($nx-1)+1}] ;# adjacent current loop
set rloc [$brd getres $iup]
set rloop [expr {$rloop+$rloc}]
math::linearalgebra::setelem mt 0 $iadj -$rloc
math::linearalgebra::setelem mt $iadj 0 -$rloc
math::linearalgebra::setelem mt $iadj $iadj [expr {[math::linearalgebra::getelem $mt $iadj $iadj]+$rloc}]
incr i
}
math::linearalgebra::setelem mt 0 0 $rloop
set j 0
set iloop 0
while {$j<$nx-1} { ;# consider each loop row. Up sides already handled
set i 0
while {$i<$nx} { ;# consider each loop in row. Up side already handled
set iup [expr {$i*$nx+$j+1}] ;# the shared resistor
set ithis [expr {$i*($nx-1)+$j+1}] ;# the local current
set iadj [expr {$i*($nx-1)+$j+2}] ;# adjacent current loop
set rloc [$brd getres $iup]
math::linearalgebra::setelem mt $ithis $ithis [expr {[math::linearalgebra::getelem $mt $ithis $ithis]+$rloc}]
if {$j<$nx-2} { ;# there is nothing beneath nx-2.
math::linearalgebra::setelem mt $iadj $iadj [expr {[math::linearalgebra::getelem $mt $iadj $iadj]+$rloc}]
math::linearalgebra::setelem mt $ithis $iadj -$rloc
math::linearalgebra::setelem mt $iadj $ithis -$rloc
}
if {$i<$nx-1} {
set iup [expr {$nx*$nx+$i*($nx-1)+$j }] ;# the shared resistor
set iadj [expr {$ithis+($nx-1)}] ;# adjacent current loop
set rloc [$brd getres $iup]
# then cover right except at end of row
math::linearalgebra::setelem mt $ithis $ithis [expr {[math::linearalgebra::getelem $mt $ithis $ithis]+$rloc}]
math::linearalgebra::setelem mt $iadj $iadj [expr {[math::linearalgebra::getelem $mt $iadj $iadj]+$rloc}]
math::linearalgebra::setelem mt $ithis $iadj -$rloc
math::linearalgebra::setelem mt $iadj $ithis -$rloc
}
incr i
incr iloop
}
incr j
}
set currs [ math::linearalgebra::solveGauss $mt $vc ]
#now find voltage across each resistor - the biggest is the BEST computer move.
set imax -1
set vmax 0
for {set i 0} {$i<$nx*$nx+($nx-1)*($nx-1)} { incr i} {
if {[$brd getres $i]==1} { ;# not yet cut or shorted.
# find shared currents. Difference is the voltage
if {$i<$nx*$nx} { ;# a horizontal resistor
set ix [expr {$i/$nx}]
set jx [expr {$i%$nx}]
set iup [expr {$jx==0?0:($i-$ix)}]
set idn [expr {$jx>$nx-2?-1:$i-$ix+1}]
set v [expr {$idn>0?[lindex $currs $iup]-[lindex $currs $idn]:[lindex $currs $iup]}]
} else { ;# vert resist.
set iii [expr {$i-$nx*$nx}] ;# which ij
set ix [expr {$iii/($nx-1)}]
set jx [expr {$iii%($nx-1)}]
set iup [expr {$ix*($nx-1)+$jx+1}]
set idn [expr {$iup+$nx-1}]
set v [expr {[lindex $currs $iup]-[lindex $currs $idn]}]
}
if {abs($v)>abs($vmax)} {
set vmax $v
set imax $i
}
}
}
return [list $imax [lindex $currs 0]]
}
proc bridgit {w args} { ;# a game of bridgit, toplevel for the board
# and allows new smooth shaped buttons.
global $w.props ;# an array of options specific to the bridgit game 'class'
global $w.res ;# an array of resistors for the computer move
# set by .this -<option> <value>
array set $w.props {-size 7 -spacing 50} ; # define the option list and each default value
array set options {}
set bridArgs {} ;# list of arguments not specific to the class
foreach {opt val} $args {
if {[array names $w.props $opt]!=""} {set options($opt) $val
} else { lappend bridArgs $opt $val }
}
# make the base canvas.
eval toplevel $w $bridArgs ;# create the "procedure" w
bind $w <Destroy> "$w destroy %W"
interp hide {} $w
# Install the alias:
interp alias {} $w {} bridgitCmd $w ;# bridgitsCmd are sub-commands for this class
foreach opt [array names options] {
$w configure $opt $options($opt)
}
$w makeboard
wm withdraw .
return $w ;# the original object
}
proc bridgitCmd {self cmd args} {
switch -- $cmd {
configure {eval bridgitConfigure $self $cmd $args}
cget {eval bridgitCget $self $args}
{about} {return [help] ;# return unit value
}
{size} {return [$self cget -size] ;# return unit value
}
{destroy} { ;# all destroy events come here - check that we are destroying the lowest level window.
if {$self==[lindex $args 0]} {
#tk_messageBox -message "$self is being destroyed $args<<\n[info level ]"
exit
}
}
{getid} { set x [lindex $args 0]
set y [lindex $args 1]
set nx [lindex $args 2] ;# which move has been made
# returns 0,nx-1 for first column of player moves; nx-2nx-1 for second
#>nx*nx for a horizontal move
# -1 for an invalid move.
set spacing [$self cget -spacing]
set ix [expr {($x-$spacing/2-2)/$spacing}]
set iy [expr { ($y-2)/$spacing }]
set nc [expr {$nx*$nx}] ;# numbero fo vertical moves available to the player.
# identify side (top, bottom, L, R)
set ixrel [expr {($x-$spacing*$ix-$spacing/2)}]
set iyrel [expr {($y-($spacing*$iy))}]
if {$ix>=-1 && $ix<$nx} {
if {$iy>=0 && $iy<$nx} {
if {abs($ixrel-$spacing/2)>abs($iyrel-$spacing/2)} {
if {$ixrel<$spacing/2} { set sid "L" } else { set sid "R" }
} else {
if {$iyrel<$spacing/2} { set sid "T" } else { set sid "B" }
}
switch $sid {
"L" {
if {$ix>$nx} {return -1} ;# invalid cell
if {$ix<0} {return -2} ;# invalid cell
return [expr {$ix*$nx+$iy}]
}
"R" {
if {$ix<-1} {return -1} ;# invalid cell
if {$ix>$nx-1} {return -2} ;# invalid cell
return [expr {($ix+1)*$nx+$iy}]
}
"T" {
if {$ix>=($nx-1)} {return -1} ;# invalid cell
if { $ix<0 } {return -2} ;# invalid cell
if {$iy<1} {return -3} ;# invalid cell
return [expr {$nx*$nx+$ix*($nx-1)+$iy-1}]
}
"B" {
if {$ix>=($nx-1)} {return -1} ;# invalid cell
if { $ix<0} {return -2} ;# invalid cell
if {$iy>($nx-2)} {return -2} ;# invalid cell
return [expr {$nx*$nx+$ix*($nx-1)+$iy}]
}
}
}
}
return -1
}
{getcut} { return [eval $self getid $args] }
{makemove} {
set ishort [lindex $args 0] ;# the resistor being cut.
set nx [$self cget -size]
set spac [$self cget -spacing]
if {$ishort<$nx*$nx} { ;# H- move
set ix [expr {int($ishort/$nx)}]
set iy [expr {int($ishort%$nx)}]
$self.froth.board create line [expr {$ix*$spac+5}] [expr {($iy+.5)*$spac+5}] \
[expr {($ix+1)*$spac+5}] [expr {($iy+.5)*$spac+5}] -fill red -width 3
} else {
set nrel [expr {$ishort-$nx*$nx}] ;# id relative to start of horizontal res.
set ix [expr {int($nrel/($nx-1))}]
set iy [expr {int($nrel%($nx-1))}]
$self.froth.board create line [expr {($ix+1)*$spac+5}] [expr {($iy+.5)*$spac+5}] \
[expr {($ix+1)*$spac+5}] [expr {($iy+1.5)*$spac+5}] -fill red -width 3
}
}
{setres} {
global $self.props
set $self.props(res[lindex $args 0]) [lindex $args 1]
}
{getres} {
return [$self cget res[lindex $args 0] ]
}
{makeresists} {
set n [$self cget -size]
# the algorithm depends on shorting out or cutting a set of resistors.
# each resistor represents a possible computer's move.
# A player's move cuts the resistor; the computer move at same place shorts out the resistor.
for {set i 0} {$i<$n*$n+($n-1)*($n-1)} { incr i} {
$self setres $i 1
}
}
{makefirstm} {
set n [$self cget -size]
set spacing [$self cget -spacing]
$self makeboard
# here we make a random move - get out of that!
set nx [expr {int(rand()*($n-1)*$spacing+$spacing/2.)}]; set ny [expr {int(rand()*($n-1)*$spacing+$spacing/2.)}]
$self click $nx $ny
}
{makeboard} { ;# puts "$self makeboard -- $cmd $args";
set n [$self cget -size]
# insert symbols into a canvas.
set spacing [$self cget -spacing]
catch {destroy $self.froth}
set frm [frame $self.froth]
pack [canvas $frm.board -height [expr {$spacing*$n+10}] -width [expr {$spacing*$n+10}]] -padx 10 -pady 10
bind $frm.board <ButtonPress-1> "$self click %x %y"
bind $frm.board <Motion> "$self setcursor %x %y"
set i 0
while {$i<=$n} {
set x [expr {$spacing*$i+2.5}]
set j 0
while {$j<$n} {
set y [expr {$spacing*($j+.5)+2.5}]
$frm.board create oval $x $y [expr {$x+5}] [expr {$y+5}] -fill red
incr j
}
incr i
}
set i 0
while {$i<$n} {
set x [expr {$spacing*($i+0.5)+2.5}]
set j 0
while {$j<=$n} {
set y [expr {$spacing*$j+2.5}]
$frm.board create oval $x $y [expr {$x+5}] [expr {$y+5}] -fill blue
incr j
}
incr i
}
set ::ival "Your move."
pack [label $frm.mesg -textvariable ::ival] -padx 10 -pady 4
pack [frame $frm.butts] -padx 2 -pady 4
pack [ button $frm.rest -text "Restart" -command "$self makeboard "] -padx 10 -pady 1 -side left
pack [ button $frm.refm -text "Make My First move" -command "$self makefirstm "] -padx 10 -pady 1 -side left
pack [ spinbox $frm.setsiz -from 3 -to 18 -command "$self configure -size %s" -width 3] -padx 10 -pady 1 -side left
$frm.setsiz set [$self cget -size]
pack [ button $frm.aboutt -text "About..." -command "$self about"] -padx 10 -pady 4 -side left
pack [ button $frm.exit -text "Exit" -command "exit 1"] -padx 10 -pady 4 -side right
pack $frm
$self makeresists [$self cget -size]
return
}
{setwin} {
set ::ival "[lindex $args 0] Wins"
switch [lindex $args 0] {
{Boris} { $self.froth.board configure -background green }
default { $self.froth.board configure -background cyan }
}
}
{setcursor} {
set nx [$self cget -size]
set icut [$self getcut [lindex $args 0] [lindex $args 1] $nx]
if {$icut<$nx*$nx} { $self.froth.board configure -cursor sb_v_double_arrow
} else { $self.froth.board configure -cursor sb_h_double_arrow }
}
{click} {
set x [lindex $args 0]
set y [lindex $args 1]
set nx [$self cget -size] ;# xy are relative to the board (not window).
# identify nearest dot pair
# $self.froth.board the game frame x,y are relative to $self.froth.board.
set i1 [$self getid $x $y $nx]
set icut [$self getcut $x $y $nx ]
if {$icut<$nx*$nx} { set horv "v"} else { set horv "h"}
if {$icut>=0} {
if {[$self getres $icut]==1} {
$self playerscut $horv $icut $nx
$self setres $icut 1.e8 ;# my move - cuts out resistor
# computer move shorts the resistor
set ::ival "OK.."; update idletasks
$self computermove $nx ;# calculate response
} else { set ::ival "Already used" }
} else {
set ::ival "Invalid Move $icut"; update idletasks
}
}
{computermove} {
set nx [lindex $args 0] ;# make the computer's move
set res [ calccurr $self $nx]
set imax [lindex $res 0]
$self setres $imax 1.e-8
$self makemove $imax
set res [ calccurr $self $nx] ;# recalculate the current to check if computer has won.
set curmax [expr {abs([lindex $res 1])}]
if {$curmax<1.e-3} {
$self setwin "You"
} elseif {$curmax>1.e3} {
$self setwin "Boris"
} else {
set ::ival "Your move"
#puts "Best current is $curmax"
}
}
{playerscut} {
set horv [lindex $args 0]
set nres [lindex $args 1]; set nx [lindex $args 2]
set spac [$self cget -spacing]
set ix [expr {int($nres/$nx)}]
set iy [expr {int($nres%$nx)}]
if {$horv=="v"} {
set ix [expr {int($nres/$nx)}]
set iy [expr {int($nres%$nx)}]
$self.froth.board create line [expr {($ix+.5)*$spac+5}] [expr {$iy*$spac+5}] \
[expr {($ix+.5)*$spac+5}] [expr {($iy+1)*$spac+5}] -fill blue -width 3
} else { ;# a horizontal move
set nrel [expr {$nres-$nx*$nx}] ;# id relative to start of horizontal res.
set ix [expr {int($nrel/($nx-1))}]
set iy [expr {int($nrel%($nx-1)+1)}]
$self.froth.board create line [expr {($ix+0.5)*$spac+5}] [expr {$iy*$spac+5}] \
[expr {($ix+1.5)*$spac+5}] [expr {$iy*$spac+5}] -fill blue -width 3
}
}
{default} { ;# use $cmd to canvas widget
# puts "Action $cmd $args"
eval interp invokehidden {{}} $self $cmd $args
}
}
}
proc bridgitConfigure {self cmd args} {
# 3 scenarios:
#
# $args is empty -> return all options with their values
# $args is one element -> return current values
# $args is 2+ elements -> configure the options
global $self.props
switch [llength $args] {
0 { ;# return all options
set result [array names $self.props]
return $result
}
1 { ;# return argument values
if {[array names $self.props $opt]!=""} { lappend opts [$self cget $args]
} else { puts "No option $opt" }
return $opts
}
default { ;# >1 arg - an option and its value
# go through each option:
foreach {option value} [lrange $args 0 end] {
if {[array names $self.props $option]!=""} {
# set global array element for each option.
set $self.props($option) $value
} else {
$self configure $option $value
}
}
return {}
}
}
}
proc bridgitCget {self args} {
# cget defaults done by the interp cget command
upvar #0 $self.props props ;# get local address for global array
#puts "$self get $args [array names props]"
if {[array names props $args ]!=""} {
#puts "CGoth $self $args; $props($args)"
return $props($args)
}
return [uplevel 1 [list interp invokehidden {} $self cget $args]]
}
#console show
update idletasks
catch { destroy .game}
set bif [bridgit .game -size 9 -spacing 45]The game of 'bridg-it'computer AI from Martin Gardener ref. Mathematical Puzzles and Diversions models board as electrical circuit. Max voltage across resistance is computer's best move.Ver 0.2 - minor improvement to handling window close - could leave the . window running in 0.1Ver 0.3 - better alignment of user & computer move with the board and added option to allow random first move (get out of that!).04.11.06 error in cget with 1 argument corrected.
gold added pix
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit