/* Copyright (c) 1996--1999 Geoff Pike. */
/* All rights reserved. */

/* Floater is distributed in the hope that it will be useful, */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */

/* This software is provided "as is" and comes with absolutely no */
/* warranties.  Geoff Pike is not liable for damages under any */
/* circumstances.  Support is not provided.  Use at your own risk. */

/* Personal, non-commercial use is allowed.  Attempting to make money */
/* from Floater or products or code derived from Floater is not allowed */
/* without prior written consent from Geoff Pike.  Anything that remotely */
/* involves commercialism, including (but not limited to) systems that */
/* show advertisements while being used and systems that collect */
/* information on users that is later sold or traded require prior */
/* written consent from Geoff Pike. */
gset newstyle_matrix 0

proc redrawmatrixcards {} {}

proc togglepassedcard {suit card} {
    global togglepassedaction

    if [info exists togglepassedaction([string toupper $suit$card])] \
	    {catch $togglepassedaction([string toupper $suit$card])}
}

proc removecardfromhand {suit card} {
    global removecard

    if [info exists removecard([string toupper $suit$card])] \
	    {catch $removecard([string toupper $suit$card])}
}

#ifndef TEXT
proc tpcard {w} {
    // talkmsg "tpcard: $w"
    if ![string match *ello* [$w config -fg]] {
	$w config -fg yellow
	// talkmsg "tpcard: $w set to yellow"
    } else {
	$w config -fg black
	// talkmsg "tpcard: $w set to black"
    }
}
#endif

#ifdef TEXT
// remove a card from a player's hand
proc rmcard {x y suit card} {
    set f "$x $y"
    anchor $f
    set suit [string toupper $suit]
    if {$suit == "S"} {rmcard2 $f $suit $card} {down_and_anchor}
    if {$suit == "H"} {rmcard2 $f $suit $card} {down_and_anchor}
    if {$suit == "D"} {rmcard2 $f $suit $card} {down_and_anchor}
    if {$suit == "C"} {rmcard2 $f $suit $card}
}

proc rmcard2 {f suit card} {
    global cursuit

    right 2 // move over suit symbol and space
    set w [set "cursuit($f$suit)" [zap $card $cursuit($f$suit)]]
    str "$w "
}

// find the first occurence of char in text and remove it
proc zap {char text} {
    set i [string first $char $text]
    if {$i < 0} { // shouldn't happen
	return $text
    } elseif {$i == 0} {
	return [string range $text 1 end]
    } else {
	incr i -1
	set j [expr $i + 2]
	// this still works (empirically) if j is beyond the end of the string
	return "[string range $text 0 $i][string range $text $j end]"
    }
}
#endif    
  

// proc suit creates one row of buttons to show one suit on the screen
proc suit {f cards suit} {
#ifdef TEXT
    global cursuit removecard

    set suit [string toupper $suit]
    set cards [string toupper $cards]
    str "$suit $cards"
    down_and_anchor
    set "cursuit($f$suit)" $cards
    for {set i [expr [string length $cards] - 1]} {$i >= 0} {incr i -1} {
	set card [string index $cards $i]
	set removecard([string toupper $suit$card]) "rmcard $f $suit $card"
    }
#else
    global buttoncardoptions buttonsuitoptions removecard togglepassedaction

    set buttons {}
    for {set i [expr [string length $cards] - 1]} {$i >= 0} {incr i -1} {
	set card [string index $cards $i]
	set comm "-command \"command $suit$card\""
	set newbutton [eval "button $f.$suit.$suit$card \
		$buttoncardoptions -text $card $comm"]
	refont $newbutton cardfont
	set buttons [linsert $buttons 0 $newbutton]
	set removecard([string toupper $suit$card]) "destroy $newbutton"
	set togglepassedaction([string toupper $suit$card]) "tpcard $newbutton"
    }

//    if {$buttons == {}} {
//	set buttons [eval "label $f.$suit.void $buttoncardoptions -text -"]
//    }

    refont [eval "label $f.$suit.suit $buttonsuitoptions -text [$suit]"] suitfont
    eval "pack $f.$suit.suit $buttons -side left"
#endif
}

// proc hand creates the frames and buttons to show a hand on the screen
// f is a frame; s, d, h, and c are suit holdings
proc hand {f s h d c} {
#ifndef TEXT
    global framesuitoptions

    // either create the 5 frames or, if they exist, empty them out
    if [winfo exists $f.name] {
	foreach i {name s h d c} {
	    foreach child [winfo children $f.$i] {
		catch {destroy $child}
	    }
	}
    } else {
	catch {destroy $f.name $f.s $f.h $f.d $f.c}
	frame $f.name
	frame $f.s
	frame $f.h
	frame $f.d
	frame $f.c
	pack $f.name -side top -anchor w
	eval "pack $f.s $f.h $f.d $f.c -side top -anchor w $framesuitoptions"
    }
#else
    global handwidth
    anchor $f
    clearrect $handwidth 4
#endif
    suit $f $s s
    suit $f $h h
    suit $f $d d
    suit $f $c c 
}

#if 0
// proc hand creates the frames and buttons to show a hand on the screen
// f is a frame; s, d, h, and c are suit holdings
proc hand {f s h d c} {
#ifndef TEXT
    global framesuitoptions

    catch {destroy $f.name $f.s $f.h $f.d $f.c}
    frame $f.name
    frame $f.s
    frame $f.h
    frame $f.d
    frame $f.c
    pack $f.name -side top -anchor w
    eval "pack $f.s $f.h $f.d $f.c -side top -anchor w $framesuitoptions"
#else
    global handwidth
    anchor $f
    clearrect $handwidth 4
#endif
    suit $f $s s
    suit $f $h h
    suit $f $d d
    suit $f $c c 
}
#endif /* 0 */

#ifndef TEXT
// We want pack propagation off most of the time for .play
// But occasionally we'll turn it on for a little while to allow important
// changes to happen.  This is a disgusting hack.
proc prop_on {} {
//    pack prop .play true
//    after 250 pack prop .play false
//    after 2000 prop_on
}
#endif

// Show a full deal
// (this wrecks & rebuilds frames and whatnot, destroying any display of the
// players' names)
proc fulldeal {s h d c LHOs LHOh LHOd LHOc \
		   Ps Ph Pd Pc RHOs RHOh RHOd RHOc} {
    global mframe

    hand $mframe(self) $s $h $d $c
    hand $mframe(pard) $Ps $Ph $Pd $Pc
    hand $mframe(lho) $LHOs $LHOh $LHOd $LHOc
    hand $mframe(rho) $RHOs $RHOh $RHOd $RHOc
}

gset tricktimeOK 1

// causes tricktimeOK to be 0 for the next tricktime milliseconds
// tricktimeOK should be 1 when this is called
proc startshowtricktimer {} {
    global tricktime tricktimeOK

    set tricktimeOK 0
    after $tricktime set tricktimeOK 1
}

// this is for erasing the last trick 5 seconds after the double dummy
// display at the end of a hand
proc delayedclearmatrix {} {
    global needtoerase

    set needtoerase 1
    after 5000 clearmatrixtimer
}

proc clearmatrixtimer {} {
    global needtoerase

    if $needtoerase {erasebidplay all}
}

// Erase a bid or play from the matrix
// who should be lho, rho, pard, self, or all
proc erasebidplay {who} {
    global tricktimeOK

    while {!$tricktimeOK} {
	update
	after 100
    }
    if {$who == "all"} {
	global needtoerase

	set needtoerase 0
	erasebidplay lho
	erasebidplay rho
	erasebidplay pard
	erasebidplay self
    } else {
#ifdef TEXT
	global matrixtext
	
	anchor $matrixtext($who)
	clearrect 2 1
#else
	set path .play.middle.box.$who
	catch {pack forget $path.suit $path.card}
#endif
    }
}

// display (in the matrix) a card played
// suit is one of s, d, h, c
// card is one of 2 ... A
proc showplay {player suit card} {
#ifdef TEXT
    global matrixtext

    anchor $matrixtext($player)
    if {$suit == "?"} {
	str "? "
    } else {
	str $suit$card
    }
#else
    global cardfont suitfont

    set path .play.middle.box.$player
    catch {pack forget $path.suit $path.card} c
    if {$c != ""} {
	// something went wrong -- we must create suit and card buttons
	refont [label $path.suit -font $suitfont -borderwidth 0] suitfont
	refont [label $path.card -font $cardfont -borderwidth 0] cardfont
    }
    pack $path.suit $path.card -side left

    if {$suit != "?"} {
	eval "$path.suit configure -text [$suit] -font $suitfont"
	refont $path.suit suitfont
    } else {
	$path.suit configure -text ""
    }
    $path.card configure -text [string toupper $card]
#endif
}

// display (in the matrix) a card played
// level is in 1 ... 7
// strain is n, s, h, d, c, x, xx, or p
// (if strain is x, xx, or p, then level is ignored)
proc showbid {player level strain} {
//  debugmsg "showbid $player $level $strain"
#ifdef TEXT
    global matrixtext

    anchor $matrixtext($player)
    if {$strain == "-"} {
	str "  "
    } elseif {$strain == "?"} {
	str "? "
    } elseif {$level > 0} {
	str "$level$strain "
    } else {	
	str "$strain "
    }
#else
    drawbid .play.middle.box.$player $level $strain
#endif
}

#ifdef TEXT
proc drawbid {x y level strain} {
    global auctionx auctiony auctionbot

//  debugmsg "drawbid $x $y $level $strain"

    if {[expr $auctiony + $y + 2] <= $auctionbot} {
	anchor "[expr $auctionx + 1 + 4 * $x] [expr $auctiony + $y + 2]"

	// convert level & strain to a two character string
	if {$strain == "x"} {
	    set s "X "
	} elseif {$strain == "xx"} {
	    set s "XX"
	} elseif {$strain == "p"} {
	    set s "P "
	} elseif {$strain == "-"} {
	    set s "  "
	} elseif {$strain == "?"} {
	    set s "? "
	} else {
	    set s $level$strain
	}
	
	clearrect 2 1
	if {$s != "  "} {str [string toupper $s]}
    }
}
#else
proc drawbid {path level strain} {
    global NTtext NTfont cardfont suitfont \
	passtext passfont doubletext doublefont redoubletext redoublefont

//  debugmsg "drawbid $path $level $strain"

    catch {pack forget $path.suit $path.card} c
    if {$c != ""} {
	// something went wrong -- we must create strain and level buttons
	refont [label $path.suit -font $suitfont -borderwidth 0] suitfont
	refont [label $path.card -font $cardfont -borderwidth 0] cardfont
    }
    pack $path.card $path.suit -side left

    if {$strain == "n"} {
	$path.suit configure -text $NTtext -font $NTfont -fg black
	refont $path.suit NTfont
	$path.card configure -text $level
    } elseif {$strain == "x"} {
	$path.suit configure -text $doubletext -font $doublefont -fg red
	refont $path.suit doublefont
	$path.card configure -text ""
    } elseif {$strain == "xx"} {
	$path.suit configure -text $redoubletext -font $redoublefont -fg blue
	refont $path.suit redoublefont
	$path.card configure -text ""
    } elseif {$strain == "p"} {
	$path.suit configure -text $passtext -font $passfont -fg black
	refont $path.suit passfont
	$path.card configure -text ""
    } elseif {$strain == "-"} {
	$path.suit configure -text ""
	$path.card configure -text ""
    } elseif {$strain == "?"} {
	$path.suit configure -text ""
	$path.card configure -text "?"
    } else {
	eval "$path.suit configure -text [$strain] -font $suitfont"
	refont $path.suit suitfont
	$path.card configure -text $level
    }
}
#endif

// Display a player's name above his cards
// player should be lho, rho, pard, or self
proc setname {player compassdir name} {
#ifdef TEXT
    global namepos namewidth

    anchor $namepos($player)
    if {[string first "(" $name] == -1} {set name "$name ($compassdir)"}
    if {[string length $name] > $namewidth} {
	set name [string range $name 0 [expr $namewidth - 1]]
    }
    if {$player == "self" || $player == "pard"} {
	rightjustify $name $namewidth
    } else {
	clearrect $namewidth 1
    }
    str $name
#else
    global namefont mframe playername position
    set playername($player) $name
    set position($player) $compassdir
    set f $mframe($player).name.label
    if {[string first "(" $name] == -1} {set name "$name  ($compassdir)"}
    catch {$f configure -text $name} c
    if {$c != ""} {
	// configure didn't work -- try creating widget
	refont [label $f -font $namefont -text $name] namefont
	pack $f -pady 0
    }
#endif
}