# chess.tcl --
#
#       This file implements Chess game plugin for the Tkabber XMPP client.

package require msgcat

namespace eval chess {
    ::msgcat::mcload [file join [file dirname [info script]] msgs]

    if {![::plugins::is_registered chess]} {
        ::plugins::register chess \
                            -namespace [namespace current] \
                            -source [info script] \
                            -description [::msgcat::mc "Whether the Chess\
                                                        plugin is loaded."] \
                            -loadcommand [namespace code load] \
                            -unloadcommand [namespace code unload]
        return
    }

    variable square_size 48
    variable line_width 1
    array set piece_name [list \
                              wk [::msgcat::mc "K"] \
                              wq [::msgcat::mc "Q"] \
                              wr [::msgcat::mc "R"] \
                              wb [::msgcat::mc "B"] \
                              wn [::msgcat::mc "N"] \
                              wp {} \
                              bk [::msgcat::mc "K"] \
                              bq [::msgcat::mc "Q"] \
                              br [::msgcat::mc "R"] \
                              bb [::msgcat::mc "B"] \
                              bn [::msgcat::mc "N"] \
                              bp {}]
    array set prom_name [list q queen r rook b bishop n knight]
    array set prom_rev [list queen q rook r bishop b knight n]

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

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

    custom::defgroup Chess [::msgcat::mc "Chess plugin options."] \
        -group Plugins
    custom::defvar options(theme) Classic \
        [::msgcat::mc "Chess figures theme."] -group Chess \
        -type options -values $values \
        -command [namespace current]::load_stored_theme
    custom::defvar options(flip_black_view) 1 \
        [::msgcat::mc "Flip board view when playing black by default."] \
        -type boolean -group Chess
    custom::defvar options(show_last_move) 0 \
        [::msgcat::mc "Show last move by default."] \
        -type boolean -group Chess
    custom::defvar options(always_queen) 0 \
        [::msgcat::mc "Promote pawns always as queens."] \
        -type boolean -group Chess
    custom::defvar options(show_tooltips) 1 \
        [::msgcat::mc "Show tooltips with short instructions."] \
        -type boolean -group Chess \
        -command [list [namespace current]::set_tooltips]
    custom::defvar options(sound) "" \
        [::msgcat::mc "Sound to play after opponent's turn"] \
        -type file -group Chess
    custom::defvar options(allow_illegal) 0 \
        [::msgcat::mc "Allow illegal moves (useful for debugging)."] \
        -type boolean -group Chess
    custom::defvar options(accept_illegal) 0 \
        [::msgcat::mc "Accept opponent illegal moves (useful for\
                       debugging)."] \
        -type boolean -group Chess
}

proc chess::load {} {
    hook::add roster_create_groupchat_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48
    hook::add chat_create_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48
    hook::add roster_jid_popup_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48

    hook::add games_board_create_hook [namespace current]::iq_create
    hook::add games_board_turn_hook [namespace current]::iq_turn

    ::xmpp::iq::register set create games:board \
                         [namespace parent]::iq_games_board_create
    ::xmpp::iq::register set turn games:board \
                         [namespace parent]::iq_games_board_turn

    load_stored_theme
    calc_moves
}

proc chess::unload {} {
    hook::remove roster_create_groupchat_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48
    hook::remove chat_create_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48
    hook::remove roster_jid_popup_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48

    hook::remove games_board_create_hook [namespace current]::iq_create
    hook::remove games_board_turn_hook [namespace current]::iq_turn

    if {[hook::is_empty games_board_create_hook]} {
        ::xmpp::iq::unregister set create games:board
        rename [namespace parent]::iq_games_board_create ""
    }

    if {[hook::is_empty games_board_turn_hook]} {
        ::xmpp::iq::unregister set turn games:board
        rename [namespace parent]::iq_games_board_turn ""
    }

    foreach var [info vars [namespace current]::*] {
        upvar #0 $var flags
        if {[info exists flags(window)]} {
            destroy_win $flags(window)
        }
    }

    foreach var [info vars [namespace current]::*] {
        if {$var ne "[namespace current]::options"} {
            unset $var
        }
    }

    foreach img [image names] {
        if {[string first chess/ $img] == 0} {
            image delete $img
        }
    }
}

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

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

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

proc chess::invite_dialog {xlib jid} {
    set w .chess_invite

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

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

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

    pack $wf.message -pady 2m

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

    $w draw
}

proc chess::invite {xlib jid color} {
    destroy .chess_invite

    set id chess[rand 1000000000]

    # FIX
    #set rjid [get_jid_of_user $jid]

    ::xmpp::sendIQ $xlib set \
        -query [::xmpp::xml::create create \
                        -xmlns games:board \
                        -attrs [list type chess \
                                     id $id \
                                     color $color]] \
        -to $jid \
        -command [list [namespace current]::invite_res $xlib $jid $id $color]
}

proc chess::invite_res {xlib jid id color status xml} {
    if {![string equal $status ok]} {
        after idle [list NonmodalMessageDlg .chess_invite_error \
            -aspect 50000 -icon error \
            -message [::msgcat::mc "%s (%s) has refused chess invitation: %s" \
                                   [get_nick $xlib $jid chat] \
                                   $jid [error_to_string $xml]]]
        return ""
    }

    start_play $xlib $jid $id $color
}


proc chess::invited_dialog {xlib jid iqid id color} {
    set w .chess_invited

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

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

    set wf [$w getframe]
    bind $wf <Destroy> [namespace code [list invited_res $w $xlib $jid \
                                                         $iqid $id $color 0]]

    set nick [get_nick $xlib $jid chat]
    set message1 \
        [::msgcat::mc "Chess game invitation from %s (%s) is received." \
                      $nick $jid]
    switch -- $color {
        white {
            set message2 [::msgcat::mc "%s wants play white." $nick]
        }
        black {
            set message2 [::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
    pack $wf.message1 -pady 1m
    pack $wf.message2 -pady 1m

    $w add -text [::msgcat::mc "Agree to play"] \
           -command [namespace code [list invited_res $w $xlib $jid \
                                                      $iqid $id $color 1]]
    $w add -text [::msgcat::mc "Refuse to play"] \
           -command [namespace code [list invited_res $w $xlib $jid \
                                                      $iqid $id $color 0]]

    $w draw
    return
}

proc chess::invited_res {w xlib jid iqid id color res} {
    catch {
        set wf [$w getframe]
        bind $wf <Destroy> {}
        destroy $w
    }

    if {$res} {
        switch -- $color {
            white {
                start_play $xlib $jid $id black
            }
            black {
                start_play $xlib $jid $id white
            }
            default {
                ::xmpp::sendIQ $xlib error \
                               -error [::xmpp::stanzaerror::error \
                                                modify bad-request] \
                               -to $jid \
                               -id $iqid
            }
        }

        ::xmpp::sendIQ $xlib result \
                       -query [::xmpp::xml::create create \
                                        -xmlns games:board \
                                        -attrs [list type chess \
                                                     id $id]] \
                       -to $jid \
                       -id $iqid
    } else {
        ::xmpp::sendIQ $xlib error \
                       -error [::xmpp::stanzaerror::error \
                                        modify not-acceptable] \
                       -to $jid \
                       -id $iqid
    }
    return
}

proc chess::start_play {xlib jid id color} {
    set gid [make_gid $jid $id]
    variable $gid
    variable options
    upvar 0 $gid flags

    set flags(window) [win_id chess $gid]
    set flags(xlib) $xlib
    set flags(opponent) $jid
    set flags(id) $id
    set flags(flip) 0
    set flags(our_color) $color

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

    make_default_position $gid

    open $gid
}

proc chess::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 chess::make_default_position {gid} {
    variable $gid
    upvar 0 $gid flags

    for {set c 0} {$c < 8} {incr c} {
        for {set r 0} {$r < 8} {incr r} {
            set flags(position,$c,$r) ""
        }
    }
    for {set c 0} {$c < 8} {incr c} {
        set flags(position,$c,1) wp
        set flags(position,$c,6) bp
    }
    set c 0
    foreach f {r n b q k b n r} {
        set flags(position,$c,0) w$f
        set flags(position,$c,7) b$f
        incr c
    }
    set flags(position,wk,c) 4
    set flags(position,wk,r) 0
    set flags(position,bk,c) 4
    set flags(position,bk,r) 7

    set flags(position,wk,kcastling) 1
    set flags(position,wk,qcastling) 1
    set flags(position,bk,kcastling) 1
    set flags(position,bk,qcastling) 1
    set flags(position,enpassant) {}

    set flags(position,turn) white

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

    set flags(position,repetitions) [list [code_position $gid] 1]
}

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

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

proc chess::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 chess::code_position {gid} {
    variable $gid
    upvar 0 $gid flags

    set code ""
    for {set c 0} {$c < 8} {incr c} {
        for {set r 0} {$r < 8} {incr r} {
            switch -- $flags(position,$c,$r) {
                wk {append code K}
                wq {append code Q}
                wr {append code R}
                wb {append code B}
                wn {append code N}
                wp {append code P}
                bk {append code k}
                bq {append code q}
                br {append code r}
                bb {append code b}
                bn {append code n}
                bp {append code p}
                default {append code .}
            }
        }
    }

    append code $flags(position,wk,kcastling)
    append code $flags(position,wk,qcastling)
    append code $flags(position,bk,kcastling)
    append code $flags(position,bk,qcastling)

    if {[llength $flags(position,enpassant)] > 0} {
        lassign $flags(position,enpassant) c r
        set cp1 [expr {$c + 1}]
        set cm1 [expr {$c - 1}]
        if {$r == 2} {
            if {($cp1 < 8 && $flags(position,$cp1,3) == "bp") || \
                    ($cm1 >= 0 && $flags(position,$cm1,3) == "bp")} {
                append code $c$r
            }
        } elseif {$r == 5} {
            if {($cp1 < 8 && $flags(position,$cp1,4) == "wp") || \
                    ($cm1 >= 0 && $flags(position,$cm1,4) == "wp")} {
                append code $c$r
            }
        }
    }

    return $code
}

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

proc chess::turn_recv {gid xmlList} {
    variable options
    variable prom_rev
    variable $gid
    upvar 0 $gid flags

    set move 0
    set draw 0

    foreach xml $xmlList {
        ::xmpp::xml::split $xml tag xmlns attrs cdata subels
        switch -- $tag {
            move {
                set pos [::xmpp::xml::getAttr $attrs pos]
                set poss [split $pos ";"]
                if {[llength $poss] == 2} {
                    set pos1 [split [lindex $poss 0] ,]
                    set pos2 [split [lindex $poss 1] ,]
                    if {[llength $pos1] == 2 && [llength $pos2] == 2} {
                        set cf [lindex $pos1 0]
                        set rf [lindex $pos1 1]
                        set ct [lindex $pos2 0]
                        set rt [lindex $pos2 1]
                        set prom ""
                        foreach subel $subels {
                            ::xmpp::xml::split $subel \
                                        stag sxmlns sattrs scdata ssubels
                            if {$stag == "promotion"} {
                                if {[info exists prom_rev($scdata)]} {
                                    set prom $prom_rev($scdata)
                                }
                            }
                        }
                        set move 1
                        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 [::xmpp::xml::create turn \
                                            -xmlns games:board \
                                            -attrs [list type chess \
                                                         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 [::xmpp::xml::create turn \
                                                -xmlns games:board \
                                                -attrs [list type chess \
                                                             id $flags(id)]]]
                } else {
                    return [list error modify not-acceptable]
                }
            }
            draw {
                set draw 1
            }
        }
    }

    if {$move && [do_move $gid $cf $rf $ct $rt $prom $draw]} {
        update_controls $gid $draw
        draw_position $gid
        highlight_last_move $gid

        return [list result [::xmpp::xml::create turn \
                                    -xmlns games:board \
                                    -attrs [list type chess \
                                                 id $flags(id)]]]
    } else {
        return [list error modify not-acceptable]
    }
}


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

proc chess::calc_moves {} {
    variable moves

    for {set c 0} {$c < 8} {incr c} {
        for {set r 0} {$r < 8} {incr r} {
            for {set moves(d1,$c,$r) {}; \
                        set x [expr {$c+1}]; set y [expr {$r+1}]} \
                {($x < 8) && ($y < 8)} {incr x; incr y} {
                lappend moves(d1,$c,$r) $x $y
            }
            for {set moves(d2,$c,$r) {}; \
                        set x [expr {$c-1}]; set y [expr {$r+1}]} \
                {($x >= 0) && ($y < 8)} {incr x -1; incr y} {
                lappend moves(d2,$c,$r) $x $y
            }
            for {set moves(d3,$c,$r) {}; \
                        set x [expr {$c-1}]; set y [expr {$r-1}]} \
                {($x >= 0) && ($y >= 0)} {incr x -1; incr y -1} {
                lappend moves(d3,$c,$r) $x $y
            }
            for {set moves(d4,$c,$r) {}; \
                        set x [expr {$c+1}]; set y [expr {$r-1}]} \
                {($x < 8) && ($y >= 0)} {incr x; incr y -1} {
                lappend moves(d4,$c,$r) $x $y
            }
            for {set moves(h1,$c,$r) {}; set x [expr {$c+1}]} \
                {$x < 8} {incr x} {
                lappend moves(h1,$c,$r) $x $r
            }
            for {set moves(h2,$c,$r) {}; set x [expr {$c-1}]} \
                {$x >= 0} {incr x -1} {
                lappend moves(h2,$c,$r) $x $r
            }
            for {set moves(v1,$c,$r) {}; set y [expr {$r+1}]} \
                {$y < 8} {incr y} {
                lappend moves(v1,$c,$r) $c $y
            }
            for {set moves(v2,$c,$r) {}; set y [expr {$r-1}]} \
                {$y >= 0} {incr y -1} {
                lappend moves(v2,$c,$r) $c $y
            }
            set moves(n,$c,$r) {}
            foreach {dx dy} {1 2 -1 2 -2 1 -2 -1 -1 -2 1 -2 2 -1 2 1} {
                    set x [expr {$c + $dx}]
                    set y [expr {$r + $dy}]
                if {($x >= 0) && ($x < 8) && ($y >= 0) && ($y < 8)} {
                    lappend moves(n,$c,$r) $x $y
                }
            }
            set moves(wpt,$c,$r) {}
            if {$r <= 6} {
                if {$c <= 6} {
                    lappend moves(wpt,$c,$r) [expr {$c + 1}] [expr {$r + 1}]
                }
                if {$c >= 1} {
                    lappend moves(wpt,$c,$r) [expr {$c - 1}] [expr {$r + 1}]
                }
            }
            set moves(bpt,$c,$r) {}
            if {$r >= 1} {
                if {$c <= 6} {
                    lappend moves(bpt,$c,$r) [expr {$c + 1}] [expr {$r - 1}]
                }
                if {$c >= 1} {
                    lappend moves(bpt,$c,$r) [expr {$c - 1}] [expr {$r - 1}]
                }
            }
            set moves(k,$c,$r) {}
            foreach {dx dy} {0 1 -1 1 -1 0 -1 -1 0 -1 1 -1 1 0 1 1} {
                set x [expr {$c + $dx}]
                set y [expr {$r + $dy}]
                if {($x >= 0) && ($x < 8) && ($y >= 0) && ($y < 8)} {
                    lappend moves(k,$c,$r) $x $y
                }
            }
        }
    }
}

proc chess::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 chess::close {gid} {
    variable $gid
    upvar 0 $gid flags

    array unset flags
}

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

proc chess::button_update_relief {b flag} {
    set rstate [expr {$flag? {pressed} : {!$pressed}}]
    if {[catch {$b state $rstate}]} {
        set relief [expr {$flag? "sunken" : "raised"}]
        $b configure -relief $relief
    }
}

proc chess::open {gid} {
    variable options
    variable square_size
    variable line_width
    variable piece_name
    variable $gid
    upvar 0 $gid flags

    set jid $flags(opponent)

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

    set title [::msgcat::mc "Chess with %s" [get_nick $flags(xlib) $jid chat]]
    add_win $w -title $title \
               -tabtitle $title \
               -class Chess \
               -raise 1

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

    set flags(board) $board

    set flags(show_last_move) $options(show_last_move)
    set slm [Button $w.show_last_move -text [::msgcat::mc "Show last move"] \
                -command [list [namespace current]::toggle_show_last_move \
                               $gid]]
    button_update_relief $slm $flags(show_last_move)
    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"] \
                -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]
    set flags(propose_draw_button) \
        [$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}]
            set img [expr {($c+$r) % 2 ? "bf" : "wf"}]

            $board create image $x1 $y1 -image chess/$img -anchor nw \
                -tags [list background [list cr $c [expr {7-$r}]]]
            $board create rectangle $x1 $y1 $x2 $y2 \
                -outline {} \
                -tags [list square [list cr $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_black $flags(our_color)] && $options(flip_black_view)} {
        toggle_flip_view $gid
    }

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

proc chess::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 $c $r]
            $board dtag [list cr $c $r]
        }
    }

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

    button_update_relief $flags(flip_button) $flags(flip)
    draw_position $gid
    highlight_last_move $gid
}

proc chess::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 chess::toggle_show_last_move {gid} {
    variable $gid
    upvar 0 $gid flags

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

    button_update_relief $flags(show_last_move_button) $flags(show_last_move)

    highlight_last_move $gid
}

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

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

    button_update_relief $flags(propose_draw_button) $flags(position,draw)
}

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

    button_update_relief $flags(propose_draw_button) 0

    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 chess::end_game {gid my_score message} {
    variable $gid
    upvar 0 $gid flags

    set opponent_score [expr {1 - $my_score}]

    if {[is_white $flags(our_color)]} {
        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 chess::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} {
            if {$flags(position,$c,$r) != ""} {
                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 chess/$flags(position,$c,$r) \
                    -tags [list figure $flags(position,$c,$r) [list cr $c $r]]
            }
        }
    }
}

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

    set board $flags(board)

    lassign [lsearch -inline -regexp [$board gettags current] ^cr] cr \
        flags(currentc) flags(currentr)

    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(currentc) $flags(currentr)
}

proc chess::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 legal&&square -outline blue
    $board addtag dst_sq overlapping $x $y $x $y
    lassign [lsearch -inline -regexp [$board gettags dst_sq&&background] ^cr] \
        cr c r
    $board addtag dst_sq withtag [list cr $c $r]&&square
    $board itemconfigure dst_sq&&square -outline red
    $board itemconfigure dst_sq&&legal&&square -outline white
}

proc chess::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 [lsearch -inline -regexp [$board gettags dst_sq&&background] ^cr] \
        cr c r
    $board dtag dst_sq

    if {$options(allow_illegal) || [is_my_move $gid]} {
        do_move $gid $flags(currentc) $flags(currentr) \
                $c $r "" $flags(position,draw)
    }

    update_controls $gid
    draw_position $gid

    unhighlight_legal_moves $gid

    highlight_last_move $gid
}

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

    $flags(board) itemconfigure square -outline ""
    $flags(board) itemconfigure square -outline ""

    if {[catch {lassign $flags(position,last_move) cf rf ct rt}]} {
        return
    }

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

    $flags(board) itemconfigure [list cr $cf $rf]&&square -outline $color
    $flags(board) itemconfigure [list cr $ct $rt]&&square -outline $color
}

proc chess::do_move {gid cf rf ct rt prom draw} {
    variable options
    variable $gid
    upvar 0 $gid flags

    if {$cf == $ct && $rf == $rt || $ct == "" || $rt == ""} {
        return 0
    }

    set opts "-"
    set prm ""
    set suffix ""
    set checkmate 0
    set stalemate 0
    set my_move [is_my_move $gid]

    if {![is_move_legal $gid $cf $rf $ct $rt]} {
        if {$my_move && !$options(allow_illegal)} {
            return 0
        }
        if {!$my_move && !$options(accept_illegal)} {
            return 0
        }
    }

    save_position $gid

    if {$flags(position,$ct,$rt) != ""} {
        set opts ":"
    }
    set f $flags(position,$cf,$rf)
    set flags(position,$ct,$rt) $flags(position,$cf,$rf)
    set flags(position,$cf,$rf) ""

    if {$flags(position,$ct,$rt) == "wk"} {
        set flags(position,wk,c) $ct
        set flags(position,wk,r) $rt
    } elseif {$flags(position,$ct,$rt) == "bk"} {
        set flags(position,bk,c) $ct
        set flags(position,bk,r) $rt
    }

    if {[is_white $flags(position,turn)]} {
        set p "w"
        set opp "b"
        set r 0
    } else {
        set p "b"
        set opp "w"
        set r 7
    }

    if {$rt == (7 - $r)} {
        if {$ct == 0} {
            set flags(position,${opp}k,qcastling) 0
        } elseif {$ct == 7} {
            set flags(position,${opp}k,kcastling) 0
        }
    }
    if {$flags(position,$ct,$rt) == "${p}k"} {
        set flags(position,${p}k,kcastling) 0
        set flags(position,${p}k,qcastling) 0
        if {($ct - $cf) == 2} {
            set opts {0-0}
            set flags(position,5,$r) "${p}r"
            set flags(position,7,$r) ""
        } elseif {($ct - $cf) == -2} {
            set opts {0-0-0}
            set flags(position,3,$r) "${p}r"
            set flags(position,0,$r) ""
        }
    } elseif {$flags(position,$ct,$rt) == "${p}r"} {
        if {($cf == 0) && ($rf == $r)} {
            set flags(position,${p}k,qcastling) 0
        } elseif {($cf == 7) && ($rf == $r)} {
            set flags(position,${p}k,kcastling) 0
        }
    }

    set enpassant 0
    if {$flags(position,$ct,$rt) == "${p}p"} {
        if {(($p == "w") && ($rt == 7)) || \
            (($p == "b") && ($rt == 0))} {
            if {$my_move} {
                set promote [promote_pawn $gid $p]
                if {$promote == -1} {
                    set flags(position,$ct,$rt) "${p}q"
                } else {
                    set flags(position,$ct,$rt) $promote
                }
            } else {
                if {$prom != ""} {
                    set flags(position,$ct,$rt) "${p}$prom"
                }
                # If we are here, then it's an error...
            }
            set prm $flags(position,$ct,$rt)
        } elseif {$flags(position,enpassant) == [list $ct $rt]} {
            if {[is_white $flags(position,turn)]} {
                set flags(position,$ct,4) ""
            } else {
                set flags(position,$ct,3) ""
            }
            set opts ":"
        } else {
            if {($rt - $rf) == 2} {
                set flags(position,enpassant) [list $ct [expr {$rt - 1}]]
                set enpassant 1
            } elseif {($rt - $rf) == -2} {
                set flags(position,enpassant) [list $ct [expr {$rt + 1}]]
                set enpassant 1
            }
        }
    }

    if {!$enpassant} {
        set flags(position,enpassant) {}
    }

    set flags(position,last_move) [list $cf $rf $ct $rt]

    if {[is_white $flags(position,turn)]} {
        set flags(position,turn) black
        set check [test_check $gid \
                              $flags(position,bk,c) $flags(position,bk,r) \
                              $flags(position,bk,c) $flags(position,bk,r)]
    } else {
        set flags(position,turn) white
        set check [test_check $gid \
                              $flags(position,wk,c) $flags(position,wk,r) \
                              $flags(position,wk,c) $flags(position,wk,r)]
    }

    find_legal_moves $gid $flags(position,turn)

    if {$check} {
        if {[llength $flags(legal_moves)] == 0} {
            set suffix "#"
            set draw 0
            set checkmate 1
        } else {
            set suffix "+"
        }
    } else {
        if {[llength $flags(legal_moves)] == 0} {
            set stalemate 1
        }
    }
    if {$draw} {
        append suffix "="
    }
    lappend opts $prm $suffix
    add_move_to_history $gid $cf $rf $ct $rt $f $opts

    set repetitions [add_to_repetitions $gid]

    if {$draw && !$my_move} {
        attention_message $gid \
            [::msgcat::mc "\n\n Opponent proposes a draw\n\n"]
    }

    if {$my_move} {
        send_move $gid $cf $rf $ct $rt $prm
    }

    if {$stalemate} {
        # Draw by stalemate
        end_game $gid 0.5 [::msgcat::mc "Draw (Stalemate)"]
    } elseif {$repetitions >= 3} {
        # Draw by repetition
        end_game $gid 0.5 [::msgcat::mc "Draw (Repetition)"]
    } elseif {$checkmate} {
        if {$my_move} {
            # I win
            end_game $gid 1 [::msgcat::mc "You win (Checkmate)"]
        } else {
            # Opponent wins
            end_game $gid 0 [::msgcat::mc "Opponent wins (Checkmate)"]
        }
    }

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

proc chess::promote_pawn {gid color} {
    variable options
    variable square_size
    variable line_width
    variable $gid
    upvar 0 $gid flags

    if {$options(always_queen)} {
        return -1
    }

    set w .promote
    if {[winfo exists $w]} {
        destroy $w
    }

    Dialog .promote -title [::msgcat::mc "Pawn promotion"] \
        -anchor e -default 0

    set fr [Frame $w.fr]
    set select [canvas $w.select \
        -borderwidth 0 \
        -highlightthickness 0 \
        -width [expr {($square_size + $line_width) * 4 + $line_width}] \
        -height [expr {($square_size + 2 * $line_width)}]]

    pack $fr -padx 3m -pady 1m
    pack $select -padx 3m -pady 1m

    set c 0
    foreach fig {q r b n} {
        set img [expr {$c % 2 ? "bf" : "wf"}]
        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) * 0)}]
        set y2 [expr {($square_size + $line_width) * (0 + 1)}]
        $select create image $x1 $y1 -image chess/$img -anchor nw \
            -tags [list background fg$fig]
        $select create image $x1 $y1 -image chess/$color$fig -anchor nw \
            -tags [list figure fg$fig]
        $select create rectangle $x1 $y1 $x2 $y2 \
                -outline {} \
                -tags [list square fg$fig]
        incr c
    }

    bind $select <Any-Enter> \
         [list [namespace current]::promotion:motion %W %x %y]
    bind $select <Any-Motion> \
         [list [namespace current]::promotion:motion %W %x %y]
    bind $select <Any-Leave> \
         [list [namespace current]::promotion:leave %W %x %y]
    foreach fig {q r b n} {
        $select bind fg$fig <ButtonRelease-1> \
            [list Dialog::enddialog $w $color$fig]
    }

    $w draw
}

proc chess::promotion:motion {c x y} {

    set x [$c canvasx $x]
    set y [$c canvasy $y]

    $c itemconfigure dst_sq&&square -outline ""
    $c dtag dst_sq

    $c addtag dst_sq overlapping $x $y $x $y
    set tags [$c gettags dst_sq&&background]
    set tag [lindex $tags [lsearch $tags fg*]]
    if {$tag != ""} {
        $c addtag dst_sq withtag $tag&&square
    }

    $c itemconfigure dst_sq&&square -outline blue
}

proc chess::promotion:leave {c x y} {
    $c itemconfigure dst_sq&&square -outline ""
    $c dtag dst_sq
}

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

    ::xmpp::sendIQ $flags(xlib) set \
        -query [::xmpp::xml::create turn \
                        -xmlns games:board \
                        -attrs [list type chess \
                                     id $flags(id)] \
                        -subelement [::xmpp::xml::create accept]] \
        -to $flags(opponent)

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

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

    ::xmpp::sendIQ $flags(xlib) set \
        -query [::xmpp::xml::create turn \
                        -xmlns games:board \
                        -attrs [list type chess \
                                     id $flags(id)] \
                        -subelement [::xmpp::xml::create resign]] \
        -to $flags(opponent)

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

proc chess::send_move {gid cf rf ct rt prom} {
    variable $gid
    upvar 0 $gid flags

    set move_tags [list [make_move_tag $gid $cf $rf $ct $rt $prom]]
    if {$flags(position,draw)} {
        lappend move_tags [::xmpp::xml::create draw]
    }

    ::xmpp::sendIQ $flags(xlib) set \
        -query [::xmpp::xml::create turn \
                        -xmlns games:board \
                        -attrs [list type chess \
                                     id $flags(id)] \
                        -subelements $move_tags] \
        -to $flags(opponent) \
        -command [list [namespace current]::send_result $gid]
}

proc chess::send_result {gid status xml} {
    if {$status == "error"} {
        attention_message $gid \
            [::msgcat::mc "\n\n Opponent rejected move:\n %s\n\n" \
                          [error_to_string $xml]]
        restore_position $gid
    }
}

proc chess::make_move_tag {gid cf rf ct rt prom} {
    variable prom_name

    if {$prom == ""} {
        ::xmpp::xml::create move \
                -attrs [list pos "$cf,$rf;$ct,$rt"]
    } else {
        set f [string index $prom 1]
        ::xmpp::xml::create move \
                -attrs [list pos "$cf,$rf;$ct,$rt"] \
                -subelement [::xmpp::xml::create promotion \
                                    -cdata $prom_name($f)]
    }
}

proc chess::add_to_repetitions {gid} {
    variable $gid
    upvar 0 $gid flags

    array set repetitions $flags(position,repetitions)
    set code [code_position $gid]
    if {[info exists repetitions($code)]} {
        incr repetitions($code)
    } else {
        set repetitions($code) 1
    }
    set flags(position,repetitions) [array get repetitions]
    return $repetitions($code)
}

proc chess::add_move_to_history {gid cf rf ct rt f opts} {
    variable piece_name
    variable $gid
    upvar 0 $gid flags

    incr flags(position,halfmove) 1

    lappend flags(position,history) [list $cf $rf $ct $rt $f $opts]

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

    $hw insert end "\t[::msgcat::mc White]\t[::msgcat::mc Black]\n"
    set i 1
    foreach {w b} $flags(position,history) {
        $hw insert end "${i}.\t"
        if {$w != {}} {
            lassign $w cf rf ct rt f opts
            lassign $opts opt prom check
            if {$prom == ""} {
                set m ""
            } else {
                set m $piece_name($prom)
            }
            if {($opt == "0-0") || ($opt == "0-0-0")} {
                $hw insert end "$opt$check\t"
            } else {
                incr rf
                incr rt
                set lf [format %c [expr {$cf+97}]]
                set lt [format %c [expr {$ct+97}]]
                set n $piece_name($f)
                $hw insert end "$n${lf}$rf${opt}${lt}$rt$m$check\t"
            }
        }
        if {$b != {}} {
            lassign $b cf rf ct rt f opts
            lassign $opts opt prom check
            if {$prom == ""} {
                set m ""
            } else {
                set m $piece_name($prom)
            }
            if {($opt == "0-0") || ($opt == "0-0-0")} {
                $hw insert end "$opt$check\n"
            } else {
                incr rf
                incr rt
                set lf [format %c [expr {$cf+97}]]
                set lt [format %c [expr {$ct+97}]]
                set n $piece_name($f)
                $hw insert end "$n${lf}$rf${opt}${lt}$rt$m$check\n"
            }
        }
        incr i
    }
    $hw see end
    $hw configure -state disabled
}

proc chess::find_pseudo_legal_moves {gid color callback} {
    variable moves
    variable $gid
    upvar 0 $gid flags

    set c [string index $color 0]

    for {set cf 0} {$cf < 8} {incr cf} {
        for {set rf 0} {$rf < 8} {incr rf} {
            if {[string index $flags(position,$cf,$rf) 0] != $c} {
                continue
            }

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

                wp {
                    set rt [expr {$rf + 1}]
                    if {$rf < 7 && $flags(position,$cf,$rt) == ""} {
                        if {$rf == 6} {
                            eval $callback $gid $cf $rf $cf $rt promotion
                        } else {
                            eval $callback $gid $cf $rf $cf $rt
                        }
                    }

                    if {$rf == 1 && $flags(position,$cf,2) == "" && \
                            $flags(position,$cf,3) == ""} {
                        eval $callback $gid $cf $rf $cf 3
                    }

                    foreach {ct rt} $moves(wpt,$cf,$rf) {
                        if {[is_black $flags(position,$ct,$rt)] || \
                              ($flags(position,enpassant) == [list $ct $rt])} {
                            if {$rf == 6} {
                                eval $callback $gid $cf $rf $ct $rt promotion
                            } else {
                                eval $callback $gid $cf $rf $ct $rt
                            }
                        }
                    }
                }

                bp {
                    set rt [expr {$rf - 1}]
                    if {$rf > 0 && $flags(position,$cf,$rt) == ""} {
                        if {$rf == 1} {
                            eval $callback $gid $cf $rf $cf $rt promotion
                        } else {
                            eval $callback $gid $cf $rf $cf $rt
                        }
                    }

                    if {$rf == 6 && $flags(position,$cf,5) == "" && \
                            $flags(position,$cf,4) == ""} {
                        eval $callback $gid $cf $rf $cf 4
                    }

                    foreach {ct rt} $moves(bpt,$cf,$rf) {
                        if {[is_white $flags(position,$ct,$rt)] || \
                                $flags(position,enpassant) == [list $ct $rt]} {
                            if {$rf == 1} {
                                eval $callback $gid $cf $rf $ct $rt promotion
                            } else {
                                eval $callback $gid $cf $rf $ct $rt
                            }
                        }
                    }
                }

                wn -
                bn {
                    foreach {ct rt} $moves(n,$cf,$rf) {
                        if {[is_same_color $flags(position,$cf,$rf) \
                                 $flags(position,$ct,$rt)]} \
                            continue
                        eval $callback $gid $cf $rf $ct $rt
                    }
                }

                wb -
                bb {
                    foreach d {d1 d2 d3 d4} {
                        foreach {ct rt} $moves($d,$cf,$rf) {
                            if {[is_same_color $flags(position,$cf,$rf) \
                                 $flags(position,$ct,$rt)]} \
                                break
                            eval $callback $gid $cf $rf $ct $rt
                            if {$flags(position,$ct,$rt) != ""} \
                                break
                        }
                    }
                }

                wr -
                br {
                    foreach d {h1 h2 v1 v2} {
                        foreach {ct rt} $moves($d,$cf,$rf) {
                            if {[is_same_color $flags(position,$cf,$rf) \
                                $flags(position,$ct,$rt)]} \
                                break
                            eval $callback $gid $cf $rf $ct $rt
                            if {$flags(position,$ct,$rt) != ""} \
                                break
                        }
                    }
                }

                wq -
                bq {
                    foreach d {d1 d2 d3 d4 h1 h2 v1 v2} {
                        foreach {ct rt} $moves($d,$cf,$rf) {
                            if {[is_same_color $flags(position,$cf,$rf) \
                                $flags(position,$ct,$rt)]} \
                                break
                            eval $callback $gid $cf $rf $ct $rt
                            if {$flags(position,$ct,$rt) != ""} \
                                break
                        }
                    }
                }

                wk {
                    foreach {ct rt} $moves(k,$cf,$rf) {
                        if {[is_same_color $flags(position,$cf,$rf) \
                                 $flags(position,$ct,$rt)]} \
                            continue
                        eval $callback $gid $cf $rf $ct $rt
                    }
                    if {($cf == 4) && ($rf == 0)} {
                        if {$flags(position,wk,kcastling) && \
                                $flags(position,5,0) == "" && \
                                $flags(position,6,0) == ""} {
                            eval $callback $gid 4 0 6 0 kcastling
                        }
                        if {$flags(position,wk,qcastling) && \
                                $flags(position,3,0) == "" && \
                                $flags(position,2,0) == "" && \
                                $flags(position,1,0) == ""} {
                            eval $callback $gid 4 0 2 0 qcastling
                        }
                    }
                }
                bk {
                    foreach {ct rt} $moves(k,$cf,$rf) {
                        if {[is_same_color $flags(position,$cf,$rf) \
                                 $flags(position,$ct,$rt)]} \
                            continue
                        eval $callback $gid $cf $rf $ct $rt
                    }
                    if {($cf == 4) && ($rf == 7)} {
                        if {$flags(position,bk,kcastling) && \
                                $flags(position,5,7) == "" && \
                                $flags(position,6,7) == ""} {
                            eval $callback $gid 4 7 6 7 kcastling
                        }
                        if {$flags(position,bk,qcastling) && \
                                $flags(position,3,7) == "" && \
                                $flags(position,2,7) == "" && \
                                $flags(position,1,7) == ""} {
                            eval $callback $gid 4 7 2 7 qcastling
                        }
                    }
                }
            }
        }
    }
}

proc chess::find_legal_moves {gid color} {
    variable $gid
    upvar 0 $gid flags

    set flags(legal_moves) {}
    find_pseudo_legal_moves $gid $color check_legal_callback
}

proc chess::check_legal_callback {gid cf rf ct rt {opt ""}} {
    variable $gid
    upvar 0 $gid flags

    if {![test_check $gid $cf $rf $ct $rt $opt]} {
        lappend flags(legal_moves) [list $cf $rf $ct $rt $opt]
    }
}

proc chess::test_check {gid cf rf ct rt {opt ""}} {
    variable $gid
    upvar 0 $gid flags

    set enpassantback ""
    set enpassantx ""
    set enpassanty ""
    if {[is_white $flags(position,turn)]} {
        set color black
        set f wk
        set of bk
        if {($rf == 4) && \
                ($flags(position,$cf,$rf) == "wp") && \
                ($flags(position,enpassant) == [list $ct $rt])} {
            set enpassantback "bp"
            set enpassantx $ct
            set enpassanty [expr {$rt - 1}]
            set flags(position,$enpassantx,$enpassanty) ""
        }
    } else {
        set color white
        set f bk
        set of wk
        if {($rf == 3) && \
                ($flags(position,$cf,$rf) == "bp") && \
                ($flags(position,enpassant) == [list $ct $rt])} {
            set enpassantback "wp"
            set enpassantx $ct
            set enpassanty [expr {$rt + 1}]
            set flags(position,$enpassantx,$enpassanty) ""
        }
    }
    set checks 0

    set back $flags(position,$ct,$rt)
    set flags(position,$ct,$rt) $flags(position,$cf,$rf)
    set flags(position,$cf,$rf) ""
    if {$flags(position,$ct,$rt) == "wk"} {
        set flags(position,wk,c) $ct
        set flags(position,wk,r) $rt
    } elseif {$flags(position,$ct,$rt) == "bk"} {
        set flags(position,bk,c) $ct
        set flags(position,bk,r) $rt
    }

    set kc  $flags(position,$f,c)
    set kr  $flags(position,$f,r)
    set okc $flags(position,$of,c)
    set okr $flags(position,$of,r)


    if {$opt == "kcastling"} {
        set kcs [list 4 5 6]
    } elseif {$opt == "qcastling"} {
        set kcs [list 4 3 2]
    } else {
        set kcs [list $kc]
    }

    foreach c $kcs {
        incr checks [test_figures $gid $color $c $kr]
        incr checks [test_pawns $gid $color $c $kr]
        if {[info exists okc]} {
            set dx [expr {abs($c-$okc)}]
            set dy [expr {abs($kr-$okr)}]
            if {($dx <= 1) && ($dy <= 1)} {
                incr checks
            }
        }
    }

    set flags(position,$cf,$rf) $flags(position,$ct,$rt)
    set flags(position,$ct,$rt) $back
    if {$flags(position,$cf,$rf) == "wk"} {
        set flags(position,wk,c) $cf
        set flags(position,wk,r) $rf
    } elseif {$flags(position,$cf,$rf) == "bk"} {
        set flags(position,bk,c) $cf
        set flags(position,bk,r) $rf
    }
    if {$enpassantback != ""} {
        set flags(position,$enpassantx,$enpassanty) $enpassantback
    }

    return $checks
}

proc chess::test_pawns {gid color c r} {
    variable moves
    variable $gid
    upvar 0 $gid flags

    if {[is_white $color]} {
        foreach {x y} $moves(bpt,$c,$r) {
            if {$flags(position,$x,$y) == "wp"} {
                    return 1
            }
        }
    } else {
        foreach {x y} $moves(wpt,$c,$r) {
            if {$flags(position,$x,$y) == "bp"} {
                    return 1
            }
        }
    }
    return 0
}

proc chess::test_figures {gid color c r} {
    variable moves
    variable $gid
    upvar 0 $gid flags

    if {[is_white $color]} {
            foreach i {d1 d2 d3 d4} {
            foreach {x y} $moves($i,$c,$r) {
                switch -- $flags(position,$x,$y) {
                    "" {continue}
                    wq -
                    wb {return 1}
                    default {break}
                }
            }
        }
        foreach i {h1 h2 v1 v2} {
            foreach {x y} $moves($i,$c,$r) {
                switch -- $flags(position,$x,$y) {
                    "" {continue}
                    wq -
                    wr {return 1}
                    default {break}
                }
            }
        }
        foreach {x y} $moves(n,$c,$r) {
            switch -- $flags(position,$x,$y) {
                wn {return 1}
                default {continue}
            }
        }
    } else {
        foreach i {d1 d2 d3 d4} {
            foreach {x y} $moves($i,$c,$r) {
                switch -- $flags(position,$x,$y) {
                    "" {continue}
                    bq -
                    bb {return 1}
                    default {break}
                }
            }
        }
        foreach i {h1 h2 v1 v2} {
            foreach {x y} $moves($i,$c,$r) {
                switch -- $flags(position,$x,$y) {
                    "" {continue}
                    bq -
                    br {return 1}
                    default {break}
                }
            }
        }
        foreach {x y} $moves(n,$c,$r) {
            switch -- $flags(position,$x,$y) {
                bn {return 1}
                default {continue}
            }
        }
    }
    return 0
}

proc chess::is_move_legal {gid cf rf ct rt} {
    variable $gid
    upvar 0 $gid flags

    expr {[lsearch -regexp $flags(legal_moves) ^[list $cf $rf $ct $rt]] >= 0}
}

proc chess::highlight_legal_moves {gid cf rf} {
    variable $gid
    upvar 0 $gid flags

    foreach move \
        [lsearch -all -inline -regexp $flags(legal_moves) ^[list $cf $rf]] {
        lassign $move cft rft ct rt
        $flags(board) addtag legal withtag [list cr $ct $rt]&&square

    }
    $flags(board) itemconfigure legal&&square -outline blue
}

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

    foreach sq [$flags(board) find withtag legal&&square] {
        $flags(board) itemconfigure $sq \
            -outline [$flags(board) itemcget $sq -fill]
    }
    $flags(board) dtag legal
}

proc chess::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 chess::is_my_move {gid} {
    variable $gid
    upvar 0 $gid flags

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

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

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

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

proc chess::add_groupchat_user_menu_item {m xlib 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 "Chess..."] \
        -command [list [namespace current]::invite_dialog $xlib $jid]
}

proc chess::iq_create {varname xlib from iqid xml} {
    upvar 2 $varname var

    ::xmpp::xml::split $xml tag xmlns attrs cdata subels

    if {[::xmpp::xml::getAttr $attrs type] == "chess"} {
        if {[::xmpp::xml::isAttr $attrs color]} {
            set color [::xmpp::xml::getAttr $attrs color]
            switch -- $color {
                white -
                black { }
                default {
                    set var [list error modify bad-request]
                }
            }
        } else {
            set color white
        }
        set var [[namespace current]::invited_dialog \
                     $xlib $from $iqid \
                     [::xmpp::xml::getAttr $attrs id] \
                     $color]
    }
    return
}

proc chess::iq_turn {varname xlib from xml} {
    upvar 2 $varname var

    ::xmpp::xml::split $xml tag xmlns attrs cdata subels

    if {[::xmpp::xml::getAttr $attrs type] == "chess"} {
        set gid [make_gid $from [::xmpp::xml::getAttr $attrs id]]
        if {[exists $gid]} {
            set var [[namespace current]::turn_recv $gid $subels]
        } else {
            set var [list error cancel item-not-found]
        }
    }
    return
}


# Common games:board part
proc iq_games_board_create {xlib from xml args} {
    set res [list error cancel feature-not-implemented]
    set iqid [::xmpp::xml::getAttr $args -id]
    hook::run games_board_create_hook res $xlib $from $iqid $xml
    return $res
}

proc iq_games_board_turn {xlib from xml args} {
    set res [list error cancel feature-not-implemented]
    hook::run games_board_turn_hook res $xlib $from $xml
    return $res
}

# vim:ft=tcl:ts=8:sw=4:sts=4:et
