# $Id: checkers.tcl 1481 2008-08-08 10:48:29Z sergei $

package require msgcat

namespace eval checkers {
    variable scriptdir [file dirname [info script]]

    ::msgcat::mcload [file join $scriptdir msgs]

    variable square_size 48
    variable line_width 1

    variable themes
    set dirs [glob -nocomplain -directory [file join $scriptdir pixmaps] *]
    foreach dir $dirs {
	pixmaps::load_theme_name [namespace current]::themes $dir
    }
    set values {}
    foreach theme [lsort [array names themes]] {
	lappend values $theme $theme
    }

    set game_names_list \
	[list \
	    straight  [::msgcat::mc "Straight checkers (English draughts)"] \
	    russian   [::msgcat::mc "Russian checkers"] \
	    pool      [::msgcat::mc "Pool checkers"] \
	    brazilian [::msgcat::mc "Brazilian checkers"] \
	    spanish   [::msgcat::mc "Spanish checkers"] \
	    italian   [::msgcat::mc "Italian checkers"] \
	]
    array set game_names $game_names_list
    array set short_game_names $game_names_list
    set short_game_names(straight) [::msgcat::mc "Straight checkers"]

    custom::defgroup Plugins [::msgcat::mc "Plugins options."] -group Tkabber

    custom::defgroup Checkers [::msgcat::mc "Checkers plugin options."] -group Plugins
    custom::defvar options(theme) Checkers \
	[::msgcat::mc "Checkers figures theme."] -group Checkers \
	-type options -values $values \
	-command [namespace current]::load_stored_theme
    custom::defvar options(game) russian \
	[::msgcat::mc "Default game variant."] -group Checkers \
	-type options \
	-values $game_names_list
    custom::defvar options(flip_black_view) 1 \
	[::msgcat::mc "Flip board view when playing black (Russian, Spanish, Italian) or white (Straight, Pool, Brazilian) by default."] \
	-type boolean -group Checkers
    custom::defvar options(show_last_move) 0 \
	[::msgcat::mc "Show last move by default."] \
	-type boolean -group Checkers
    custom::defvar options(show_tooltips) 1 \
	[::msgcat::mc "Show tooltips with short instructions."] \
	-type boolean -group Checkers \
	-command [list [namespace current]::set_tooltips]
    custom::defvar options(sound) "" \
        [::msgcat::mc "Sound to play after opponent's turn"] \
	-type file -group Checkers
    custom::defvar options(allow_illegal) 0 \
	[::msgcat::mc "Allow illegal moves (useful for debugging)."] \
	-type boolean -group Checkers
    custom::defvar options(accept_illegal) 0 \
	[::msgcat::mc "Accept opponent illegal moves (useful for debugging)."] \
	-type boolean -group Checkers
}

proc checkers::load_stored_theme {args} {
    variable options
    variable themes

    pixmaps::load_dir $themes(Checkers)
    pixmaps::load_dir $themes($options(theme))
}

hook::add postload_hook [namespace current]::checkers::load_stored_theme 70

proc checkers::get_nick {connid jid type} {
    if {[catch {chat::get_nick $connid $jid $type} nick]} {
	return [chat::get_nick $jid $type]
    } else {
	return $nick
    }
}

proc checkers::invite_dialog {connid jid} {
    variable options

    set w .checkers_invite

    if {[winfo exists $w]} {
	destroy $w
    }

    Dialog $w -title [::msgcat::mc "Checkers Invitation"] \
	-modal none -separator 1 -anchor e -default 0

    set wf [$w getframe]
    message $wf.message -aspect 50000 \
	-text [format [::msgcat::mc "Sending checkers game invitation to %s (%s)"] \
		      [get_nick $connid $jid chat] \
		      $jid]

    pack $wf.message -pady 2m
    variable game $options(game)
    radiobutton $wf.straight -text [::msgcat::mc "Straight checkers (English draughts)"] \
	-value straight -variable [namespace current]::game
    pack $wf.straight -padx 15m -anchor w
    radiobutton $wf.russian -text [::msgcat::mc "Russian checkers"] \
	-value russian -variable [namespace current]::game
    pack $wf.russian -padx 15m -anchor w
    radiobutton $wf.pool -text [::msgcat::mc "Pool checkers"] \
	-value pool -variable [namespace current]::game
    pack $wf.pool -padx 15m -anchor w
    radiobutton $wf.brazilian -text [::msgcat::mc "Brazilian checkers"] \
	-value brazilian -variable [namespace current]::game
    pack $wf.brazilian -padx 15m -anchor w
    radiobutton $wf.spanish -text [::msgcat::mc "Spanish checkers"] \
	-value spanish -variable [namespace current]::game
    pack $wf.spanish -padx 15m -anchor w
    radiobutton $wf.italian -text [::msgcat::mc "Italian checkers"] \
	-value italian -variable [namespace current]::game
    pack $wf.italian -padx 15m -anchor w

    $w add -text [::msgcat::mc "I want play white"] \
	-command [list [namespace current]::invite $connid $jid white]
    $w add -text [::msgcat::mc "I want play black"] \
	-command [list [namespace current]::invite $connid $jid black]
    $w add -text [::msgcat::mc "Cancel invitation"] \
	-command [list destroy $w]

    $w draw
}

proc checkers::invite {connid jid color} {
    variable game

    destroy .checkers_invite

    set id checkers[rand 1000000000]

    # FIX
    #set rjid [get_jid_of_user $jid]

    jlib::send_iq set \
	[jlib::wrapper:createtag create \
	     -vars [list xmlns games:board type checkers:$game id $id color $color]] \
	-to $jid \
	-command [list [namespace current]::invite_res $game $connid $jid $id $color] \
	-connection $connid
}

proc checkers::invite_res {game connid jid id color res child} {
    if {![cequal $res OK]} {
	after idle [list NonmodalMessageDlg .checkers_invite_error -aspect 50000 -icon error \
	    -message [format [::msgcat::mc "%s (%s) has refused checkers invitation: %s"] \
			     [get_nick $connid $jid chat] \
			     $jid [error_to_string $child]]]
	return ""
    }

    start_play $game $connid $jid $id $color
}

proc checkers::invited_dialog {game connid jid id color} {
    variable invited_result
    variable game_names

    set w .checkers_invited

    if {[winfo exists $w]} {
	destroy $w
    }

    Dialog $w -title [format [::msgcat::mc "Checkers Invitation from %s"] $jid] \
	-modal none -separator 1 -anchor e -default 0

    set wf [$w getframe]

    bind $wf <Destroy> [list [namespace current]::set_invited_res ""]

    set nick [get_nick $connid $jid chat]
    set message1 [format [::msgcat::mc "Checkers game invitation from %s (%s) is received."] \
			 $nick $jid]
    set message2 [format [::msgcat::mc "%s wants play %s."] $nick $game_names($game)]
    switch -- $color {
	white {
	    set message3 [format [::msgcat::mc "%s wants play white."] $nick]
	}
	black {
	    set message3 [format [::msgcat::mc "%s wants play black."] $nick]
	}
	default {
	    return [list error modify bad-request]
	}
    }
    message $wf.message1 -aspect 50000 -text $message1
    message $wf.message2 -aspect 50000 -text $message2
    message $wf.message3 -aspect 50000 -text $message3
    pack $wf.message1 -pady 1m
    pack $wf.message2 -pady 1m
    pack $wf.message3 -pady 1m
    
    $w add -text [::msgcat::mc "Agree to play"] \
	   -command [list [namespace current]::set_invited_res 0]
    $w add -text [::msgcat::mc "Refuse to play"] \
	   -command [list [namespace current]::set_invited_res 1]

    $w draw
    vwait [namespace current]::invited_result

    catch {
	bind $wf <Destroy> {}
	destroy $w
    }

    if {$invited_result == 0} {
	switch -- $color {
	    white {
		start_play $game $connid $jid $id black
	    }
	    black {
		start_play $game $connid $jid $id white
	    }
	    default {
		return [list error modify bad-request]
	    }
	}

	return [list result\
		     [jlib::wrapper:createtag create \
			  -vars [list xmlns games:board type checkers:$game id $id]]]
    } else {
	return [list error modify not-acceptable]
    }
}

proc checkers::set_invited_res {res} {
    variable invited_result
    set invited_result $res
}


proc checkers::start_play {game connid jid id color} {

    set gid [make_gid $jid $id]
    variable $gid
    variable options
    upvar 0 $gid flags

    set flags(window) [win_id checkers $gid]
    set flags(connid) $connid
    set flags(opponent) $jid
    set flags(id) $id
    set flags(flip) 0
    set flags(game) $game
    set flags(our_color) $color

    switch -- $game {
	straight {
	    set flags(board_type) 0
	    set flags(start) black
	}
	russian {
	    set flags(board_type) 0
	    set flags(start) white
	}
	pool {
	    set flags(board_type) 0
	    set flags(start) black
	}
	brazilian {
	    set flags(board_type) 0
	    set flags(start) black
	}
	spanish {
	    set flags(board_type) 1
	    set flags(start) white
	}
	italian {
	    set flags(board_type) 1
	    set flags(start) white
	}
    }

    trace variable [namespace current]::${gid}(position,turn) w \
	[list [namespace current]::set_label_move $gid]

    make_default_position $gid

    open $gid
}

proc checkers::set_label_move {gid args} {
    variable $gid
    upvar 0 $gid flags

    switch -- $flags(position,turn) {
	white {
	    set flags(move_label) [::msgcat::mc "White"]
	    set move 1
	}
	black {
	    set flags(move_label) [::msgcat::mc "Black"]
	    set move 1
	}
	default {
	    set move 0
	}
    }
    if {$move && [is_my_move $gid]} {
	append flags(move_label) [::msgcat::mc " (You)"]
    } else {
	append flags(move_label) [::msgcat::mc " (Opponent)"]
    }
}

proc checkers::make_default_position {gid} {
    variable $gid
    upvar 0 $gid flags

    switch -- $flags(start) {
	white {
	    set p1 wp
	    set p2 bp
	}
	black {
	    set p1 bp
	    set p2 wp
	}
    }

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    set cr [list $c $r]
	    set flags(position,$cr) ""
	    if {($c + $r) % 2 == $flags(board_type)} {
		if {$r < 3} {
		    set flags(position,$cr) $p1
		} elseif {$r > 4} {
		    set flags(position,$cr) $p2
		}
	    }
	}
    }

    set flags(position,turn) $flags(start)

    catch {unset flags(position,last_move)}
    set flags(position,draw) 0
    set flags(position,halfmove) 0
    set flags(position,history) {}
}

proc checkers::save_position {gid} {
    variable $gid
    upvar 0 $gid flags

    set flags(saved_position) [array get flags position,*]
}

proc checkers::restore_position {gid} {
    variable $gid
    upvar 0 $gid flags

    array set flags $flags(saved_position)
    draw_position $gid
    unhighlight_legal_moves $gid
    update_controls $gid
    find_legal_moves $gid $flags(position,turn)
}

proc checkers::make_gid {jid id} {
    jid_to_tag [concat $jid $id]
}

proc checkers::turn_recv {gid childs} {
    variable options
    variable prom_rev
    variable $gid
    upvar 0 $gid flags

    set move {}
    set draw 0

    foreach child $childs {
	jlib::wrapper:splitxml $child tag vars isempty chdata children
	switch -- $tag {
	    move {
		set pos [jlib::wrapper:getattr $vars pos]
		set poss [split $pos ";"]
		if {[llength $poss] >= 2} {
		    foreach pos1 $poss {
			set pos2 [split $pos1  ","]
			if {[llength $pos2] == 2} {
			    lappend move $pos2
			} else {
			    return [list error modify not-acceptable]
			}
		    }
		} else {
		    return [list error modify not-acceptable]
		}
		if {$options(sound) != "" && ![::sound::is_mute]} {
		    ::sound::play $options(sound)
		}
	    }
	    resign {
		end_game $gid 1 [::msgcat::mc "You win (Opponent resigned)"]
		update_controls $gid
		draw_position $gid
		highlight_last_move $gid
		return [list result [jlib::wrapper:createtag turn \
					 -vars [list xmlns games:board \
						     type checkers:$flags(game) \
						     id $flags(id)]]]
	    }
	    accept {
		if {$flags(position,draw)} {
		    end_game $gid 0.5 [::msgcat::mc "Draw (Opponent accepted)"]
		    update_controls $gid
		    draw_position $gid
		    highlight_last_move $gid
		    return [list result [jlib::wrapper:createtag turn \
					     -vars [list xmlns games:board \
							 type checkers:$flags(game) \
							 id $flags(id)]]]
		} else {
		    return [list error modify not-acceptable]
		}
	    }
	    draw {
		set draw 1
	    }
	}
    }

    if {![lempty $move] && [do_move $gid $move $draw]} {
	update_controls $gid $draw
	draw_position $gid
	highlight_last_move $gid

	return [list result [jlib::wrapper:createtag turn \
				 -vars [list xmlns games:board \
					     type checkers:$flags(game) \
					     id $flags(id)]]]
    } else {
	return [list error modify not-acceptable]
    }
}


###############################################################################

proc checkers::calc_moves {} {
    variable moves
    variable jumps

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    set cr [list $c $r]
	    set moves(up,$cr) {}
	    if {$r <= 6} {
		if {$c <= 6} {
		    lappend moves(up,$cr) [list [expr {$c + 1}] [expr {$r + 1}]]
		}
		if {$c >= 1} {
		    lappend moves(up,$cr) [list [expr {$c - 1}] [expr {$r + 1}]]
		}
	    }
	    set moves(dn,$cr) {}
	    if {$r >= 1} {
		if {$c <= 6} {
		    lappend moves(dn,$cr) [list [expr {$c + 1}] [expr {$r - 1}]]
		}
		if {$c >= 1} {
		    lappend moves(dn,$cr) [list [expr {$c - 1}] [expr {$r - 1}]]
		}
	    }
	    set jumps(up,$cr) {}
	    if {$r <= 5} {
		if {$c <= 5} {
		    lappend jumps(up,$cr) [list [expr {$c + 1}] [expr {$r + 1}]] \
					  [list [expr {$c + 2}] [expr {$r + 2}]]
		}
		if {$c >= 2} {
		    lappend jumps(up,$cr) [list [expr {$c - 1}] [expr {$r + 1}]] \
					  [list [expr {$c - 2}] [expr {$r + 2}]]
		}
	    }
	    set jumps(dn,$cr) {}
	    if {$r >= 2} {
		if {$c <= 5} {
		    lappend jumps(dn,$cr) [list [expr {$c + 1}] [expr {$r - 1}]] \
					  [list [expr {$c + 2}] [expr {$r - 2}]]
		}
		if {$c >= 2} {
		    lappend jumps(dn,$cr) [list [expr {$c - 1}] [expr {$r - 1}]] \
					  [list [expr {$c - 2}] [expr {$r - 2}]]
		}
	    }
	
	    for {set moves(d1,$cr) {}; set x [expr {$c+1}]; set y [expr {$r+1}]} \
		{($x < 8) && ($y < 8)} {incr x; incr y} {
		lappend moves(d1,$cr) [list $x $y]
	    }
	    for {set moves(d2,$cr) {}; set x [expr {$c-1}]; set y [expr {$r+1}]} \
		{($x >= 0) && ($y < 8)} {incr x -1; incr y} {
		lappend moves(d2,$cr) [list $x $y]
	    }
	    for {set moves(d3,$cr) {}; set x [expr {$c-1}]; set y [expr {$r-1}]} \
		{($x >= 0) && ($y >= 0)} {incr x -1; incr y -1} {
		lappend moves(d3,$cr) [list $x $y]
	    }
	    for {set moves(d4,$cr) {}; set x [expr {$c+1}]; set y [expr {$r-1}]} \
		{($x < 8) && ($y >= 0)} {incr x; incr y -1} {
		lappend moves(d4,$cr) [list $x $y]
	    }
	}
    }
}

hook::add finload_hook [namespace current]::checkers::calc_moves 100

proc checkers::center {c r} {
    variable square_size
    variable line_width

    set r [expr {7 - $r}]
    list [expr {$line_width + ($square_size * 0.5) + \
		    (($square_size + $line_width) * $c)}] \
	[expr {$line_width + ($square_size * 0.5) + \
		   (($square_size + $line_width) * $r)}]
}

proc checkers::close {gid} {
    variable $gid
    upvar 0 $gid flags

    array unset flags
}

proc checkers::exists {gid} {
    variable $gid
    info exists $gid
}

proc checkers::open {gid} {
    variable options
    variable square_size
    variable line_width
    variable short_game_names
    variable $gid
    upvar 0 $gid flags

    set jid $flags(opponent)

    set w $flags(window)
    if {[winfo exists $w]} {
	raise_win $w
	return
    }

    set title [format [::msgcat::mc "%s with %s"] \
	$short_game_names($flags(game)) [get_nick $flags(connid) $jid chat]]
    add_win $w -title $title \
	       -tabtitle $title \
	       -class Checkers \
	       -raise 1

    set board [canvas $w.board \
		   -width [expr {($square_size + $line_width) * 8}] \
		   -height [expr {($square_size + $line_width) * 8}]]
    pack $board -side left -anchor w -padx 10

    set flags(board) $board

    set flags(show_last_move) $options(show_last_move)
    set relief [expr {$flags(show_last_move) ? "sunken" : "raised"}]
    set slm [Button $w.show_last_move -text [::msgcat::mc "Show last move"] \
		-relief $relief \
		-command [list [namespace current]::toggle_show_last_move $gid]]
    pack $slm -side top -anchor w -fill x
    set flags(show_last_move_button) $slm

    set flags(flip) 0
    set slm [Button $w.flip -text [::msgcat::mc "Flip view"] \
		-relief raised \
		-command [list [namespace current]::toggle_flip_view $gid]]
    pack $slm -side top -anchor w -fill x
    set flags(flip_button) $slm

    frame $w.move 
    pack $w.move -side top -anchor w
    label $w.move.title -text [::msgcat::mc "Move: "]
    pack $w.move.title -side left
    label $w.move.on_move -anchor w \
	-textvariable [namespace current]::${gid}(move_label)
    pack $w.move.on_move -side left -anchor w

    set bbox [ButtonBox $w.bbox -orient vertical -spacing 0]
    $bbox add -text [::msgcat::mc "Propose a draw"] \
	-command [list [namespace current]::toggle_draw $gid]
    $bbox add -text [::msgcat::mc "Accept the draw proposal"] \
	-state disabled \
	-command [list [namespace current]::accept_draw $gid]
    $bbox add -text [::msgcat::mc "Resign the game"] \
	-command [list [namespace current]::send_resign $gid]
    grid columnconfigure $bbox 0 -weight 1
    pack $bbox -side bottom -anchor w -fill x
    set flags(bbox) $bbox
    set_tooltips

    #label $w.history -text [::msgcat::mc "History"]
    #pack $w.history -side top -anchor w
    set hsw [ScrolledWindow $w.hsw]
    pack $hsw -side top -fill x -expand yes
    set ht [text $w.text -wrap word -height 60 -state disabled]
    set font [$ht cget -font]
    set tabstop1 [font measure $font "99.."]
    set tabstop2 [font measure $font "99..Qa8-a8+= "]
    $ht configure -tabs "$tabstop1 $tabstop2"
    $ht tag configure attention -foreground [option get $ht errorForeground Text]
    $hsw setwidget $ht
    set flags(hw) $ht

    set dsq_color #77a26d
    set lsq_color #c8c365

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    set x1 [expr {$line_width + (($square_size + $line_width) * $c)}]
	    set x2 [expr {($square_size + $line_width) * ($c + 1)}]
	    set y1 [expr {$line_width + (($square_size + $line_width) * $r)}]
	    set y2 [expr {($square_size + $line_width) * ($r + 1)}]
	    set color [expr {($c+$r) % 2 ? $dsq_color : $lsq_color}]
	    switch -- $flags(board_type) {
		0 {
		    set img [expr {($c+$r) % 2 ? "bf" : "wf"}]
		}
		1 {
		    set img [expr {($c+$r) % 2 ? "wf" : "bf"}]
		}
	    }

	    $board create image $x1 $y1 -image checkers/$img -anchor nw \
		-tags [list background [list cr [list $c [expr {7-$r}]]]]
	    $board create rectangle $x1 $y1 $x2 $y2 \
		-outline {} \
		-tags [list square [list cr [list $c [expr {7-$r}]]]]
	}
    }

    $board bind figure <1> \
	[list [namespace current]::start_drag_figure $gid %x %y]
    $board bind figure <B1-Motion> \
	[list [namespace current]::drag_figure $gid %x %y]
    $board bind figure <ButtonRelease-1> \
	[list [namespace current]::drag_end $gid %x %y]

    bind $w <Destroy> [list [namespace current]::close $gid]

    if {![is_same_color $flags(our_color) $flags(start)] && $options(flip_black_view)} {
	toggle_flip_view $gid
    }

    draw_position $gid
    update_controls $gid
    find_legal_moves $gid $flags(position,turn)
}

proc checkers::toggle_flip_view {gid} {
    variable $gid
    upvar 0 $gid flags

    set flags(flip) [expr {!$flags(flip)}]

    set board $flags(board)

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    $board addtag [list temp [expr {7-$c}] [expr {7-$r}]] \
		   withtag [list cr [list $c $r]]
	    $board dtag [list cr [list $c $r]]
	}
    }

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    $board addtag [list cr [list $c $r]] withtag [list temp $c $r]
	    $board dtag [list temp $c $r]
	}
    }
    
    set relief [expr {$flags(flip) ? "sunken" : "raised"}]
    $flags(flip_button) configure -relief $relief

    draw_position $gid
    highlight_last_move $gid
}

proc checkers::set_tooltips {args} {
    variable options

    if {$options(show_tooltips)} {
	set tooltip0 [::msgcat::mc "Press button and make move if you want propose draw"]
	set tooltip1 [::msgcat::mc "Press button if you want accept the draw proposal"]
	set tooltip2 [::msgcat::mc "Press button if you want resign"]
    } else {
	set tooltip0 ""
	set tooltip1 ""
	set tooltip2 ""
    }

    foreach var [info vars [namespace current]::*] {
	upvar 0 $var flags
	if {[info exists flags(bbox)]} {
	    catch {
		$flags(bbox) itemconfigure 0 -helptext $tooltip0
		$flags(bbox) itemconfigure 1 -helptext $tooltip1
		$flags(bbox) itemconfigure 2 -helptext $tooltip2
	    }
	}
    }
}

proc checkers::toggle_show_last_move {gid} {
    variable $gid
    upvar 0 $gid flags

    set flags(show_last_move) [expr {!$flags(show_last_move)}]

    set relief [expr {$flags(show_last_move) ? "sunken" : "raised"}]
    $flags(show_last_move_button) configure -relief $relief

    highlight_last_move $gid
}

proc checkers::toggle_draw {gid} {
    variable $gid
    upvar 0 $gid flags

    set flags(position,draw) [expr {!$flags(position,draw)}]

    if {$flags(position,draw)} {
	$flags(bbox) itemconfigure 0 -relief sunken
    } else {
	$flags(bbox) itemconfigure 0 -relief raised
    }
}

proc checkers::update_controls {gid {draw_proposed 0}} {
    variable $gid
    upvar 0 $gid flags

    $flags(bbox) itemconfigure 0 -relief raised

    if {[is_my_move $gid]} {
	$flags(board) config -cursor ""
	set flags(position,draw) 0
	if {$draw_proposed} {
	    $flags(bbox) itemconfigure 0 -state disabled
	    $flags(bbox) itemconfigure 1 -state normal
	    $flags(bbox) itemconfigure 2 -state disabled
	} else {
	    $flags(bbox) itemconfigure 0 -state normal
	    $flags(bbox) itemconfigure 1 -state disabled
	    $flags(bbox) itemconfigure 2 -state normal
	}
    } elseif {![is_white $flags(position,turn)] && \
	      ![is_black $flags(position,turn)]} {
	$flags(board) config -cursor ""
	$flags(bbox) itemconfigure 0 -state disabled
	$flags(bbox) itemconfigure 1 -state disabled
	$flags(bbox) itemconfigure 2 -state disabled
    } else {
	$flags(board) config -cursor watch
	$flags(bbox) itemconfigure 0 -state disabled
	$flags(bbox) itemconfigure 1 -state disabled
	$flags(bbox) itemconfigure 2 -state disabled
    }
}

proc checkers::end_game {gid my_score message} {
    variable $gid
    upvar 0 $gid flags

    set opponent_score [expr {1 - $my_score}]

    if {[is_same_color $flags(our_color) $flags(start)]} {
	set score "$my_score : $opponent_score"
    } else {
	set score "$opponent_score : $my_score"
    }

    set flags(position,turn) none
    set flags(move_label) $message

    set hw $flags(hw)
    $hw configure -state normal
    catch {$hw delete attention.first attention.last}
    $hw delete {end -1 char} end
    $hw insert end "\n\t\t$score\n"
    $hw see end
    $hw configure -state disabled
}

proc checkers::draw_position {gid} {
    variable $gid
    upvar 0 $gid flags

    $flags(board) delete figure

    for {set c 0} {$c < 8} {incr c} {
	for {set r 0} {$r < 8} {incr r} {
	    set cr [list $c $r]
	    if {$flags(position,$cr) != ""} {
		if {$flags(flip)} {
		    set c1 [expr {7 - $c}]
		    set r1 [expr {7 - $r}]
		} else {
		    set c1 $c
		    set r1 $r
		}
		$flags(board) create image [center $c1 $r1] \
		    -image checkers/$flags(position,$cr) \
		    -tags [list figure $flags(position,$cr) [list cr $cr]]
	    }
	}
    }
}

proc checkers::start_drag_figure {gid x y} {
    variable $gid
    upvar 0 $gid flags

    set board $flags(board)

    lassign [lindex [lmatch -regexp [$board gettags current] ^cr] 0] \
	cr currentcr
    set flags(current_move) [list $currentcr]

    set flags(last_x) [$board canvasx $x]
    set flags(last_y) [$board canvasy $y]
    $board raise current
    $board config -cursor hand2

    highlight_legal_moves $gid $flags(current_move)
}

proc checkers::drag_figure {gid x y} {
    variable $gid
    upvar 0 $gid flags

    set board $flags(board)

    set x [$board canvasx $x]
    set y [$board canvasy $y]
    $board move current \
	[expr {$x - $flags(last_x)}] [expr {$y - $flags(last_y)}]
    set flags(last_x) $x
    set flags(last_y) $y

    $board itemconfigure dst_sq&&square -outline {}
    $board dtag dst_sq
    $board itemconfigure intermediate1&&square -outline yellow
    $board itemconfigure intermediate2&&square -outline green
    $board itemconfigure legal&&square -outline blue
    $board addtag dst_sq overlapping $x $y $x $y
    lassign [lindex [lmatch -regexp [$board gettags dst_sq&&background] ^cr] 0] \
	-> cr
    $board addtag dst_sq withtag [list cr $cr]&&square

    $board itemconfigure dst_sq&&square -outline red
    $board itemconfigure dst_sq&&legal&&square -outline blue
    if {[lindex $flags(current_move) end] != $cr} {
	set current [concat $flags(current_move) [list $cr]]
	if {[is_move_prefix_legal $gid $current]} {
	    set flags(current_move) $current
	    highlight_legal_moves $gid $flags(current_move)
	} elseif {[is_move_legal $gid $current]} {
	    $board itemconfigure dst_sq&&legal&&square -outline white
	}
    }
    $board itemconfigure dst_sq&&intermediate1&&square -outline yellow
    $board itemconfigure dst_sq&&intermediate2&&square -outline green
}

proc checkers::drag_end {gid x y} {
    variable options
    variable $gid
    upvar 0 $gid flags

    set board $flags(board)

    set x [$board canvasx $x]
    set y [$board canvasy $y]
    $board itemconfigure dst_sq&&square -outline {}
    $board dtag dst_sq
    $board addtag dst_sq overlapping $x $y $x $y

    lassign [lindex [lmatch \
			 -regexp [$board gettags dst_sq&&background] \
			 ^cr] 0] -> cr
    $board dtag dst_sq

    lappend flags(current_move) $cr

    if {$options(allow_illegal) || [is_my_move $gid]} {
	do_move $gid $flags(current_move) $flags(position,draw)
    }
    
    update_controls $gid
    draw_position $gid

    unhighlight_legal_moves $gid

    highlight_last_move $gid
}

proc checkers::highlight_last_move {gid} {
    variable $gid
    upvar 0 $gid flags

    $flags(board) itemconfigure square -outline ""
    $flags(board) itemconfigure square -outline ""
    
    if {![info exists flags(position,last_move)]} {
	return
    }

    if {$flags(show_last_move)} {
	set color white
	set color2 yellow
    } else {
	set color {}
	set color2 {}
    }

    foreach pos [lrange $flags(position,last_move) 1 end-1] {
	$flags(board) itemconfigure [list cr $pos]&&square -outline $color
    }
    $flags(board) itemconfigure \
	[list cr [lindex $flags(position,last_move) 0]]&&square -outline $color
    $flags(board) itemconfigure \
	[list cr [lindex $flags(position,last_move) end]]&&square -outline $color
}

proc checkers::do_move {gid move draw} {
    variable options
    variable $gid
    upvar 0 $gid flags

    if {([llength $move] < 2) || ([lindex $move 0] == [lindex $move 1])} {
	return 0
    }

    set endgame 0
    set opt "-"
    set suffix ""
    set my_move [is_my_move $gid]

    if {![is_move_legal $gid $move]} {
	if {$my_move && !$options(allow_illegal)} {
	    return 0
	}
	if {!$my_move && !$options(accept_illegal)} {
	    return 0
	}
    }

    save_position $gid

    set figure $flags(position,[lindex $move 0])

    if {![is_move_legal $gid $move]} {
	set flags(position,[lindex $move end]) $figure
	set flags(position,[lindex $move 0]) ""
    } else {
	set origin [lindex $move 0]
	foreach step [lrange $move 1 end] {
	    lassign $origin originx originy
	    lassign $step stepx stepy
	    set dx [expr {$originx < $stepx ? 1 : -1}]
	    set dy [expr {$originy < $stepy ? 1 : -1}]
	    for {set x $originx; set y $originy} {($x != $stepx) && ($y != $stepy)} \
		    {incr x $dx; incr y $dy} {
		set xy [list $x $y]
		if {![is_same_color $flags(position,$xy) $figure]} {
		    set opt ":"
		}
		set flags(position,$xy) ""
	    }
	    switch -- $flags(game) {
		straight {
		    switch -- $figure,$stepy {
			bp,7 { set figure bk }
			wp,0 { set figure wk }
		    }
		}
		pool -
		brazilian {
		    switch -- $figure,$stepy {
			bp,7 {
			    if {[lindex $move end] == $step} {
				set figure bk
			    }
			}
			wp,0 {
			    if {[lindex $move end] == $step} {
				set figure wk
			    }
			}
		    }
		}
		russian -
		spanish -
		italian {
		    switch -- $figure,$stepy {
			wp,7 { set figure wk }
			bp,0 { set figure bk }
		    }
		}
	    }
	    set flags(position,$step) $figure
	    set origin $step
	}
    }

    set flags(position,last_move) $move

    if {[is_white $flags(position,turn)]} {
	set flags(position,turn) black
    } else {
	set flags(position,turn) white
    }

    find_legal_moves $gid $flags(position,turn)

    if {[lempty $flags(legal_moves)]} {
	set draw 0
	set endgame 1
    }
    if {$draw} {
	set suffix "="
    }
    add_move_to_history $gid $move $opt $suffix
    if {$draw && !$my_move} {
	attention_message $gid \
	    [::msgcat::mc "\n\n Opponent proposes a draw\n\n"]
    }
	
    if {$my_move} {
	send_move $gid $move
    }

    if {$endgame} {
	if {$my_move} {
	    # I win
	    end_game $gid 1 [::msgcat::mc "You win"]
	} else {
	    # Opponent wins
	    end_game $gid 0 [::msgcat::mc "Opponent wins"]
	}
    }

    tab_set_updated [winfo parent $flags(board)] 1 mesg_to_user
    return 1
}

proc checkers::accept_draw {gid} {
    variable $gid
    upvar 0 $gid flags

    jlib::send_iq set \
	[jlib::wrapper:createtag turn \
	     -vars [list xmlns games:board \
			type checkers:$flags(game) \
			id $flags(id)] \
	     -subtags [list [jlib::wrapper:createtag accept]]] \
	-to $flags(opponent) \
	-connection $flags(connid)

	end_game $gid 0.5 [::msgcat::mc "Draw (You accepted)"]
	update_controls $gid
	draw_position $gid
	highlight_last_move $gid
}

proc checkers::send_resign {gid} {
    variable $gid
    upvar 0 $gid flags

    jlib::send_iq set \
	[jlib::wrapper:createtag turn \
	     -vars [list xmlns games:board \
			type checkers:$flags(game) \
			id $flags(id)] \
	     -subtags [list [jlib::wrapper:createtag resign]]] \
	-to $flags(opponent) \
	-connection $flags(connid)

	end_game $gid 0 [::msgcat::mc "Opponent wins (You resigned)"]
	update_controls $gid
	draw_position $gid
	highlight_last_move $gid
}

proc checkers::send_move {gid move} {
    variable $gid
    upvar 0 $gid flags

    set move_tags [list [make_move_tag $gid $move]]
    if {$flags(position,draw)} {
	lappend move_tags [jlib::wrapper:createtag draw]
    }

    jlib::send_iq set \
	[jlib::wrapper:createtag turn \
	     -vars [list xmlns games:board \
			type checkers:$flags(game) \
			id $flags(id)] \
	     -subtags $move_tags] \
	-to $flags(opponent) \
	-connection $flags(connid) \
	-command [list [namespace current]::send_result $gid]
}

proc checkers::send_result {gid res child} {
    if {$res == "ERR"} {
	attention_message $gid \
	    [format [::msgcat::mc "\n\n Opponent rejected move:\n %s\n\n"] \
		[error_to_string $child]]
	restore_position $gid
    }
}

proc checkers::make_move_tag {gid move} {
    set move1 {}
    foreach pos $move {
	lappend move1 [join $pos ","]
    }

    jlib::wrapper:createtag move -vars [list pos [join $move1 ";"]]
}

proc checkers::add_move_to_history {gid move opt suffix} {
    variable piece_name
    variable $gid
    upvar 0 $gid flags

    incr flags(position,halfmove) 1

    lappend flags(position,history) [list $move $opt $suffix]

    set hw $flags(hw)
    $hw configure -state normal
    $hw delete 0.0 end

    if {[is_white $flags(start)]} {
	$hw insert end "\t[::msgcat::mc White]\t[::msgcat::mc Black]\n"
    } else {
	$hw insert end "\t[::msgcat::mc Black]\t[::msgcat::mc White]\n"
    }
    set i 1
    foreach {w b} $flags(position,history) {
	$hw insert end "${i}.\t"
	if {$w != {}} {
	    lassign $w move opt suffix
	    set move1 {}
	    foreach pos $move {
		lassign $pos c r
		incr r
		set l [format %c [expr {$c+97}]]
		lappend move1 "$l$r"
	    }
	    $hw insert end "[join $move1 $opt]$suffix\t"
	}
	if {$b != {}} {
	    lassign $b move opt suffix
	    set move1 {}
	    foreach pos $move {
		lassign $pos c r
		incr r
		set l [format %c [expr {$c+97}]]
		lappend move1 "$l$r"
	    }
	    $hw insert end "[join $move1 $opt]$suffix\n"
	}
	incr i
    }
    $hw see end
    $hw configure -state disabled
}


proc checkers::find_legal_moves {gid color} {
    variable moves
    variable jumps
    variable $gid
    upvar 0 $gid flags

    set flags(legal_moves) {}
    find_legal_jumps $gid $color
    if {[lempty $flags(legal_moves)]} {
	find_legal_moves1 $gid $color
    }
}

proc checkers::find_legal_jumps {gid color} {
    variable moves
    variable $gid
    upvar 0 $gid flags

    for {set cf 0} {$cf < 8} {incr cf} {
	for {set rf 0} {$rf < 8} {incr rf} {
	    set cr [list $cf $rf]
	    if {![is_same_color $flags(position,$cr) $color]} {
		continue
	    }

	    set figure $flags(position,$cr)
	    set flags(position,$cr) ""
	    find_legal_jumps1 $gid $cr $figure [list $cr] {}
	    set flags(position,$cr) $figure
	}
    }

    clean_jumps $gid
}

proc checkers::clean_jumps {gid} {
    variable $gid
    upvar 0 $gid flags

    switch -- $flags(game) {
	brazilian -
	spanish {
	    set jumps {}
	    set l 0
	    foreach m $flags(legal_moves) {
		set l1 [llength $m]
		if {$l1 > $l} {
		    set jumps [list $m]
		    set l $l1
		} elseif {$l1 == $l} {
		    lappend jumps $m
		}
	    }
	    set flags(legal_moves) $jumps
	}
	italian {
	    set jumps {}
	    set l 0
	    set captor b
	    set nkings 0
	    set pking 0
	    foreach m $flags(legal_moves) {
		set l1 [llength $m]
		set captor1 [string index $flags(position,[lindex $m 0]) end]
		lassign [count_kings $gid $m] nkings1 pking1
		if {($l1 > $l) ||
		    (($l1 == $l) && ($captor1 == "k" && $captor == "b")) ||
		    (($l1 == $l) && ($captor1 == $captor) && ($nkings1 > $nkings)) ||
		    (($l1 == $l) && ($captor1 == $captor) && ($nkings1 == $nkings) && ($pking1 < $pking))} {
		    set jumps [list $m]
		    set l $l1
		    set captor $captor1
		    set nkings $nkings1
		    set pking $pking1
		} elseif {($l1 == $l) && ($captor == $captor1) && ($nkings1 == $nkings) && ($pking1 == $pking)} {
		    lappend jumps $m
		}
	    }
	    set flags(legal_moves) $jumps
	}
    }
}

proc checkers::count_kings {gid move} {
    variable $gid
    upvar 0 $gid flags

    set nkings 0
    set pking 0
    set crf [lindex $move 0]
    set i 1
    foreach crt [lrange $move 1 end] {
	lassign $crf cf rf
	lassign $crt ct rt
	set crm [list [expr {($cf + $ct)/2}] [expr {($rf + $rt)/2}]]
	if {[string index $flags(position,$crm) end] == "k"} {
	    incr nkings
	    if {$pking == 0} {
		set pking $i
	    }
	}
	incr i
    }
    return [list $nkings $pking]
}

proc checkers::find_legal_jumps1 {gid cr figure current forbidden {simulate 0}} {
    variable moves
    variable jumps
    variable $gid
    upvar 0 $gid flags

    set jump 0

    switch -- $figure {
	"" { continue }

	bp {
	    switch -- $flags(game) {
		straight {
		    foreach {crdel crt} $jumps(up,$cr) {
			if {![lcontain $forbidden $crdel] && \
				[is_white $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		spanish {
		    foreach {crdel crt} $jumps(dn,$cr) {
			if {![lcontain $forbidden $crdel] && \
				[is_white $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		italian {
		    foreach {crdel crt} $jumps(dn,$cr) {
			if {![lcontain $forbidden $crdel] && \
				$flags(position,$crdel) == "wp" && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		russian {
		    foreach {crdel crt} [concat $jumps(up,$cr) $jumps(dn,$cr)] {
			if {![lcontain $forbidden $crdel] && \
				[is_white $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt \
				[expr {[lindex $crt 1] == 0 ? "bk" : "bp"}] \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		pool -
		brazilian {
		    foreach {crdel crt} [concat $jumps(up,$cr) $jumps(dn,$cr)] {
			if {![lcontain $forbidden $crdel] && \
				[is_white $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
	    }
	}

	wp {
	    switch -- $flags(game) {
		straight {
		    foreach {crdel crt} $jumps(dn,$cr) {
			if {![lcontain $forbidden $crdel] && \
				[is_black $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		spanish {
		    foreach {crdel crt} $jumps(up,$cr) {
			if {![lcontain $forbidden $crdel] && \
				[is_black $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		italian {
		    foreach {crdel crt} $jumps(up,$cr) {
			if {![lcontain $forbidden $crdel] && \
				$flags(position,$crdel) == "bp" && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		russian {
		    foreach {crdel crt} [concat $jumps(dn,$cr) $jumps(up,$cr)] {
			if {![lcontain $forbidden $crdel] && \
				[is_black $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt \
				[expr {[lindex $crt 1] == 7 ? "wk" : "wp"}] \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		pool -
		brazilian {
		    foreach {crdel crt} [concat $jumps(dn,$cr) $jumps(up,$cr)] {
			if {![lcontain $forbidden $crdel] && \
				[is_black $flags(position,$crdel)] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
	    }
	}

	wk -
	bk {
	    switch -- $flags(game) {
		straight -
		italian {
		    foreach {crdel crt} [concat $jumps(dn,$cr) $jumps(up,$cr)] {
			if {![lcontain $forbidden $crdel] && \
				![is_same_color $flags(position,$crdel) $figure] && \
				$flags(position,$crt) == ""} {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
		russian -
		pool -
		brazilian -
		spanish {
		    set canjump {}
		    set cantjump {}
		    foreach d {d1 d2 d3 d4} {
			set state empty
			foreach crt $moves($d,$cr) {
			    switch -- $state {
				empty {
				    if {($flags(position,$crt) != "")} {
					if {![lcontain $forbidden $crt] && \
						![is_same_color $flags(position,$crt) $figure]} {
					    set crdel $crt
					    set state jump
					} else {
					    break
					}
				    }
				}
				jump {
				    if {($flags(position,$crt) == "")} {
					if {[find_legal_jumps1 $gid $crt $figure \
						[concat $current [list $crt]] \
						[concat $forbidden [list $crdel]] 1]} {
					    lappend canjump $crdel $crt
					} else {
					    lappend cantjump $crdel $crt
					}
				    } else {
					break
				    }
				}
			    }
			}
		    }
		    if {![lempty $canjump]} {
			foreach {crdel crt} $canjump {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    } else {
			foreach {crdel crt} $cantjump {
			    find_legal_jumps1 $gid $crt $figure \
				[concat $current [list $crt]] \
				[concat $forbidden [list $crdel]]
			    set jump 1
			}
		    }
		}
	    }
	}
    }

    if {!$simulate && !$jump && [llength $current] >= 2} {
	lappend flags(legal_moves) $current
    }
    return $jump
}

proc checkers::find_legal_moves1 {gid color} {
    variable moves
    variable $gid
    upvar 0 $gid flags

    for {set cf 0} {$cf < 8} {incr cf} {
	for {set rf 0} {$rf < 8} {incr rf} {
	    set cr [list $cf $rf]
	    if {![is_same_color $flags(position,$cr) $color]} {
		continue
	    }

	    switch -- $flags(position,$cr) {
		"" { continue }

		bp {
		    switch -- $flags(game) {
			straight -
			pool -
			brazilian {
			    foreach crt $moves(up,$cr) {
				if {$flags(position,$crt) == ""} {
				    lappend flags(legal_moves) [list $cr $crt]
				}
			    }
			}
			russian -
			spanish -
			italian {
			    foreach crt $moves(dn,$cr) {
				if {$flags(position,$crt) == ""} {
				    lappend flags(legal_moves) [list $cr $crt]
				}
			    }
			}
		    }
		}

		wp {
		    switch -- $flags(game) {
			straight -
			pool -
			brazilian {
			    foreach crt $moves(dn,$cr) {
				if {$flags(position,$crt) == ""} {
				    lappend flags(legal_moves) [list $cr $crt]
				}
			    }
			}
			russian -
			spanish -
			italian {
			    foreach crt $moves(up,$cr) {
				if {$flags(position,$crt) == ""} {
				    lappend flags(legal_moves) [list $cr $crt]
				}
			    }
			}
		    }
		}

		wk -
		bk {
		    switch -- $flags(game) {
			straight -
			italian {
			    foreach crt [concat $moves(up,$cr) $moves(dn,$cr)] {
				if {$flags(position,$crt) == ""} {
				    lappend flags(legal_moves) [list $cr $crt]
				}
			    }
			}
			russian -
			pool -
			brazilian -
			spanish {
			    foreach d {d1 d2 d3 d4} {
				foreach crt $moves($d,$cr) {
				    if {$flags(position,$crt) == ""} {
					lappend flags(legal_moves) [list $cr $crt]
				    } else {
					break
				    }
				}
			    }
			}
		    }
		}
	    }
	}
    }
}

proc checkers::is_move_legal {gid move} {
    variable $gid
    upvar 0 $gid flags

    expr {[lsearch -exact $flags(legal_moves) $move] >= 0}
}

proc checkers::is_move_prefix_legal {gid move} {
    variable $gid
    upvar 0 $gid flags

    expr {[lsearch -glob $flags(legal_moves) "$move *"] >= 0}
}

proc checkers::highlight_legal_moves {gid prefix} {
    variable $gid
    upvar 0 $gid flags

    unhighlight_legal_moves $gid

    set len [llength $prefix]
    set lenm1 [expr {$len - 1}]
    foreach move $flags(legal_moves) {
	if {[lrange $move 0 $lenm1] != $prefix} {
	    continue
	}
	foreach pos [lrange $move 1 $lenm1] {
	    $flags(board) addtag intermediate1 withtag [list cr $pos]&&square
	}
	foreach pos [lrange $move $len end-1] {
	    $flags(board) addtag intermediate2 withtag [list cr $pos]&&square
	}
	$flags(board) addtag legal withtag [list cr [lindex $move end]]&&square

    }
    $flags(board) itemconfigure legal&&square -outline blue
    $flags(board) itemconfigure intermediate1&&square -outline yellow
    $flags(board) itemconfigure intermediate2&&square -outline green
}

proc checkers::unhighlight_legal_moves {gid} {
    variable $gid
    upvar 0 $gid flags

    $flags(board) itemconfigure square -outline {}
    $flags(board) dtag legal
    $flags(board) dtag intermediate1
    $flags(board) dtag intermediate2
}

proc checkers::attention_message {gid message} {
    variable $gid
    upvar 0 $gid flags

    set hw $flags(hw)
    $hw configure -state normal
    $hw delete {end -1 char} end
    $hw insert end $message attention
    $hw see end
    $hw configure -state disabled
}

proc checkers::is_my_move {gid} {
    variable $gid
    upvar 0 $gid flags

    is_same_color $flags(position,turn) $flags(our_color)
}

proc checkers::is_white {f} {
    string equal -length 1 $f w
}

proc checkers::is_black {f} {
    string equal -length 1 $f b
}

proc checkers::is_same_color {f1 f2} {
    string equal -length 1 $f1 $f2
}

proc checkers::add_groupchat_user_menu_item {m connid jid} {
    set mm $m.gamesmenu
    if {![winfo exists $mm]} {
	menu $mm -tearoff 0
	$m add cascade -label [::msgcat::mc "Games"] -menu $mm
    }
    $mm add command -label [::msgcat::mc "Checkers..."] \
	-command [list [namespace current]::invite_dialog $connid $jid]
}

hook::add roster_create_groupchat_user_menu_hook \
    [namespace current]::checkers::add_groupchat_user_menu_item 49
hook::add chat_create_user_menu_hook \
    [namespace current]::checkers::add_groupchat_user_menu_item 49
hook::add roster_jid_popup_menu_hook \
    [namespace current]::checkers::add_groupchat_user_menu_item 49

proc checkers::iq_create {varname connid from child} {
    upvar 2 $varname var

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    lassign [split [jlib::wrapper:getattr $vars type] ":"] cathegory game

    if {$cathegory != "checkers"} {
	return
    }

    switch -- $game {
	straight -
	russian -
	pool -
	brazilian -
	spanish -
	italian {
	    if {[jlib::wrapper:isattr $vars color]} {
		set color [jlib::wrapper:getattr $vars color]
		switch -- $color {
		    white -
		    black { }
		    default {
			set var [list error modify bad-request]
		    }
		}
	    } else {
		set color white
	    }
	    set var [[namespace current]::invited_dialog \
			 $game $connid $from \
			 [jlib::wrapper:getattr $vars id] \
			 $color]
	}
    }
    return
}

hook::add games_board_create_hook [namespace current]::checkers::iq_create

proc checkers::iq_turn {varname connid from child} {
    upvar 2 $varname var

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    lassign [split [jlib::wrapper:getattr $vars type] ":"] cathegory game

    if {$cathegory != "checkers"} {
	return
    }

    switch -- $game {
	straight -
	russian -
	pool -
	brazilian -
	spanish -
	italian {
	    set gid [make_gid $from [jlib::wrapper:getattr $vars id]]
	    if {[exists $gid]} {
		set var [[namespace current]::turn_recv $gid $children]
	    } else {
		set var [list error cancel item-not-found]
	    }
	}
    }
    return
}

hook::add games_board_turn_hook [namespace current]::checkers::iq_turn


# Common games:board part
proc iq_games_board_create {connid from lang child} {
    set res [list error cancel feature-not-implemented]
    hook::run games_board_create_hook res $connid $from $child
    return $res
}

iq::register_handler set create games:board \
    [namespace current]::iq_games_board_create

proc iq_games_board_turn {connid from lang child} {
    set res [list error cancel feature-not-implemented]
    hook::run games_board_turn_hook res $connid $from $child
    return $res
}

iq::register_handler set turn games:board \
    [namespace current]::iq_games_board_turn

