pkg://tkfibs-3.0-0.i386.rpm:30745/
usr/
bin/tkfibs.tcl
info downloads
#!/bin/sh
# The next line is executed by /bin/sh, but not Tcl \
exec wish $0 ${1+"$@"}
#################################################################
#
# TkFibs
#
# by Keith P. Vetter (keithv@cs.berkeley.edu)
# Copyright (c) 1993, 1994, 1995, 1996 Keith P. Vetter
#
# TkFibs is a graphical front-end to the FIBS backgammon server
# located at 129.16.235.165, port 4321. It is written in version
# tcl version 7.1 and tk version 4.0, with a C front end.
#
# Keith Vetter 11/23/94 Added Moves toggle menu item
# Keith Vetter 12/15/94 Arrow keys, home, end & mouse now work on command line
# Keith Vetter 1/../96 Did most work for tk4.0 conversion.
# Dirk Sudowe 2/14/96 Cleaned up some tk4.0 stuff.
# Keith Vetter 2/20/96 focus always in command window, catch on macro regexp.
# Keith Vetter 10/../96 many small fixes, added button 3 double==>invite
# made to work with tcl doing the socket work
# kibitz window, added ratings display
#
if {[info tclversion] < 7.0 || $tk_version < 4.0} {
puts stdout ""
puts stdout "You need TCL version 7.0 and TK version 4.0 for this program."
puts stdout ""
exit
}
puts "TkFibs 3.00 by Keith Vetter"
#################################################################
#
# Overview:
#
# We use two top level windows: . which holds the board, buttons and
# menus, and .term which is the terminal window which shows the text
# sent to and from FIBS.
#
# Global variables:
# state() - values derived from the board state sent by Fibs
# sz() - size of board objects, all derived from tkfibs(pipsize)
# board() - location of board objects
# tkfibs() - user definable values for color, titles, etc.
#
#
# Sizes: all sizes are determined from PIPSIZE
#
# Board(direction) is what draw_board, etc. use to determine where
# everything goes. We set it equal to state(color) which we get
# from FIBS. This assumes that state(color) == -state(direction)
# as sent by FIBS, which so far is true. This should probably be
# changed.
#
# Board direction 1, then white's home position is lower right
# Board direction -1, then black's home position is lower left
#
#################################################################
#
# Set_size pipsize
#
# Determines all the size of all parts of the board
#
proc set_size {{psize {}}} {
global sz
if {$psize == {}} { ;# Default to old size
set psize $sz(pipsize)
}
set sz(pipsize) $psize
if {$sz(pipsize) < 24} { set sz(pipsize) 24 };# Not any smaller than this
set sz(ps2) [expr 0.5*$psize] ;# Half a pip - handy to have
set sz(sx) [expr 0.1*$psize] ;# Shadow distance in x
set sz(sy) [expr 0.1*$psize] ;# Shadow distance in y
set sz(tw) [expr 1.2*$psize] ;# Width of triangle
set sz(th) [expr 5.1*$psize] ;# Height of triangle
set sz(bmw) [expr 0.1*$psize] ;# Margin width
set sz(bm) [expr 3.0*$sz(bmw)] ;# Total margin of the board
set sz(bw) [expr 1.6*$psize] ;# Width of bar
set sz(bw2) [expr 0.7*$psize] ;# Width of home divider
set sz(bwh) [expr 1.2*$psize] ;# Width of home bar
set sz(winx) [expr 2*$sz(bm)+2*$sz(bwh)+2*$sz(bw2)+12*$sz(tw)+$sz(bw)]
set sz(winy) [expr $sz(bm)+(2*$sz(th)/.85)+$sz(bm)]
set sz(bl) $sz(bm) ;# Left side
set sz(blf) [expr $sz(bl) + $sz(bwh) + $sz(bw2)];# Left side w/o home
set sz(br) [expr $sz(winx) - $sz(bm)] ;# Right side
set sz(brf) [expr $sz(br) - [expr $sz(bwh)+$sz(bw2)]];# Right side w/o home
set sz(bt) $sz(bm) ;# Top side
set sz(bb) [expr $sz(winy) - $sz(bm)] ;# Bottom side
set sz(bc) [expr ($sz(brf) + $sz(blf)) / 2.0];# Middle x of whole play area
set sz(bc2) [expr ($sz(bt) + $sz(bb)) / 2.0];# Middle y of whole play area
set sz(bcl) [expr .5*($sz(bc)-0.5*$sz(bw)+$sz(blf))];# Middle left area
set sz(bcr) [expr .5*($sz(brf)+$sz(bc)+0.5*$sz(bw))];# Middle right area
set sz(bl_pip) [expr $sz(bl) + $sz(ps2)] ;# Area we can move a pip
set sz(br_pip) [expr $sz(br) - $sz(ps2)]
set sz(bt_pip) [expr $sz(bt) + $sz(ps2)]
set sz(bb_pip) [expr $sz(bb) - $sz(ps2)]
set sz(ds) [expr $sz(pipsize) / 4.0] ;# Die dot size
set sz(die1,x) [expr $sz(bcl) - .75*$sz(pipsize)];# Die 1 x location
set sz(die1,y) $sz(bc2)
set sz(die2,x) [expr $sz(bcl) + .75*$sz(pipsize)];# Die 2 x location
set sz(die2,y) $sz(bc2)
set sz(die,xshift) [expr $sz(bcr) - $sz(bcl)]
set sz(f_ps) 15 ;# Size of pip in frills area
return $psize
}
#################################################################
#
# do_defaults
#
# We allow the user to set many of the cosmetic aspects such as
# colors and titles. We first set our initial values then read
# the file ~/.tkfibsrc to get the users defaults.
#
proc do_defaults {} {
global tkfibs
set tkfibs(login) baal ;# FIBS login name
set tkfibs(passwd) "" ;# Password for Fibs
set tkfibs(pipsize) 30 ;# How big to make the board
set tkfibs(ow_height) 24 ;# Output window height
set tkfibs(ow_width) 80 ;# Output window width
set tkfibs(title) TkFibs ;# Window title for board
set tkfibs(title2) TkFibs ;# Window title for command
set tkfibs(prompt) "TkFibs> " ;# Prompt in command window
set tkfibs(kprompt) "Kibitz> " ;# Prompt in kibitz window
set tkfibs(pipcount) 0 ;# Show the pipcount
set tkfibs(animate) 1 ;# Move opp. pieces into place
set tkfibs(numbers) 0 ;# Show board position numbers
set tkfibs(ratings) 0 ;# Show opponents rating
set tkfibs(kibitz) 0 ;# Make kibitz window visible
set tkfibs(color,frame1) black ;# Outside margin
set tkfibs(color,frame2) white ;# Next margin
set tkfibs(color,frame3) black ;# Third margin - frames field
set tkfibs(color,play) deepskyblue4 ;# Playing area color
set tkfibs(color,bar) black ;# Color of the bar
set tkfibs(color,wpip) white ;# White pip color
set tkfibs(color,bpip) maroon ;# Black pip color
set tkfibs(color,w_shadow) black ;# White pip's shadow
set tkfibs(color,b_shadow) black ;# Black pip's shadow
set tkfibs(color,d_shadow) black ;# Die's shadow
set tkfibs(color,d_dot) black ;# Die's dot color
set tkfibs(color,dcube) maroon ;# Double cube color
set tkfibs(color,dc_shadow) black ;# Double cube shadow
set tkfibs(color,triag0) limegreen ;# Board triangle color
set tkfibs(color,triag1) gold ;# Board other triangle color
set tkfibs(color,triag_s) black ;# Shadow for triangle
set tkfibs(color,bg) #d9d9d9 ;# Non-board background
set tkfibs(color,menu) #d9d9d9 ;# Menu background
set tkfibs(color,output) #d9d9d9 ;# Output window background
set tkfibs(color,command) #d9d9d9 ;# Command window background
set tkfibs(color,output_text) black ;# Output window text
set tkfibs(color,command_text) black ;# Command window text
set tkfibs(color,about) #d9d9d9 ;# About dialog color
set tkfibs(color,fullmove) purple ;# Move label w/ 2/4 moves
#
#
# Tags: if the line sent by FIBS matches the first item, then that line
# will be colored the second argument. There can be any number of tags as
# long as they're numbered sequentially. The third argument is any commands
# to be executed.
#
# Some useful commands are: bell - rings the terminal bell, and FIBS - which
# sends the text to FIBS.
#
# Text to match Color Command
##set tkfibs(tag1) {"Please move " green }
##set tkfibs(tag2) {"Starting a new game" green {FIBS "toggle double"}}
##set tkfibs(tag3) {"Please roll or double" red bell}
##set tkfibs(tag4) {"kibitzes:" deeppink }
##set tkfibs(tag5) {"whispers:" deeppink }
##set tkfibs(tag6) {"sracer" skyblue }
#
# Set the default font. We do a little test to make sure the
# font really exists. Also, we specify the font to be used in
# the output window.
#
option add *font -Adobe-Helvetica-Bold-R-Normal--14-100*
if [catch {button .b -text test}] { ;# Does font exist?
option clear
} else { catch { destroy .b } }
set tkfibs(output_font) "*-Courier-Medium-R-Normal--*-140-*"
set tkfibs(output_boldfont) "*-Courier-Bold-R-Normal-*-140-*"
#
# Initial commands. These will be sent to FIBS upon authentication
# of the users login.
#
set tkfibs(init) {}
#
# Now read the users specified defaults in ~/.tkfibsrc
#
set tkfibs(rating) "?"
catch {source ~/.tkfibsrc}
if {$tkfibs(pipsize) < 24} { set tkfibs(pipsize) 24 }
}
#################################################################
#
# draw_board
#
# Draws the basic board with the triangles. Does not draw
# the pips.
#
proc draw_board {} {
global sz ;# Sizes of everything
global board ;# Pip and board info
global tkfibs ;# State information
.b delete all
.b config -height $sz(winy) -width $sz(winx);# Resize the canvas
#
# First draw the outlines
#
.b create rectangle 0 0 $sz(winx) $sz(winy) -tag frame1
.b itemconfig frame1 -fill $tkfibs(color,frame1)
.b itemconfig frame1 -outline $tkfibs(color,frame1)
set m $sz(bmw)
.b create rect $m $m [expr $sz(winx) - $m] [expr $sz(winy)-$m] -tag frame2
.b itemconfig frame2 -fill $tkfibs(color,frame2)
.b itemconfig frame2 -outline $tkfibs(color,frame2)
set m [expr 2*$sz(bmw)]
.b create rect $m $m [expr $sz(winx) - $m] [expr $sz(winy)-$m] -tag frame3
.b itemconfig frame3 -fill $tkfibs(color,frame3)
.b itemconfig frame3 -outline $tkfibs(color,frame3)
set m [expr 3*$sz(bmw)]
.b create rect $m $m [expr $sz(winx) - $m] [expr $sz(winy)-$m] -tag play
.b itemconfig play -fill $tkfibs(color,play) -outline $tkfibs(color,play)
if {[winfo depth .] == "1"} {
.b itemconfig play -stipple gray50 -fill gray
}
#
# Now draw the bar
#
set x1 [expr $sz(bc) - ($sz(bw) / 2.0)] ;# Left side of bar
set x2 [expr $x1 + $sz(bw)] ;# Right side of bar
.b create rectangle $x1 $sz(bt) $x2 $sz(bb) -tag bar
.b itemconfig bar -fill $tkfibs(color,bar)
.b itemconfig bar -outline $tkfibs(color,bar)
#
# Dividers between playing fields and homes
#
set x [expr $sz(blf) - $sz(bw2)] ;# Left side
.b create rectangle $x $sz(bt) $sz(blf) $sz(bb) -tag "bar barl"
.b itemconfig barl -fill $tkfibs(color,bar)
.b itemconfig barl -outline $tkfibs(color,bar)
set board(homel,x) [expr $sz(bl) + 0.5 * $sz(bwh)]
set x [expr $sz(brf) + $sz(bw2)] ;# Right side
.b create rectangle $sz(brf) $sz(bt) $x $sz(bb) -tag "bar barr"
.b itemconfig barr -fill $tkfibs(color,bar)
.b itemconfig barr -outline $tkfibs(color,bar)
set board(homer,x) [expr ($sz(br) + $x) / 2.0]
#
# Now draw the triangles and the dice
#
draw_triangles ;# Draw the triangles
place_homebar ;# Figure out where home is
draw_dice ;# Draw the dice
draw_dcube ;# Draw the cube
numbers 1 ;# Show position numbers
}
#################################################################
#
# place_homebar
#
# Determines where home and bar are for the current direction
#
proc place_homebar {} {
global board sz
if {[info exist board(homel,x)] == 0} return;# No board yet
set board(bar,x) $sz(bc) ;# Bar positions
set board(barw,x) $sz(bc) ;# Bar positions
set board(barb,x) $sz(bc)
set board(bar$board(ocolor),y) [expr $sz(bt) + $sz(ps2)]
set board(bar$board(color),y) [expr $sz(bb) - $sz(ps2)]
#
# Now figure out where home and doubling cube go
#
set board(homew,x) $board(homer,x) ;# Guess home is right
set board(dcube,x) [expr $board(homel,x) - .5*$sz(sx)];# and cube left
set board(dcube,xx) $sz(bcl)
if {$board(direction) == -1} {
set board(homew,x) $board(homel,x) ;# Guessed wrong
set board(dcube,x) [expr $board(homer,x) - .5*$sz(sx)]
set board(dcube,xx) $sz(bcr)
}
set board(homeb,x) $board(homew,x) ;# Blacks home = white's
set board(home$board(color),y) [expr $sz(bb) - $sz(ps2)]
set board(home$board(ocolor),y) [expr $sz(bt) + $sz(ps2)]
set board(dcube,y) $sz(bc2) ;# Y position for dcube
set board(dcube,y_me) [expr $sz(bb) - 2*$sz(pipsize)]
set board(dcube,y_opp) [expr $sz(bt) + 2*$sz(pipsize)]
set board(dcube,yy1) [expr $sz(bc2) - 2*$sz(pipsize)]
set board(dcube,yy2) [expr $sz(bc2) + 2*$sz(pipsize)]
}
#################################################################
#
# draw_triangles
#
# Draws the 24 triangles on the board and records
# the x,y position in the board array
#
proc draw_triangles {} {
global sz ;# Size of everything
global board ;# Board information
global tkfibs ;# Colors of the objects
set color(0) $tkfibs(color,triag0) ;# So we can toggle colors
set color(1) $tkfibs(color,triag1)
for {set i 0} {$i < 12} {incr i} { ;# Build top/bottom together
set c1 [expr $i % 2]
set c2 [expr 1 - $c1]
#
# Top left field
#
set x1 [expr ($i * $sz(tw))+ $sz(blf)] ;# X,y coordinates
if {$i > 5} {
set x1 [expr (($i-6) * $sz(tw)) + $sz(bc) + ($sz(bw) / 2.0)]
}
set x2 [expr $x1 + $sz(tw)]
set x3 [expr $x1 + ($sz(tw) / 2.0)]
set y3 [expr $sz(bt) + $sz(th)]
set id [expr 13 + $i]
if {$board(direction) == -1} { set id [expr $i + 1] }
.b create polygon $x1 $sz(bt) $x2 $sz(bt) $x3 $y3 -tag triag$c1
.b create line $x1 $sz(bt) $x2 $sz(bt) $x3 $y3 \
-fill $tkfibs(color,triag_s)
set board($id,x) $x3
set board($id,y) [expr $sz(bt) + $sz(ps2)]
#
# Bottom field
#
set y3 [expr $sz(bb) - $sz(th)]
set id [expr 12 - $i]
if {$board(direction) == -1} { set id [expr 24 - $i] }
.b create polygon $x1 $sz(bb) $x2 $sz(bb) $x3 $y3 -tag triag$c2
.b create line $x1 $sz(bb) $x2 $sz(bb) $x3 $y3 \
-fill $tkfibs(color,triag_s)
set board($id,x) $x3
set board($id,y) [expr $sz(bb) - $sz(ps2)]
}
.b itemconfig triag0 -fill $tkfibs(color,triag0)
.b itemconfig triag1 -fill $tkfibs(color,triag1)
}
#################################################################
#
# draw_dice d1 d2
#
# Draws the dice and the proper number of dots
#
proc draw_dice {{d1 {}} {d2 {}}} {
global state tkfibs ;# Where and how to draw die
if {$d1 == {}} {
set d1 $state(die1)
set d2 $state(die2)
if {$d1 == 0} {
set d1 $state(opp_die1)
set d2 $state(opp_die2)
}
}
if {$d1 < $d2} {
set state(d1) $d1 ;# Dice for check_move
set state(d2) $d2
} else {
set state(d1) $d2 ;# Dice for check_move
set state(d2) $d1
}
set state(d3) 0
if {$state(d1) == $state(d2)} { set state(d3) $state(d1) }
set state(d4) $state(d3)
.b delete die ;# Get rid of any old dice
makedie 1 $d1
makedie 2 $d2
.b itemconfig pdie -fill $tkfibs(color,[whatcolor $state(turn)]pip)
}
#################################################################
#
# draw_dcube value
#
# Draws the doubling cube. We must see which side of the board
# it goes on.
#
# Value: -1 => we just doubled, -2 => opponent just doubled
#
proc draw_dcube {{value {}}} {
global sz state tkfibs board
set doubling 0 ;# Are we doubling?
if {$value == {}} {
set value $state(dcube)
} elseif {$value < 0} { ;# Animated double?
set doubling [expr -$value]
set value [expr 2 * $state(dcube)]
} else { set state(dcube) $value }
if {[.b find withtag dcube] == {}} { ;# Do we need to make it?
set s $sz(pipsize) ;# How big to make it
set s2 [expr $s / 2.0] ;# Where to put the text
.b create rect 0 0 $s $s -fill $tkfibs(color,dc_shadow) -tags dcube
.b itemconfig dcube -tags "dc_shadow dcube"
.b move dcube $sz(sx) $sz(sy)
.b create rect 0 0 $s $s -fill $tkfibs(color,dcube) -tag "dcube pdcube"
.b create text $s2 $s2 -anchor center -tags "dcube dcubet"
}
.b itemconfig dcubet -text $value ;# Put in the new value
set x $board(dcube,x)
set y $board(dcube,y) ;# Assume it's in the middle
if {$doubling} { ;# Where to put it
set x $board(dcube,xx)
set y $board(dcube,yy$doubling)
} elseif {$state(i_may_double) != 0 && $state(opp_may_double) == 0} {
set y $board(dcube,y_me)
} elseif {$state(i_may_double) == 0 && $state(opp_may_double) != 0} {
set y $board(dcube,y_opp)
}
movepip_xy dcube $x $y ;# Position correctly
}
#################################################################
#
# makedie die n
#
# Creates a die with N pips on it, and places it
# in the correct position.
#
proc makedie {die n} {
global sz tkfibs state board
.b delete die$die ;# Get rid of any old dice
set s $sz(pipsize) ;# Size of the die
set id [.b create rect 0 0 $s $s -fill $tkfibs(color,d_shadow)]
.b itemconfigure $id -tag "die die$die d_shadow"
.b move die$die $sz(sx) $sz(sy)
set id [.b create rect 0 0 $s $s -fill $tkfibs(color,wpip)]
.b itemconfigure $id -tag "die pdie die$die pdie$die"
for {set i 1} {$i <= $n} {incr i} { ;# Make the dots on the die
.b create oval 0 0 $sz(ds) $sz(ds) -fill $tkfibs(color,d_dot) \
-tag "die die$die dot${die}_$i diedot d_dot"
}
if {$n == 0} { ;# No pips - display ?
set s2 [expr 0.5 * $s]
.b create text $s2 $s2 -anchor center -text "?" \
-tag "die die$die die${die}_t"
}
#
# Now position the dot in one of seven possible locations
#
set mx1 [expr 0.25 * $s - 0.5 * $sz(ds)] ;# Offsets to locations
set mx2 [expr 0.50 * $s - 0.5 * $sz(ds)]
set mx3 [expr 0.75 * $s - 0.5 * $sz(ds)]
set dot 0
if {$n == 6} { ;# 6 needs wider spacing
.b move dot${die}_1 [expr $mx1 - 0.25 * $sz(ds)] $mx1
.b move dot${die}_2 $mx2 $mx1
.b move dot${die}_3 [expr $mx3 + 0.25 * $sz(ds)] $mx1
.b move dot${die}_4 [expr $mx1 - 0.25 * $sz(ds)] $mx3
.b move dot${die}_5 $mx2 $mx3
.b move dot${die}_6 [expr $mx3 + 0.25 * $sz(ds)] $mx3
} else {
if {$n > 1} {
.b move dot${die}_[incr dot] $mx1 $mx1
.b move dot${die}_[incr dot] $mx3 $mx3
}
if {$n > 3} {
.b move dot${die}_[incr dot] $mx1 $mx3
.b move dot${die}_[incr dot] $mx3 $mx1
}
if {$n == 1 || $n == 3 || $n == 5} {
.b move dot${die}_[incr dot] $mx2 $mx2
}
}
set x $sz(die$die,x) ;# Where to put it
if {$state(turn) == $board(direction)} { set x [expr $x + $sz(die,xshift)]}
movepip_xy die$die $x $sz(die$die,y)
##.b bind die <Double-Button-1> "my_button move"
}
#################################################################
#
# makepip (who id)
#
# Makes a new pip with tag ID. If who is positive
# then we create a white pip, else maroon.
#
proc makepip {who id} {
global sz tkfibs
if {$who < 0} {set c b} {set c w} ;# White or black
set shadow [.b create oval 0 0 $sz(pipsize) $sz(pipsize) \
-fill $tkfibs(color,${c}_shadow) \
-tag "${c}_shadow ${c}pip pip $id s$id"]
.b move $shadow $sz(sx) 0
.b create oval 0 0 $sz(pipsize) $sz(pipsize) \
-fill $tkfibs(color,${c}pip) -tag "${c}pip pip $id p$id"
}
#################################################################
#
# movepip_xy (id x y)
#
# Moves canvas item ID to absolute location x,y. If we are
# moving a pip then we want to center w/o its shadow.
#
proc movepip_xy {id x y {verbose {}}} {
global sz tkfibs ;# Size of everything
if {$x < $sz(bl_pip) || $x > $sz(br_pip) || \
$y < $sz(bt_pip) || $y > $sz(bb_pip)} {
return
}
set where [.b coord p$id] ;# Get center of pip itself
if {$where == {}} { set where [.b coord $id] };# Default to whole item
set dx [expr $x - [lindex $where 0] - $sz(ps2)]
set dy [expr $y - [lindex $where 1] - $sz(ps2)]
.b move $id $dx $dy ;# Position the pip
.b raise $id ;# Make it visible
}
#################################################################
#
# movepip2_xy (id id2 x y)
#
# Like movepip_xy but for two pips
#
proc movepip2_xy {id id2 x y} {
global sz
movepip_xy $id $x $y ;# Move this one first
movepip_xy $id2 $x [expr $y + $sz(pipsize)] ;# And this one next
}
#################################################################
#
# assign_pips
#
# Assigns pips (pip1-pip15) and (pip-1-pip-15) to the positions on the
# board. Board(##,men) is set in decode_board() so we must updaate
# board(##,who).
#
proc assign_pips {} {
global board
set w 0
set b 0
set pos {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
lappend pos barw barb homew homeb
foreach i $pos {
set board($i,who) {} ;# Erase all men here
if {$board($i,men) == 0} continue ;# Empty position
if {$board($i,men) < 0} { ;# Place the black men
for {set j 0} {$j > $board($i,men)} {incr j -1} {
lappend board($i,who) [incr b -1]
}
} else { ;# Place the white men
for {set j 0} {$j < $board($i,men)} {incr j +1} {
lappend board($i,who) [incr w +1]
}
}
}
if {$w != 15 || $b != -15} { ;# Sanity check
puts "ERROR: assign pips w $w, b $b"
return 1
}
return 0
}
#################################################################
#
# stack_position pos
#
# Displays pips at location POS. This is where pips are first
# created. If we have more than 5 pips then we layer the pips.
#
proc stack_position {pos} {
global board sz
set men [expr abs($board($pos,men))] ;# How many pips here
for {set i 0} {$i < $men} {incr i} {
set who [lindex $board($pos,who) $i] ;# Which pip belongs here
set id pip$who ;# ID of pip
if {[.b find withtag $id] == {}} { ;# Does pip exist?
makepip $who $id
}
set row [expr $i % 5] ;# Position in this layer
set layer [expr $i / 5] ;# Which layer
set x $board($pos,x) ;# Get x,y of pip position
set y [expr $row*$sz(pipsize) + $sz(pipsize)*0.2*$layer]
if {$board($pos,y) > $sz(bc2)} { ;# See if it goes at bottom
set y [expr -$y]
}
set y [expr $board($pos,y) + $y]
movepip_xy $id $x $y yes ;# Position the pip
}
}
#################################################################
#
# draw_pips ()
#
# Draws all the pips. If a pip doesn't exist yet, this
# will create it.
#
proc draw_pips {} {
global state
set pos {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
lappend pos barw barb homew homeb
foreach p $pos {
stack_position $p
}
}
#################################################################
#
# XY2pos
#
# Determines which board position is closest to x,y
#
proc XY2pos {x y {key {}}} {
global sz
global board ;# Holds board coordinates
set minx 99999 ;# Bigger than the board
if [string match $key "tight"] { ;# Must be close to triangle
set t [expr $sz(th) + $sz(ps2)] ;# Just how close
if {$y > [expr $sz(bt)+$t] && $y < [expr $sz(bb)-$t]} {
return bad ;# Too far away
}
}
#
# Find which X position it is in
#
foreach i {1 2 3 4 5 6 7 8 9 10 11 12 bar homel homer} {;# All x positions
set dx [expr abs($board($i,x) - $x)] ;# How far away
if {$dx < $minx} { ;# Is it closer?
set minx $dx
set who $i
}
}
#
# Now check which side its on
#
if [string match $who "bar"] { ;# Bar is weird
set who bar$board(ocolor) ;# Assume top half
if {$y > $sz(bc2)} { ;# Bottom half
set who bar$board(color)
}
} elseif {$who == "homel" || $who == "homer"} {;# Home is weirder
set who home$board(ocolor) ;# Assume top half
if {$y > $sz(bc2)} { ;# Bottom half
set who home$board(color)
}
} else { ;# Normal positioning
set dy [expr abs($y - $board($who,y))] ;# Distance from 1-12
set other [expr 25 - $who] ;# Other side of the board
set dy2 [expr abs($y - $board($other,y))];# Distance from 13-24
if {$dy2 < $dy} {
set who $other ;# 13-24 is closer
}
}
return $who
}
#################################################################
#
# pippick (x y)
#
# Here when we picked a pip to move. Find which position we're
# in, set the last guy at that position to be the one to be
# move (curpip) and update the board info for that position.
#
proc pippick {x y {check 1}} {
global curpip ;# Pip moved by the mouse
global board ;# Board state information
global state ;# State of the world
set pos [XY2pos $x $y tight] ;# Find source position
set id [movepip_from $pos] ;# Find who to move
set curpip(id) $id ;# Save globally for pipmove
set curpip(source) $pos
if {$id != "bad"} { ;# Legitimate pip?
set color [whatcolor [string range $id 3 end]];# Color of the pip
if {$state(setup) || $color == $board(color) || ! $check} {
pipmove $x $y
} else { ;# Opponent pip
movepip_to $curpip(id) $pos ;# Yep, put him back
unset curpip
return bad
}
} else { ;# No pips here
unset curpip
return bad
}
do_cursor mouse
return yes
}
#################################################################
#
# pipmove (x y)
#
# Moves the current pip to the mouse position. The current pip
# is set in pippick.
#
proc pipmove {x y} {
global curpip state
if {$state(speed) != "fast"} return
if {[info exist curpip] == 0} return
movepip_xy $curpip(id) $x $y
}
#################################################################
#
# pipdrop (x y)
#
# Here when let go. We must put the pip into the new board
# position.
#
proc pipdrop {x y {check 1}} {
global curpip board state tkfibs
if {[info exist curpip] == 0} return ;# Just be safe
set pipcolor [whatcolor $curpip(id)]
set pos bad
if {$x != -1} {
set pos [XY2pos $x $y] ;# Destination position
}
set p [string index $pos 0] ;# Check for home/bar moves
if [string match $p "b"] { set pos bar[whatcolor $curpip(id)]
} elseif [string match $p "h"] { set pos home[whatcolor $curpip(id)] }
set r {} ;# Assume no legality check
if {$check && ! $state(setup)} {
set r [check_move $curpip(id) $curpip(source) $pos];# Check legality
}
if [string match $r "bad"] { ;# Error, bad move
movepip_to $curpip(id) $curpip(source) ;# Rollback the move
} else {
foreach m $r { ;# For each component
do_move $curpip(id) [lindex $m 0] [lindex $m 1] [lindex $m 2]
}
set r [movepip_to $curpip(id) $pos] ;# Move to destination
if [string match $r "bad"] {
movepip_to $curpip(id) $curpip(source);# Rollback the move
}
}
do_cursor
unset curpip
numbers
}
#################################################################
#
# piphome
#
# Bound to the double-click, moves pip from mouse position
# to the home board
#
proc piphome {x y} {
global board curpip state
pippick $x $y ;# Pick up the piece
;#pipdrop $board(homeb,x) $board(homeb,y)
set to [expr $curpip(source) - $state(d1)]
if {$state(d1) == 0 || $to <= 0} { set newpos homeb }
pipdrop $board($to,x) $board($to,y)
}
#################################################################
#
# movepip_to
#
# Puts pip ID into board array at position POS
#
# Returns: bad if not legal
# blot if we hit a blot
# id otherwise
#
proc movepip_to {id pos} {
global board ;# Holds board stat info
set colorv(w) 1
set colorv(b) -1
set result $id ;# What we return
if {$id == "bad" || $pos == "bad"} { return bad };# Test for valid input
set who [string range $id 3 end] ;# Raw pip number
set c1 [whatcolor $who] ;# Color of ID
set c2 [whatcolor $board($pos,men)] ;# Color of destination
if {$c2 != 0 && $c1 != $c2} { ;# Place is occupied
if {$board($pos,men) != $colorv($c2)} { ;# Not a blot
return bad
}
#
# Hit a blot, so we must move it to the bar
#
set blot_id [movepip_from $pos] ;# Move the blot from here
incr board(bar$c2,men) $colorv($c2) ;# ...to the bar
lappend board(bar$c2,who) [string range $blot_id 3 end]
stack_position bar$c2 ;# Display bar
set result blot
}
incr board($pos,men) $colorv($c1) ;# One more man here
lappend board($pos,who) $who ;# Who that man is
stack_position $pos ;# Display it
return $result
}
#################################################################
#
# movepip_from (pos)
#
# Removes last pip from board at POS and returns its ID
#
proc movepip_from {pos} {
global board
if {$pos == "bad" || $board($pos,men) == 0} {;# Nothing to move
return bad
}
if {$board($pos,men) < 0} { ;# Black men here
incr board($pos,men) 1 ;# One less man here
} else {
incr board($pos,men) -1 ;# One less man here
}
set count [expr abs($board($pos,men))]
set id pip[lindex $board($pos,who) $count] ;# Who to move
set board($pos,who) [lrange $board($pos,who) 0 [expr $count - 1]]
return $id
}
#################################################################
#
# movepip (from to)
#
# Moves a pip from FROM to TO
#
proc movepip {from to} {
set id [movepip_from $from] ;# Who to move
set id2 [movepip_to $id $to] ;# Place in at destination
if [string match $id2 "bad"] { set id $id2 }
return $id
}
#################################################################
#
# whatcolor (n number?)
#
# Returns what color/number number N is.
#
proc whatcolor {value {num no}} {
set r [set rn 0] ;# Default to nothing
if [string match [string range $value 0 0] "p"] {;# Is it in pip## format?
set value [string range $value 3 end]
}
if {$value > 0} { set r w ; set rn 1 }
if {$value < 0} { set r b ; set rn -1 }
if {$num != "no"} { return $rn }
return $r
}
#################################################################
#
# setcolor dir update
#
# Sets the color we are playing. If UPDATE is true
# then we update the visual display.
#
proc setcolor {{dir 0} {update no}} {
global board tkfibs
set olddir 0
if [info exist board(direction)] { set olddir $board(direction) }
if {$dir == 0} {
set dir $board(direction) ;# Use current board direction
}
set board(direction) $dir ;# Set the new direction
set board(color) [whatcolor $dir] ;# Our color
set board(color2) $tkfibs(color,$board(color)pip);# Our color on the board
set board(ocolor) [whatcolor [expr -$dir]] ;# Opponent's color
set board(ocolor2) $tkfibs(color,$board(ocolor)pip);# Opp color on board
#
# Here to swap board positions that change on reversal
# of color
#
if {$dir != $olddir} { ;# Different color
if {[info exist board(homel,x)] == 0} return;# Board not drawn yet
place_homebar ;# Reposition home & bar
foreach p { 1 2 3 4 5 6 7 8 9 10 11 12} {;# Reposition triangles
set other [expr $p + 12] ;# Who to swap with
set x $board($p,x) ;# Swap X positions
set board($p,x) $board($other,x)
set board($other,x) $x
set y $board($p,y) ;# Swap Y positions
set board($p,y) $board($other,y)
set board($other,y) $y
}
numbers 0 ;# Redo numbering
numbers 1
}
if {$update} { ;# Should we redisplay?
draw_pips
draw_dcube
frills
}
}
#################################################################
#
# init_state
#
# Sets up all the state variables to sane values
#
proc init_state {} {
global state
set state(ss) SendSocket ;# Assume we have sockets
set state(os) OpenSocket
set state(cs) CloseSocket
set state(speed) fast ;# Assume fast machine
set state(old_width) 0 ;# For resizing
set state(old_height) 0
set state(animating) 0 ;# TRUE when animating moves
if {[info commands SendSocket] != "SendSocket"} {
set state(ss) vputs ;# Debug, use puts instead
set state(os) vputs
set state(cs) vputs
}
set state(setup) 0 ;# Enable check_move
set state(history) "" ;# No history yet
set state(history,where) 0
set state(old_opp) "" ;# To detect opponent changing
set init board:Yourself:Opponent:0:0:0:
append init 0:-2:0:0:0:0:5:0:3:0:0:0:-5:5:0:0:0:-3:0:-5:0:0:0:0:2:0:
append init 1:5:6:0:0:1:1:1:0:1:-1:0:25:0:0:0:0:2:0:0:0
decode_board $init
}
#################################################################
#
# update_board
#
# Takes data from FIBS, has it parsed then update the screen.
#
# Value: 0 ok (same as decode_board)
# 1 bad format
# 2 incomplete board
#
proc update_board {{b last}} {
global board state tkfibs
if [info exist state(show_board)] { ;# Debugging
display "Update_board: $b\n"
unset state(show_board)
}
if $state(animating) { ;# No update while animating
set state(pending) $b
return 0
}
pipdrop -1 -1 ;# Turn off any pip dragging
set state(pending) {}
set code [decode_board $b] ;# Parse the board
if {$code == "2"} { ;# Incomplete
decode_board $state(last) ;# Back to a normal state
}
if {$code != "0"} { return $code }
draw_pips ;# Pips may have moved
draw_dcube ;# New double cube
if {$state(die1) != 0} { ;# My turn
draw_dice $state(die1) $state(die2)
} elseif {$state(opp_die1) != 0} { ;# Opponents turn
draw_dice $state(opp_die1) $state(opp_die2)
set state(d1) [set state(d2) [set state(d3) [set state(d4) 0]]]
} else { draw_dice }
do_cursor
frills
record_move
numbers
return 0
}
#################################################################
#
# decode_board
#
# Parses the board data sent by Fibs. It doesn't have any
# visual affects--that's done by update board.
#
# Value: 0 ok
# 1 bad format
# 2 incomplete
#
proc decode_board b {
global board state
if [string match $b "last"] { set b $state(last) }
set save $b
set b [split $b :] ;# Break into a list
if {[string compare [lindex $b 0] "board"]} { ;# Bad format
return 1
}
if {[llength $b] != 53} { return 2 } ;# Too short
set state(my_name) [lindex $b 1] ;# My name
set state(opp_name) [lindex $b 2] ;# Opponent's name
set state(match_length) [lindex $b 3] ;# Match length
set state(my_score) [lindex $b 4] ;# My score
set state(opp_score) [lindex $b 5] ;# Opponent's score
for {set pos 0} {$pos < 26} {incr pos} { ;# Board data
set board($pos,men) [lindex $b [expr 6 + $pos]]
}
set state(turn) [lindex $b 32] ;# Whose turn it is
set state(die1) [lindex $b 33] ;# My dice
set state(die2) [lindex $b 34]
set state(opp_die1) [lindex $b 35] ;# Opponent's dice
set state(opp_die2) [lindex $b 36]
set state(dcube) [lindex $b 37] ;# Double cube
set state(i_may_double) [lindex $b 38] ;# Who owns doubling cube
set state(opp_may_double) [lindex $b 39]
set state(was_doubled) [lindex $b 40] ;# Were we asked about doubles
set state(color) [lindex $b 41] ;# What color are we
set m [whatcolor $state(color)]
set o [whatcolor [expr -$state(color)]]
set state(direction) [lindex $b 42] ;# Board direction
set state(home) [lindex $b 43] ;# Where home is (0 or 25)
set state(bar) [lindex $b 44] ;# Where bar is (0 or 25)
set board(home$m,men) [lindex $b 45] ;# Player-on-home
set board(home$o,men) [lindex $b 46] ;# Opp-on-home
set board(bar$m,men) [lindex $b 47] ;# Player-on-bar
set board(bar$o,men) [lindex $b 48] ;# Opp-on-bar
set board(barb,men) [expr -$board(barb,men)]
set board(homeb,men) [expr -$board(homeb,men)]
set state(can_move) [lindex $b 49] ;# How many pieces I can move
set state(forced_move) [lindex $b 50] ;# obsolete
set state(did_crawford) [lindex $b 51] ;# obsolete
set state(max_redoubles) [lindex $b 52] ;# for unlimited games
#
# Now update non-visual aspects
#
setcolor $state(color)
if [assign_pips] { ;# Attach pips to positions
puts " prev: $state(last)" ;# ERROR
puts " curr: $b"
}
set state(move) {} ;# Erase potential moves
set state(undo) {}
set state(i_can_roll) [expr {$state(turn) == $state(color) &&
$state(die1) == 0 && $state(die2) == 0}]
set state(last) $save ;# Save last position
return 0
}
#################################################################
#
# frills
#
# Displays non-graphical information: players names, score, etc.
#
proc frills {} {
global state board f tkfibs
set enable(0) disabled
set enable(1) normal
#
# Now fill in the details
#
set pip [pipcount]
set f(opp) "$state(opp_score)-$state(opp_name) [lindex $pip 0]"
set f(me) "$state(my_score)-$state(my_name) [lindex $pip 1]"
.c_opp itemconfig opp_pip -fill $board(ocolor2)
.c_me itemconfig me_pip -fill $board(color2)
set f(match) " $state(match_length)-point match "
if {$state(match_length) == 9999} {
set f(match) " unlimited match "
}
if [string compare $state(opp_name) $state(old_opp)] {
set tkfibs(rating) "?"
set state(old_opp) $state(opp_name)
}
if $tkfibs(ratings) {
set f(rating) "Rating: $tkfibs(rating) "
} else { set f(rating) "" }
set f(move) "Move: $state(move)"
set t [expr {$state(i_can_roll) && $state(i_may_double)}]
.ff.f2.bdouble config -state $enable($t)
.ff.f2.broll config -state $enable($state(i_can_roll))
}
#################################################################
#
# draw_frills
#
# Draws all the boxes, labels, etc that make up the top of the board.
#
proc draw_frills {} {
global tkfibs sz
set color $tkfibs(color,bg) ;# Color to use
. config -bg $color ;# Set the color and title
wm title . $tkfibs(title)
;#
;# Buttons in the frills area
;#
frame .ff -bg $color
pack .ff -in .frills -side right -fill y
button .ff.b1 -text "Submit\nMove" -command "my_button move" -bd 4
pack .ff.b1 -side right -padx 2m -pady 2m -fill y
frame .ff.f2 -bg $color ;# Roll and double
button .ff.f2.broll -text Roll -command "my_button roll"
button .ff.f2.bdouble -text Double -command "my_button double"
pack .ff.f2 -side right -fill y -padx 1m
pack .ff.f2.broll .ff.f2.bdouble -side top -expand 1 -fill x
frame .ff.f3 -bg $color ;# Undo and backup
button .ff.f3.bundo -text Undo -command "my_button undo"
button .ff.f3.bbackup -text Backup -command "my_button backup"
pack .ff.f3 -side right -fill y -padx 1m
pack .ff.f3.bundo .ff.f3.bbackup -side top -expand 1 -fill x
;#
;# Text in the frills area
;#
frame .f -bg $color -bd 3 -relief ridge ;# Various text info
frame .ftop -bg $color
canvas .c_opp -bg $color -width $sz(f_ps) -height $sz(f_ps)
.c_opp create oval 2 2 $sz(f_ps) $sz(f_ps) -tag opp_pip
label .opp -bg $color -textvariable f(opp)
label .me -bg $color -textvariable f(me)
canvas .c_me -bg $color -width $sz(f_ps) -height $sz(f_ps)
.c_me create oval 2 2 $sz(f_ps) $sz(f_ps) -tag me_pip
label .match -bg $color -textvariable f(match)
label .rating -bg $color -textvariable f(rating)
label .move -bg $color -textvariable f(move) -anchor w -bd 3 -relief ridge
pack .f -in .frills -side left ;# Pack everything in
pack .move -in .f -side bottom -fill x
pack .ftop -in .f -side top -fill x
pack .c_opp -in .ftop -side left -padx 3
pack .opp -in .ftop -side left
pack .rating -in .ftop -side right -expand 1
pack .match -in .f -side right
pack .c_me -in .f -side left -padx 3
pack .me -in .f -side left
}
#######################################################################
#
# my_button cmd
#
# Handles the various button presses
#
proc my_button cmd {
global state
switch $cmd {
undo { undo_move }
move { submit_move }
backup { after 1 update_board } ;# Use AFTER for better flash
double { display2 doubling... ; draw_dcube -1 ; FIBS double\n }
default {
FIBS ${cmd}\n
}
}
}
#################################################################
#
# do_move
#
# Processes the global affects of moving FROM - TO.
# 1) any blots hit
# 2) undo information
#
proc do_move {id from to die} {
global state board
set state(undo) [linsert $state(undo) 0 $from $to $die]
record_move $from $to
if {$board($to,men) == -[whatcolor $id yes]} {;# A blot
set blot_id [movepip_from $to] ;# Get the blot
movepip_to $blot_id bar[whatcolor $blot_id];# Move it to its bar
set state(undo) [linsert $state(undo) 0 blot]
}
}
#######################################################################
#
# record_move (from to)
#
# Records the move for 1) display, and 2) later sending to FIBS
#
proc record_move {{from {}} {to {}}} {
global state tkfibs f
if {$from != {}} {
if {$to == "barw" || $to == "barb"} {
set to b
} elseif {$to == "homew" || $to == "homeb"} {
set to h
}
if {$from == "barw" || $from == "barb" || $from < 1 || $from > 24} {
set from b
} elseif {$from == "homew" || $from == "homeb"} {
set from h
}
lappend state(move) "$from-$to"
}
set co [lindex [.move config -fg] 3] ;# Default color
set n [llength $state(move)]
if {$n == $state(can_move) && $n > 0} { ;# No more moves possible?
set co $tkfibs(color,fullmove) ;# Use this color instead
}
set f(move) "Move: $state(move)"
.move config -fg $co
if {$state(undo) != {}} { ;# Update button display
.ff.b1 config -state normal
.ff.f3.bundo config -state normal
} else {
.ff.b1 config -state disabled
.ff.f3.bundo config -state disabled
}
}
#######################################################################
#
# undo_move
#
# Backs up one move from the move list
#
proc undo_move {} {
global state board
set blot 0 ;# Does this involve a blot?
set l [expr [llength $state(move)] - 1] ;# Length of move list
if {$state(undo) != {}} { ;# Any moves?
set from [lindex $state(undo) 0] ;# FROM to undo
if [string match $from "blot"] {
set blot 1
set state(undo) [lrange $state(undo) 1 end]
set from [lindex $state(undo) 0]
}
set to [lindex $state(undo) 1]
set die [lindex $state(undo) 2]
set state(undo) [lrange $state(undo) 3 end]
set state(move) [lrange $state(move) 0 [expr [llength $state(move)]-2]]
if [string match $from "b"] { set from bar$board(color) }
if [string match $from "h"] { set from home$board(color) }
if [string match $to "b"] { set to bar$board(color) }
if [string match $to "h"] { set to home$board(color) }
movepip $to $from
if $blot { ;# Blot also??
movepip bar$board(ocolor) $to
}
record_move ;# Update the display
rotate_dice [expr -$die]
}
if {$state(undo) != {}} { ;# Update button display
## .ff.b1 config -state normal
## .ff.f3.bundo config -state normal
.ff.b1 config -state normal
.ff.f3.bundo config -state normal
} else {
.ff.b1 config -state disabled
.ff.f3.bundo config -state disabled
}
}
#######################################################################
#
# submit_move
#
# Takes the accumulated moves and submits it to fibs over
# the socket.
#
proc submit_move {} {
global state
if {$state(move) != {} } { ;# Are there moves to do?
set cmd "move $state(move)\n"
FIBS $cmd ;# Execute it
}
set state(move) {} ;# Reset the moves
set state(undo) {} ;# Reset undo of moves
record_move ;# Update the display
}
#######################################################################
#
# do_cursor
#
# Turns the cursor into a watch when it's not our turn. Also when
# we're moving a pip, turn the cursor into a dot.
#
proc do_cursor {{mousing no}} {
global state board tkfibs
if {[whatcolor $state(turn)] != $board(color)} {;# Not my turn
##. config -cursor watch ;# Show the watch
.b config -cursor watch
} elseif {$mousing != "no"} { ;# It is our turn
##. config -cursor dot ;# Mouse moving a pip
.b config -cursor dot
} else {
##. config -cursor {}
.b config -cursor fleur
}
}
#######################################################################
#
# resize_board
#
# Resizes the playing field
#
proc resize_board {ps} {
set_size $ps ;# Update board dimensions
.b delete pip dcube ;# Delete to force redraw
draw_board ;# Redraw the board
draw_pips ;# ... and the pips
}
#######################################################################
#
# resize_all
#
# Resizes the display including board and frills. Note, we want to keep
# the frills area constant size
#
proc resize_all {W w h {ignore 0}} {
global sz state ;# Get old size of pip
if {$W != "."} return ;# Skip child configurations
if { ! $ignore } {
if {$w == $state(old_width) && $h == $state(old_height)} return
}
set fh [winfo reqheight .frills ] ;# Height of frills display
set fw [winfo reqwidth .frills ] ;# Width of frills display
set min_pip [expr int(($fw / 20.4) + -4)] ;# Smallest pip allowed
set ps1 [expr round($w / 20.4)] ;# New pipsize based on width
set ps2 [expr round(($h-$fh) / 12.6)] ;# ... based on height
set ps [expr ($ps1 < $ps2 ? $ps1 : $ps2)] ;# Use the smaller
if {$ps < $min_pip} {set ps $min_pip}
set w [expr int($ps * 20.4 + 1)] ;# New window width
set h [expr int($ps * 12.6 + $fh + 1)] ;# New window height
if {! $ignore} {
set cmd [bind . <Configure>] ;# Unbind to avoid recursion
bind . <Configure> {}
set state(old_width) $w ;# So we don't repeat ourselves
set state(old_height) $h
if {$ps != $sz(pipsize)} { ;# Resize the board
resize_board $ps
}
if {$ps != $ps1 || $ps != $ps2} { ;# Did size of window change?
wm geometry . ${w}x$h ;# Resize the window
}
update
bind . <Configure> $cmd
}
return "$w $h"
}
#######################################################################
#
# draw_menus
#
# Displays the menus on the screen
#
proc draw_menus {} {
global tkfibs state
#
# All the menus
#
set menu(0) {&Game &Connect &Disconnect - &Quit - &About}
set menu(1) {&Toggle Allowpip Autoboard Autodouble &Automove Bell Crawford
&Double &Greedy &Moreboards Moves &Notify Ratings &Ready Re&port
&Silent Wrap}
set menu(2) {&Resign &Normal &Gammon &Backgammon}
set menu(3) {&Show &Games &Saved &Watchers &Max}
set menu(4) {&Opponent &Oldmoves &Rating W&here &Whois}
set menu(5) {&Misc &Board &Off &Rating &Who "W&ho ready"
- {&Setup c state} {&Numbers c tkfibs} {Ratings c tkfibs}
{&Pipcount c tkfibs} {&Animate c tkfibs}}
set menu(6) {&Windows {&Kibitz c tkfibs}}
set c $tkfibs(color,menu)
foreach w [winfo children .m] { ;# Destroy what's out there
catch { destroy $w }
}
.m config -bg $c -bd 3 -relief ridge ;# Configure its window
for {set i 0} {[info exist menu($i)]} {incr i} {
set who [lindex $menu($i) 0] ;# Name of the menu button
set u [string first & $who] ;# Where to underline it
regsub {&} $who "" who ;# Name w/o underline mark
menubutton .m.m$i -text $who -menu .m.m$i.m -padx 5 -bg $c \
-underline $u -relief raised
pack .m.m$i -side left ;# Display it
menu .m.m$i.m -bg $c ;# Menu that hangs off it
set checks {Setup Numbers Pipcount Animate}
foreach item [lrange $menu($i) 1 end] { ;# Add sub-commands
set check 0
if {[llength $item] == 3} { ;# Check box item
set check [lindex $item 2]
set item [lindex $item 0]
}
set u [string first & $item] ;# Where to underline menu entry
regsub {&} $item "" item ;# Name w/o underline mark
if [string match $item "-"] { ;# Separator entry
.m.m$i.m add separator
} elseif {$check != 0} { ;# Check box entry
set item2 [string tolower $item]
.m.m$i.m add check -label $item -u $u \
-variable ${check}($item2) -command "do_menu $who $item"
} else { ;# Normal entry
.m.m$i.m add command -label $item -underline $u \
-command "do_menu $who $item"
}
}
}
}
#######################################################################
#
# do_menu
#
# Process the menu commands
#
proc do_menu {cmd option args} {
global state tkfibs
set Setup(1) "Disabling move checking.\n"
set Setup(0) "Enabling move checking.\n"
set Numbers(1) "Displaying board positions.\n"
set Numbers(0) "Won't show board positions.\n"
set Pip(1) "Will show pipcount with player's name.\n"
set Pip(0) "Won't show pipcount with player's name.\n"
set Animate(1) "Will animate movement of opponents pieces.\n"
set Animate(0) "Won't animate movement of opponents pieces.\n"
set Rating(1) "Will show player's rating.\n"
set Rating(0) "Won't show player's rating.\n"
set option [string tolower $option] ;# Lowercase the arguments
switch $cmd {
Game {
switch $option {
connect { $state(os) FIBS }
disconnect { $state(cs) }
quit { if {![close_socket2 quit]} {FIBS quit ; destroy .} }
about { about }
default { FIBS ${option}\n }
}
}
Toggle { FIBS "toggle ${option}\n" }
Resign { FIBS "resign ${option}\n" }
Show { FIBS "show ${option}\n" }
Opponent { FIBS "${option} $state(opp_name)\n" }
Misc {
switch $option {
setup { display $Setup($state(setup)) }
numbers { numbers 1; display $Numbers($tkfibs(numbers)) }
pipcount { display $Pip($tkfibs(pipcount)) ; frills }
animate { display $Animate($tkfibs(animate)) }
ratings { display $Rating($tkfibs(ratings)) ; frills }
default { FIBS "${option} ${args}\n" }
}
}
Windows { show_$option $tkfibs($option) }
}
}
#######################################################################
#
# pipcount
#
# Determines the pipcount for the current board
#
proc pipcount {{show {}}} {
global board state tkfibs
if {! $tkfibs(pipcount)} { return "" }
set o_pip [set x_pip 0] ;# Initialize
set pos {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
foreach p $pos {
if {$boar
