#!/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) 1996 Keith P. Vetter
#
# TkFibs is a graphical front-end to the FIBS backgammon server
# located at 134.130.130.46, port 8765.  It is written in version
# tcl version 7.1 and tk version 3.4, with a C front end.
#
# As of 12/6/93 FIBS has moved to 129.16.235.153 port 4321.
# As of 6/96 FIBS has moved to 205.149.189.55 port 4321 (fibs.com).
#
# This is the socket part of the program. It opens up a socket to FIBS.
# It manages all the reading and writing to the socket, plus parsing the
# data stream back from FIBS. It loads tkfibs.tcl for the GUI.
#
if {[info tclversion] < 7.5} {
    puts stdout ""
    puts stdout "You need TCL version 7.5 for this program."
    puts stdout ""
    exit
}

set FIBS_host 207.155.180.4			;# Where FIBS lives today
set FIBS_port 4321

##+##########################################################################
#
# SocketHandler
#
# Reads from socket, then calls routine to parse the data.
# Called by the file event dispatcher.
#
proc SocketHandler {} {
    global fibs buff parse

    fileevent $fibs readable {}			;# Turn off for now

    while (1) {
	set buff [read $fibs]			;# Read in the data

	if {[string compare $buff ""] == 0} {	;# Blocked or eof
	    if [eof $fibs] {			;# End of file???
		catch {close $fibs}
		set fibs ""
		close_socket close		;# Ask to leave program
		return
	    }
	    break				;# Just blocked
	}
	if [string compare $parse(log) ""] {
	    catch {puts $parse(log) $buff}	;# Write to log file
	}
	set parse(time) [clock seconds]		;# Record when this happened
	parse_lines $buff			;# Parse through the data
    }

    fileevent $fibs readable SocketHandler	;# Turn back on
}
##+##########################################################################
#
# SendSocket
#
# Writes data out to the socket. No flushing is needed since we've
# turned off buffering with fconfigure.
#
proc SendSocket {args} {
    global fibs

    if [string match $fibs ""] return
    set args [join $args " "]			;# Make one long string
    puts $fibs $args				;# Send it along
}
##+##########################################################################
#
# OpenSocket
#
# Opens connection to FIBS.
#
# On an error, we return the error message, otherwise the empty string
#
proc OpenSocket {args} {
    global fibs FIBS_host FIBS_port

    if {$fibs != ""} {				;# Already open???
	if [close_socket2] {return ""}		;# Really close it
    }
    catch {close $fibs}				;# Close it up
    set fibs ""

    ;# Open socket to FIBS
    set n [catch {set fibs [socket $FIBS_host $FIBS_port]} err]
    if {$n} {return $err}

    fconfigure $fibs -blocking 0 -buffering none
    fileevent $fibs readable SocketHandler
    return ""
}
##+##########################################################################
#
# CloseSocket
#
# Closes socket. Called by tkfibs.tcl.
#
proc CloseSocket {} {
    global fibs

    if {$fibs == ""} {
	display2 Not currently connected to fibs
	return
    }

    if [close_socket2] return			;# Ask user to confirm
    catch {close $fibs}
    set fibs ""
}
##+##########################################################################
#
# logging
#
# Toggles the state of logging
#
proc logging {} {
    global parse

    if [string compare $parse(log) ""] {	;# Already open
	puts "closing log file"
	catch {close $parse(log)}
	set parse(log) ""
    } else {
	puts "opening log file"
	catch {
	    set parse(log) [open tkfibs.log a]	;# Append to log file
	    fconfigure $parse(log) -buffering none;# Turn off buffering
	}
    }
}
##+##########################################################################
# 
# status
# 
# Returns debugging info on the connection to fibs
# 
proc status {} {
    global parse fibs

    set msg "last read [expr [clock seconds] - $parse(time)]\n"
    append msg "fibs is $fibs\n"
    catch {append msg "eof is [eof $fibs] \n"}
    catch {append msg "fileevent is [fileevent $fibs readable]\n"}
    display $msg
}
##+##########################################################################
#
# lookup
#
# Looks up commands which we treat specially. Put inline for speed.
#
proc lookup line {
    global state
    if [regexp "^login:" $line]			               {return 0}
    if [regexp "^password:" $line]		               {return 1}
    if [regexp "^board:" $line]			               {return 2}
    if [regexp "Type 'accept'" $line]		               {return 3}
    if [regexp "^> " $line]			               {return 4}
    if [regexp "^Type 'join' if you want" $line]               {return 5}
    if [regexp "ype 'join " $line]		               {return 6}
    if [regexp "^\\* You can't move" $line]	               {return 7}
    if [regexp "^\\* Please don't give more than" $line]       {return 7}
    if [regexp "^\\* You must give" $line]	               {return 7}
    if [regexp "^It's your turn. Please roll or double" $line] {return 8}
    if [regexp "^It's your turn to roll or double." $line]     {return 8}
    if [regexp "Your running match was loaded" $line]          {return 8}
    if [regexp "^You can't move" $line]		               {return 8}
    if [regexp "^\377\374\001" $line]		               {return 9}
    if [regexp "kibitz(es|)" $line]                            {return 10}
    if [regexp "whisper(s|)" $line]                            {return 10}

    if [info exists state(my_name)] {
	if [regexp "^$state(my_name) moves" $line]             {return 11}
	if [regexp "^$state(opp_name) moves" $line]            {return 11}
    }

    return -1
}
##+##########################################################################
#
# parse_lines
#
# Goes through each line read from FIBS. It looks to see if the
# line requires special action. If not, then it just displays it.
#
proc parse_lines buff {
    global parse

    set buff "$parse(pend)$buff"		;# Incomplete line from before
    set parse(pend) ""

    set complete [regexp \n$ $buff]		;# EOL on the last line
    set lines [split [string trimright $buff \n] \n]
    set nlines [expr [llength $lines] - 1]

    set cnt -1					;# Which line we're looking at
    foreach line $lines {
	incr cnt

	set eol 0
	if {$complete || $cnt < $nlines } {	;# Add eol to the line
	    append line \n
	    set eol 1
	}

	set n [lookup $line]			;# Lookup special keywords
    	switch -exact -- $n {
	    0 {					;# Login
		set parse(init) -1		;# Must reinitialize

		set login [login]		;# Get login and passwd
		if [string compare $login "**no**"] {
		    SendSocket [lindex $login 0]
		    set parse(passwd) [lindex $login 1]
		} else {
		    display $line
		}
	    }
	    1 {					;# Password
		if [string compare $parse(passwd) ""] {
		    SendSocket $parse(passwd)
		} else {
		    display $line
		}
	    }
	    2 {					;# Board command
		if {$eol} {
		    update_board $line
		} else {
		    set parse(pend) $line	;# Keep for next time in
		}
	    }
	    3 {					;# Accept
		display $line
		acceptor $line
	    }
	    4 {					;# Prompt
		if {$parse(init) == -1} {
		    SendSocket "set boardstyle 3";# Always this init
		    set parse(init) 0		;# Start the inits
		} elseif {$parse(init) != -2} {
		    set init [get_inits $parse(init)]
		    incr parse(init)
		    if [string compare $init "**no**"] {
			SendSocket $init
		    } else {
			set parse(init) -2
		    }
		}
	    }
	    5 {					;# Join1
		display $line
		joiner $line
	    }
	    6 {					;# Join2
		display $line
		joiner $parse(last)
	    }
	    7 {					;# Bad move 1-3
		update_board last
	    }
	    8 {					;# Roll, resume, can't move
		display $line
		SendSocket "board"
	    }
	    9 {					;# NULL cmd -- eat the line
	    }
	    10 {				;# Kibitz or whisper
		display_kibitz $line
	    }
	    11 {				;# My/opponent move command
		display $line
		animate_move $line
	    }
	    default {
		display $line
		set parse(last) $line
	    }
	}
    }
}

;# Commands which tkfibs.tcl defines
proc display args       { puts -nonewline [join $args] }
proc close_socket args  { puts "in close_socket: $args" }
proc close_socket2 args { puts "in close_socket2: $args" }
proc get_inits args     { puts "in get_inits: $args" ; return "**no**" }
proc login args         { puts "in login: $args" ; return "sracer recars" }

set parse(last) ""				;# Last line seen
set parse(pend) ""				;# Any unfinished board line
set parse(passwd) ""				;# Password to log in with
set parse(init) -1				;# Have done initialization
set parse(log) ""				;# File to log to
set parse(time) 0				;# Time of last read from FIBS
set fibs ""					;# Socket to FIBS

;# See if default host and port is to be overridden
if {$argc > 0} { set FIBS_host [lindex $argv 0] }
if {$argc > 1} { set FIBS_port [lindex $argv 1] }

;# Search out tkfibs.tcl file. First along path
set f_file [glob -nocomplain tkfibs.tcl]
if {$f_file == ""} {
    set f_file [glob -nocomplain [file join [file dirname $argv0] tkfibs.tcl]]
    if {$f_file == ""} {			;# Still not found
	puts stderr "Cannot locate tkfibs.tcl"
	exit 1
    }
}

source $f_file					;# Source tkfibs.tcl
display2 Connecting to FIBS...
update
set err [OpenSocket]				;# Open connection to fibs
if {$err != ""} {
    close_socket connect $err			;# Error on connecting
}
