Updated 2016-05-03 19:29:23 by gold

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.1

Ver 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.
  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]

gold added pix