# battleship.tcl --
#
#       This file implements a Battleship game plugin for the Tkabber XMPP
#       client.

package require msgcat

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

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

    variable winid 0

    package require sha1

    variable square_size 27
    variable line_width 1

    variable board_size 10

    variable ships \
        {carrier 1 battleship 1 destroyer 1 cruiser 2 submarine 2}

    variable sizes \
        {carrier 5 battleship 4 destroyer 3 cruiser 2 submarine 1}

    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 Battleship [::msgcat::mc "Battleship plugin options."] \
        -group Plugins

    custom::defvar options(theme) Copybook \
        [::msgcat::mc "Battleship pixmaps theme."] \
        -group Battleship \
        -type options \
        -values $values \
        -command [namespace code load_stored_theme]
    custom::defvar options(show_last_move) 0 \
        [::msgcat::mc "Show last move by default."] \
        -type boolean -group Battleship
    custom::defvar options(show_tooltips) 1 \
        [::msgcat::mc "Show tooltips with short instructions."] \
        -type boolean -group Battleship \
        -command [namespace code set_tooltips]
}

proc battleship::load {} {
    hook::add postload_hook [namespace current]::load_stored_theme 70

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

    hook::add games_board_create_hook [namespace current]::iq_create
    hook::add games_board_init_hook [namespace current]::iq_init
    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 board games:board \
                         [namespace parent]::iq_games_board_init
    ::xmpp::iq::register set turn games:board \
                         [namespace parent]::iq_games_board_turn

    load_stored_theme
}

proc battleship::unload {} {
    hook::remove postload_hook [namespace current]::load_stored_theme 70

    hook::remove finload_hook [namespace current]::calc_moves 100

    hook::remove roster_create_groupchat_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48.5
    hook::remove chat_create_user_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48.5
    hook::remove roster_jid_popup_menu_hook \
              [namespace current]::add_groupchat_user_menu_item 48.5

    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_init_hook]} {
        ::xmpp::iq::unregister set board games:board
        rename [namespace parent]::iq_games_board_init ""
    }

    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 w [winfo children .] {
        if {[regexp {^\.battleship_invite} $w]} {
            catch {
                set wf [$w getframe]
                bind $wf <Destroy> {}
            }
            destroy $w
        }
    }

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

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

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

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

proc battleship::invite_dialog {xlib jid} {
    variable winid

    set w .battleship_invite[incr winid]

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

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

    $w add -text [::msgcat::mc "I want to move first"] \
        -command [namespace code [list invite $w $xlib $jid true]]
    $w add -text [::msgcat::mc "I want to move second"] \
        -command [namespace code [list invite $w $xlib $jid false]]
    $w add -text [::msgcat::mc "Cancel invitation"] \
        -command [list destroy $w]

    $w draw
}

proc battleship::invite {w xlib jid first} {
    destroy $w

    set id battleship[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 battleship \
                                     id $id \
                                     first $first]] \
        -to $jid \
        -command [namespace code [list invite_res $xlib $jid $id $first]]
}

proc battleship::invite_res {xlib jid id first status xml} {
    variable winid

    if {![string equal $status ok]} {
        set w .battleship_invite_error[incr winid]

        after idle [list NonmodalMessageDlg $w -aspect 50000 -icon error \
            -message [::msgcat::mc "%s (%s) has refused Battleship\
                                    invitation: %s" \
                                   [chat::get_nick $xlib $jid chat] \
                                   $jid [error_to_string $xml]]]
        return ""
    }

    start_play $xlib $jid $id $first
}

proc battleship::invited_dialog {xlib jid iqid id first} {
    variable winid

    set w .battleship_invited[incr winid]

    Dialog $w -title [::msgcat::mc "Battleship 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 $first 0]]

    set nick [chat::get_nick $xlib $jid chat]
    set message1 [::msgcat::mc "Battleship game invitation from %s (%s)\
                                is received." \
                               $nick $jid]
    switch -- $first {
        true -
        1 {
            set message2 [::msgcat::mc "%s wants to move first." $nick]
        }
        false -
        0 {
            set message2 [::msgcat::mc "%s wants to move second." $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 $first 1]]
    $w add -text [::msgcat::mc "Refuse to play"] \
           -command [namespace code \
                        [list invited_res $w $xlib $jid $iqid $id $first 0]]

    $w draw
    return
}

proc battleship::invited_res {w xlib jid iqid id first result} {
    catch {
        set wf [$w getframe]
        bind $wf <Destroy> {}
        destroy $w
    }

    if {$result} {
        switch -- $first {
            true -
            1 {
                start_play $xlib $jid $id false
            }
            false -
            0 {
                start_play $xlib $jid $id true
            }
            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 battleship \
                                                     id $id]] \
                       -to $jid \
                       -id $iqid
    } else {
        ::xmpp::sendIQ $xlib error \
                       -error [::xmpp::stanzaerror::error \
                                        modify not-acceptable] \
                       -to $jid \
                       -id $iqid
    }
    return
}

proc battleship::start_play {xlib jid id first} {
    set gid [make_gid $jid $id]
    variable $gid
    upvar 0 $gid state

    set state(window) [win_id battleship $gid]
    set state(xlib) $xlib
    set state(opponent) $jid
    set state(id) $id
    set state(move_first) $first

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

    open_win $gid
}

proc battleship::set_label_move {gid args} {
    variable $gid
    upvar 0 $gid state

    switch -- $state(position,turn) {
        first -
        second {
            set move 1
        }
        default {
            set move 0
        }
    }
    if {$move && [is_my_move $gid]} {
        if {$state(board_is_sent) && $state(board_is_received)} {
            set state(move_label) [::msgcat::mc "You"]
        } else {
            set state(move_label) \
                [::msgcat::mc "You (after all parties freeze boards)"]
        }
    } else {
        if {$state(board_is_sent) && $state(board_is_received)} {
            set state(move_label) [::msgcat::mc "Opponent"]
        } else {
            set state(move_label) \
                [::msgcat::mc "Opponent (after all parties freeze boards)"]
        }
    }
}

proc battleship::save_position {gid} {
    variable $gid
    upvar 0 $gid state

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

proc battleship::restore_position {gid} {
    variable $gid
    upvar 0 $gid state

    array set state $state(saved_position)
    draw_position $gid
    update_controls $gid
    find_reasonable_moves $gid $state(position,turn)
}

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

proc battleship::board_recv {gid xmlElements} {
    variable board_size
    variable options
    variable $gid
    upvar 0 $gid state

    if {[llength [array names state hash,*]] == 0} {
        # Receiving hashes

        set numhashes 0
        set state(shiphashes) {}

        foreach element $xmlElements {
            ::xmpp::xml::split $element tag xmlns attrs cdata subels
            switch -- $tag {
                cell {
                    set c [::xmpp::xml::getAttr $attrs col]
                    set r [::xmpp::xml::getAttr $attrs row]
                    set hash [::xmpp::xml::getAttr $attrs hash]

                    if {![string is integer -strict $c] || \
                            $c < 0 || $c >= $board_size} {
                        return [list error modify bad-request]
                    }
                    if {![string is integer -strict $r] || \
                            $r < 0 || $r >= $board_size} {
                        return [list error modify bad-request]
                    }
                    if {$hash != "" && ![info exists state(hash,$c,$r)]} {
                        set state(hash,$c,$r) $hash
                        incr numhashes
                    } else {
                        return [list error modify bad-request]
                    }
                }
                ship {
                    lappend state(shiphashes) \
                            [::xmpp::xml::getAttr $attrs hash]
                }
            }
        }

        if {$numhashes == [expr {$board_size * $board_size}]} {
            set state(board_is_received) 1
            set_label_move $gid
            update_controls $gid
            find_reasonable_moves $gid $state(position,turn)

            return [list result {}]
        } else {
            array unset state hash,*
            array unset state shiphashes

            return [list error modify bad-request]
        }
    } else {
        # Checking hashes

        set numhashes 0
        set cells {}

        foreach element $xmlElements {
            ::xmpp::xml::split $element tag xmlns attrs cdata subels
            switch -- $tag {
                cell {
                    set c [::xmpp::xml::getAttr $attrs col]
                    if {![string is integer -strict $c] || \
                            $c < 0 || $c >= $board_size} {
                        attention_message $gid \
                                [::msgcat::mc "\n\n Opponent sent incorrect\
                                               cell column"]
                        return [list error modify bad-request]
                    }

                    set r [::xmpp::xml::getAttr $attrs row]
                    if {![string is integer -strict $r] || \
                            $r < 0 || $r >= $board_size} {
                        attention_message $gid \
                                [::msgcat::mc "\n\n Opponent sent incorrect\
                                               cell row"]
                        return [list error modify bad-request]
                    }

                    set seed [::xmpp::xml::getAttr $attrs seed]
                    if {[::xmpp::xml::getAttr $attrs ship]} {
                        set ship 1
                    } else {
                        set ship 0
                    }

                    if {[sha1::sha1 $seed$ship] ne $state(hash,$c,$r)} {
                        attention_message $gid \
                                [::msgcat::mc "\n\n Opponent sent incorrect\
                                               cell seed"]
                        return [list error modify bad-request]
                    }

                    lappend cells [list $c $r]
                    set board($c,$r) $ship
                    incr numhashes
                }
            }
        }

        if {$numhashes != $board_size*$board_size ||
                [llength [lsort -unique $cells]] != $board_size*$board_size} {
            attention_message $gid \
                    [::msgcat::mc "\n\n Opponent sent incorrect number\
                                   of cells"]
            return [list error modify bad-request]
        }

        if {![test_legal [array get board]]} {
            attention_message $gid \
                    [::msgcat::mc "\n\n Opponent sent illegal board"]
            return [list error modify bad-request]
        }

        return [list result {}]
    }
}

proc battleship::test_legal {boardlist} {
    variable board_size
    variable ships
    variable sizes

    array set board $boardlist
    foreach c [list -1 $board_size] {
        for {set r -1} {$r <= $board_size} {incr r} {
            set board($c,$r) 0
            set board($r,$c) 0
        }
    }

    array set size $sizes

    foreach {name number} $ships {
        for {set i 1} {$i <= $number} {incr i} {
            lassign [find_ship board $size($name)] status c1 r1 c2 r2

            if {!$status} {
                return 0
            }

            for {set c $c1} {$c <= $c2} {incr c} {
                for {set r $r1} {$r <= $r2} {incr r} {
                    set board($c,$r) 0
                }
            }
            for {set c [expr {$c1-1}]} {$c <= $c2+1} {incr c} {
                for {set r [expr {$r1-1}]} {$r <= $r2+1} {incr r} {
                    if {$board($c,$r) == 1} {
                        return 0
                    }
                }
            }
        }
    }
    return 1
}

proc battleship::find_ship {vboard size} {
    variable board_size
    upvar $vboard board

    for {set c1 0} {$c1 < $board_size} {incr c1} {
        for {set r1 0} {$r1 <= $board_size} {incr r1} {
            if {$board($c1,$r1) == 0} continue

            set q 1
            set c2 $c1
            for {set r2 $r1} {$r2 < $r1+$size} {incr r2} {
                if {$board($c2,$r2) == 0} {
                    set q 0
                    break
                }
            }
            if {$q} {
                return [list 1 $c1 $r1 $c2 [incr r2 -1]]
            }

            set q 1
            set r2 $r1
            for {set c2 $c1} {$c2 < $c1+$size} {incr c2} {
                if {$board($c2,$r2) == 0} {
                    set q 0
                    break
                }
            }
            if {$q} {
                return [list 1 $c1 $r1 [incr c2 -1] $r2]
            }
        }
    }
    return {0}
}

proc battleship::turn_recv {gid xmlElements} {
    variable board_size
    variable options
    variable $gid
    upvar 0 $gid state

    set move 0
    set draw 0

    foreach element $xmlElements {
        ::xmpp::xml::split $element tag xmlns attrs cdata subels
        switch -- $tag {
            shot {
                set c [::xmpp::xml::getAttr $attrs col]
                set r [::xmpp::xml::getAttr $attrs row]
                if {![string is integer -strict $c] || \
                        ![string is integer -strict $r] || \
                        $c < 0 || $c >= $board_size || \
                        $r < 0 || $r >= $board_size} {
                    return [list error modify not-acceptable]
                }
                set move 1
            }
            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 battleship \
                                                         id $state(id)]]]
            }
            accept {
                if {$state(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 battleship \
                                                         id $state(id)]]]
                } else {
                    return [list error modify not-acceptable]
                }
            }
            draw {
                set draw 1
            }
        }
    }

    if {$move} {
        set hit 0
        foreach ship $state(position,ships) {
            set sunk 1
            foreach {sc sr} [coordinates $ship] {
                if {$c == $sc && $r == $sr} {
                    set hit 1
                } elseif {$state(position,oshot,$sc,$sr) != 1} {
                    set sunk 0
                }
            }
            if {$hit} {
                break
            }
        }

        if {$hit && $sunk} {
            set result destroy
            lappend state(position,destroyed_my_ships) $ship
        } elseif {$hit} {
            set result hit
        } else {
            set result miss
        }

        if {[do_move $gid $c $r $result $draw]} {
            update_controls $gid $draw
            draw_position $gid
            highlight_last_move $gid

            set subel [::xmpp::xml::create shot \
                                -attrs [list result $result \
                                             seed $state(seed,$c,$r)]]
            return [list result [::xmpp::xml::create turn \
                                        -xmlns games:board \
                                        -attrs [list type battleship \
                                                     id $state(id)] \
                                        -subelement $subel]]
        } else {
            return [list error modify not-acceptable]
        }
    } else {
        return [list error modify not-acceptable]
    }
}

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

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

    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 battleship::nw {c r} {
    variable square_size
    variable line_width

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

proc battleship::onw {c r} {
    variable board_size
    variable square_size
    variable line_width

    list [expr {($square_size + $line_width) * ($board_size + 1) + \
                $line_width + ($square_size + $line_width) * $c}] \
         [expr {$line_width + ($square_size + $line_width) * $r}]
}

proc battleship::close {gid} {
    variable $gid
    upvar 0 $gid state

    array unset state
    catch {unset state}
}

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

proc battleship::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 battleship::open_win {gid} {
    variable options
    variable board_size
    variable square_size
    variable line_width
    variable $gid
    upvar 0 $gid state

    set jid $state(opponent)

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

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

    catch {grid anchor $w center}

    set mylabel [Label $w.mylabel -text [::msgcat::mc "My ships"]]
    set theirlabel [Label $w.theirlabel -text [::msgcat::mc "Opponent ships"]]
    grid $mylabel -row 0 -column 0 -sticky w
    grid $theirlabel -row 0 -column 1 -sticky e

    if {[catch {lindex [$w configure -background] 4} bg]} {
        # Ttk
        set bg [ttk::style lookup TFrame -background]
    }

    set board [canvas $w.board \
                   -borderwidth 0 \
                   -highlightthickness 0 \
                   -background $bg \
                   -width [expr {($square_size + $line_width) *
                                 (2 * $board_size + 1) + $line_width}] \
                   -height [expr {($square_size + $line_width) *
                                  $board_size + $line_width}]]
    grid $board -row 1 -column 0 -columnspan 2 -sticky nw -padx 10 -pady 10

    set state(board) $board
    set state(show_last_move) $options(show_last_move)

    Frame $w.move
    grid $w.move -row 2 -column 0 -columnspan 2 -sticky wn
    Label $w.move.title -text [::msgcat::mc "Move: "]
    pack $w.move.title -side left
    Label $w.move.label -anchor w \
                        -textvariable [namespace current]::${gid}(move_label)
    pack $w.move.label -side left -anchor w

    set bbox [ButtonBox $w.bbox -orient vertical -spacing 0]
    $bbox add -text [::msgcat::mc "Freeze ships position"] \
              -command [namespace code [list send_board $gid]]
    set state(show_last_move_button) \
        [$bbox add -text [::msgcat::mc "Show last move"] \
                   -command [namespace code [list toggle_show_last_move $gid]]]
    button_update_relief $state(show_last_move_button) $state(show_last_move)
    set state(propose_draw_button) \
        [$bbox add -text [::msgcat::mc "Propose a draw"] \
                   -state disabled \
                   -command [namespace code [list toggle_draw $gid]]]
    $bbox add -text [::msgcat::mc "Accept the draw proposal"] \
              -state disabled \
              -command [namespace code [list accept_draw $gid]]
    $bbox add -text [::msgcat::mc "Resign the game"] \
              -state disabled \
              -command [namespace code [list send_resign $gid]]
    grid columnconfigure $bbox 0 -weight 1
    grid $bbox -row 3 -column 1 -sticky wen

    set state(bbox) $bbox

    set_tooltips

    #label $w.history -text [::msgcat::mc "History"]
    #pack $w.history -side top -anchor w
    set hsw [ScrolledWindow $w.hsw]
    grid $hsw -row 3 -column 0 -sticky nwes
    set ht [Text $w.text -wrap word -height 5 -width 25 -state disabled]
    set font [$ht cget -font]
    set tabstop1 [font measure $font "100.."]
    set tabstop2 [font measure $font "100..[::msgcat::mc Opponent]   "]
    $ht configure -tabs "$tabstop1 $tabstop2"
    $ht tag configure attention \
        -foreground [option get $ht errorForeground Text]
    $hsw setwidget $ht
    set state(hw) $ht

    grid columnconfigure $w 0 -weight 0
    grid columnconfigure $w 1 -weight 0
    grid rowconfigure $w 0 -weight 0
    grid rowconfigure $w 1 -weight 0
    grid rowconfigure $w 2 -weight 0
    grid rowconfigure $w 3 -weight 0

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {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)}]

            $board create image $x1 $y1 -image battleship/field -anchor nw \
                -tags [list mbackground [list cr $c $r]]
            $board create rectangle $x1 $y1 $x2 $y2 \
                -outline {} \
                -tags [list olast [list cr $c $r]]
        }
    }

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            set x1 [expr {($square_size + $line_width) * ($board_size + 1) + \
                          $line_width + (($square_size + $line_width) * $c)}]
            set x2 [expr {($square_size + $line_width) * ($board_size + 1) + \
                          ($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)}]

            $board create image $x1 $y1 -image battleship/field/shaded \
                -anchor nw \
                -tags [list obackground [list cr $c $r]]
            $board create rectangle $x1 $y1 $x2 $y2 \
                -outline {} \
                -tags [list mlast [list cr $c $r]]
            $board create rectangle $x1 $y1 $x2 $y2 \
                -outline {} \
                -tags [list square [list cr $c $r]]
        }
    }

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

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

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            set state(position,mshot,$c,$r) ""
            set state(position,oshot,$c,$r) ""
        }
    }

    set state(board_is_sent) 0
    set state(board_is_received) 0

    set state(position,turn) first

    catch {unset state(position,last_move)}
    set state(position,draw) 0
    set state(position,halfmove) 0
    set state(position,history) {}
    set state(position,ships) {}
    set state(position,destroyed_ships) {}
    set state(position,destroyed_my_ships) {}

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
          set state(seed,$c,$r) \
           [rand 1000000000][rand 1000000000][rand 1000000000][rand 1000000000]
        }
    }

    make_random_position $gid

    predraw_position $gid
    update_controls $gid
    attention_message $gid \
            [::msgcat::mc "\nDrag and drop ships to desired locations, then\
                           click the 'Freeze ships position'\
                           button.\nRight mouse button switches horizontal\
                           and vertical ship orientation."]
}

proc battleship::predraw_position {gid} {
    variable board_size
    variable sizes
    variable $gid
    upvar 0 $gid state

    $state(board) delete figure

    foreach ship $state(position,ships) {
        lassign $ship name dir c r

        $state(board) create image [nw $c $r] \
                      -anchor nw \
                      -image battleship/$name/$dir \
                      -tags [list figure [list ship $name $dir $c $r]]
    }
}

proc battleship::flip_figure {gid x y} {
    variable board_size
    variable sizes
    variable $gid
    upvar 0 $gid state

    array set size $sizes
    set board $state(board)

    lassign [lsearch -inline -regexp [$board gettags current] ^ship] ship \
            name dir c r

    set x [$board canvasx $x]
    set y [$board canvasy $y]
    $board dtag dst
    $board addtag dst overlapping [expr {$x-1}] [expr {$y-1}] $x $y
    lassign [lsearch -inline -regexp [$board gettags dst&&mbackground] ^cr] \
            cr c1 r1
    $board dtag dst

    set c2 [expr {$c1 - $r1 + $r}]
    if {$c2 < 0} { set c2 0 }
    if {$dir == "vertical" && $c2 > $board_size - $size($name)} {
        set c2 [expr {$board_size - $size($name)}]
    }

    set r2 [expr {$r1 - $c1 + $c}]
    if {$r2 < 0} { set r2 0 }
    if {$dir == "horizontal" && $r2 > $board_size - $size($name)} {
        set r2 [expr {$board_size - $size($name)}]
    }

    if {$dir == "horizontal"} {
        set dir2 vertical
    } else {
        set dir2 horizontal
    }

    set idx [lsearch -exact $state(position,ships) [list $name $dir $c $r]]
    set state(position,ships) [lreplace $state(position,ships) $idx $idx]
    lappend state(position,ships) [list $name $dir2 $c2 $r2]
    predraw_position $gid

    if {[position_is_legal $gid 0]} {
        $state(bbox) itemconfigure 0 -state normal
    } else {
        $state(bbox) itemconfigure 0 -state disabled
    }
}

proc battleship::start_drag_figure {gid x y} {
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    set state(lastx) [$board canvasx $x]
    set state(lasty) [$board canvasy $y]
    $board dtag dst
    $board addtag dst overlapping [expr {$x-1}] [expr {$y-1}] $x $y
    lassign [lsearch -inline -regexp [$board gettags dst&&mbackground] ^cr] \
            cr state(startc) state(startr)
    $board dtag dst

    $board raise current
    $board addtag drag withtag current
    $board config -cursor hand2
}

proc battleship::drag_figure {gid x y} {
    variable board_size
    variable square_size
    variable line_width
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    set minx $line_width
    set maxx [expr {($square_size + $line_width) * $board_size}]
    set miny $line_width
    set maxy [expr {($square_size + $line_width) * $board_size}]

    set x [$board canvasx $x]
    set y [$board canvasy $y]
    set dx [expr {$x - $state(lastx)}]
    set dy [expr {$y - $state(lasty)}]

    lassign [$board bbox drag] x1 y1 x2 y2

    if {$x1 + $dx < $minx} {
        set dx [expr {$minx - $x1}]
    }

    if {$x2 + $dx > $maxx} {
        set dx [expr {$maxx - $x2}]
    }

    if {$y1 + $dy < $miny} {
        set dy [expr {$miny - $y1}]
    }

    if {$y2 + $dy > $maxy} {
        set dy [expr {$maxy - $y2}]
    }

    $board move drag $dx $dy

    if {$x < $minx} {
        set state(lastx) $minx
    } elseif {$x > $maxx} {
        set state(lastx) $maxx
    } else {
        set state(lastx) $x
    }
    if {$y < $miny} {
        set state(lasty) $miny
    } elseif {$y > $maxy} {
        set state(lasty) $maxy
    } else {
        set state(lasty) $y
    }
}

proc battleship::drag_end {gid x y} {
    variable square_size
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    lassign [lsearch -inline -regexp [$board gettags drag] ^ship] ship \
            name dir c r
    lassign [$board bbox drag] x1 y1
    $board dtag drag

    set x [expr {$x1 + $square_size/2}]
    set y [expr {$y1 + $square_size/2}]
    $board dtag dst
    $board addtag dst overlapping [expr {$x-1}] [expr {$y-1}] $x $y
    lassign [lsearch -inline -regexp [$board gettags dst&&mbackground] ^cr] \
            cr c1 r1
    $board dtag dst

    set idx [lsearch -exact $state(position,ships) [list $name $dir $c $r]]
    set state(position,ships) [lreplace $state(position,ships) $idx $idx]
    lappend state(position,ships) [list $name $dir $c1 $r1]

    predraw_position $gid
    if {[position_is_legal $gid 0]} {
        $state(bbox) itemconfigure 0 -state normal
    } else {
        $state(bbox) itemconfigure 0 -state disabled
    }
}

proc battleship::make_random_position {gid} {
    variable board_size
    variable ships
    variable sizes
    variable $gid
    upvar 0 $gid state

    array set tmp $sizes
    set state(position,ships) {}

    foreach {name num} $ships {
        for {set i 0} {$i < $num} {incr i} {
            while {1} {
                set c [rand $board_size]
                set r [rand $board_size]
                set dir [lindex {horizontal vertical} [rand 2]]
                set ship [list $name $dir $c $r]

                set saved $state(position,ships)
                lappend state(position,ships) $ship
                if {[position_is_legal $gid 0]} {
                    break
                } else {
                    set state(position,ships) $saved
                }
            }
        }
    }
}

proc battleship::position_is_legal {gid checkSizesOfShips} {
    variable board_size
    variable ships
    variable sizes
    variable $gid
    upvar 0 $gid state

    if {$checkSizesOfShips} {
        array set tmp $ships

        foreach ship $state(position,ships) {
            set name [lindex $ship 0]
            if {![info exists tmp($name)]} {
                return 0
            }
            incr tmp($name) -1
        }

        foreach name [array names tmp] {
            if {$tmp($name) != 0} {
                return 0
            }
        }
    }

    set max -1
    foreach ship $state(position,ships) {
        foreach {c r} [coordinates $ship] {
            if {$c < 0 || $c >= $board_size || $r < 0 || $r >= $board_size} {
                return 0
            }

            foreach ship2 [lrange $state(position,ships) 0 $max] {
                foreach {c1 r1} [coordinates $ship2] {
                    if {abs($c1 - $c) <= 1 && abs($r1 - $r) <= 1} {
                        return 0
                    }
                }
            }
        }
        incr max
    }

    return 1
}

proc battleship::coordinates {ship} {
    variable sizes

    array set tmp $sizes
    lassign $ship name dir c r

    set coords {}
    for {set i 0} {$i < $tmp($name)} {incr i} {
        lappend coords $c $r
        switch -- $dir {
            horizontal {
                incr c
            }
            vertical {
                incr r
            }
            default {
                return -code error
            }
        }
    }
    return $coords
}

proc battleship::set_tooltips {args} {
    variable options

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

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

proc battleship::toggle_show_last_move {gid} {
    variable $gid
    upvar 0 $gid state

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

    button_update_relief $state(show_last_move_button) $state(show_last_move)

    highlight_last_move $gid
}

proc battleship::toggle_draw {gid} {
    variable $gid
    upvar 0 $gid state

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

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

proc battleship::update_controls {gid {draw_proposed 0}} {
    variable $gid
    upvar 0 $gid state

    if {!$state(board_is_sent)} {
        $state(bbox) itemconfigure 0 -state normal
        return
    } else {
        $state(bbox) itemconfigure 0 -state disabled
    }

    if {!$state(board_is_received)} {
        return
    }

    button_update_relief $state(propose_draw_button) 0

    if {[is_my_move $gid]} {
        $state(board) config -cursor ""
        set state(position,draw) 0
        if {$draw_proposed} {
            $state(bbox) itemconfigure 2 -state disabled
            $state(bbox) itemconfigure 3 -state normal
            $state(bbox) itemconfigure 4 -state disabled
        } else {
            $state(bbox) itemconfigure 2 -state normal
            $state(bbox) itemconfigure 3 -state disabled
            $state(bbox) itemconfigure 4 -state normal
        }
    } else {
        if {$state(position,turn) ne "first" && \
                $state(position,turn) ne "second"} {
            $state(board) config -cursor ""
        } else {
            set state(position,draw) $draw_proposed
            $state(board) config -cursor watch
        }
        $state(bbox) itemconfigure 2 -state disabled
        $state(bbox) itemconfigure 3 -state disabled
        $state(bbox) itemconfigure 4 -state disabled
    }
}

proc battleship::end_game {gid my_score message} {
    variable $gid
    upvar 0 $gid state

    set opponent_score [expr {1 - $my_score}]

    if {$state(move_first)} {
        set score "$my_score : $opponent_score"
    } else {
        set score "$opponent_score : $my_score"
    }

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

    set hw $state(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

    after idle [namespace code [list send_board2 $gid]]
}

proc battleship::draw_position {gid} {
    variable board_size
    variable sizes
    variable $gid
    upvar 0 $gid state

    $state(board) delete figure
    $state(board) delete unshaded
    $state(board) delete oshot
    $state(board) delete mshot

    foreach ship $state(position,ships) {
        lassign $ship name dir c r

        $state(board) create image [nw $c $r] \
                      -anchor nw \
                      -image battleship/$name/$dir \
                      -tags [list figure [list ship $name $dir $c $r]]
    }

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            switch -- $state(position,oshot,$c,$r) {
                1 { set image battleship/hit }
                0 { set image battleship/miss }
                default { continue }
            }
            $state(board) create image [nw $c $r] \
                          -anchor nw \
                          -image $image \
                          -tags [list oshot [list cr $c $r]]
        }
    }

    array set tmp $sizes

    foreach ship $state(position,destroyed_ships) {
        lassign $ship name dir c r

        switch -- $dir {
            vertical {
                for {set c1 [expr {$c - 1}]} {$c1 <= $c + 1} {incr c1} {
                    if {$c1 < 0 || $c1 >= $board_size} continue
                    for {set r1 [expr {$r - 1}]} {$r1 <= $r + $tmp($name)} \
                        {incr r1} {
                        if {$r1 < 0 || $r1 >= $board_size} continue

                        $state(board) create image [onw $c1 $r1] \
                                      -anchor nw \
                                      -image battleship/field \
                                      -tags [list unshaded $c1 $r1]
                        set unshaded($c1,$r1) 1
                    }
                }
            }
            horizontal {
                for {set c1 [expr {$c - 1}]} {$c1 <= $c + $tmp($name)} \
                    {incr c1} {
                    if {$c1 < 0 || $c1 >= $board_size} continue
                    for {set r1 [expr {$r - 1}]} {$r1 <= $r + 1} {incr r1} {
                        if {$r1 < 0 || $r1 >= $board_size} continue

                        $state(board) create image [onw $c1 $r1] \
                                      -anchor nw \
                                      -image battleship/field \
                                      -tags [list unshaded $c1 $r1]
                        set unshaded($c1,$r1) 1
                    }
                }
            }
        }

        $state(board) create image [onw $c $r] \
                      -anchor nw \
                      -image battleship/$name/$dir \
                      -tags [list figure [list ship $name $dir $c $r]]
    }

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            switch -- $state(position,mshot,$c,$r) {
                1 { set image battleship/hit }
                0 { set image battleship/miss }
                default { continue }
            }
            if {![info exists unshaded($c,$r)]} {
                $state(board) create image [onw $c $r] \
                              -anchor nw \
                              -image battleship/field \
                              -tags [list unshaded $c $r]
            }
            $state(board) create image [onw $c $r] \
                          -anchor nw \
                          -image $image \
                          -tags [list mshot [list cr $c $r]]
        }
    }

    $state(board) raise mlast
    $state(board) raise olast
    $state(board) raise square
}

proc battleship::motion {gid x y} {
    variable $gid
    upvar 0 $gid state

    set board $state(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 [expr {$x-1}] [expr {$y-1}] $x $y
    set tags [$board gettags dst_sq&&obackground]
    lassign [lindex $tags [lsearch $tags cr*]] cr c r
    $board addtag dst_sq withtag [list cr $c $r]&&square

    if {[is_my_move $gid] && [info exists state(position,mshot,$c,$r)] && \
            $state(position,mshot,$c,$r) == ""} {
        $board itemconfigure dst_sq&&square -outline red
        $board itemconfigure dst_sq&&reasonable&&square -outline blue
    }
}

proc battleship::leave {gid x y} {
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    $board itemconfigure dst_sq&&square -outline ""
    $board dtag dst_sq
    highlight_last_move $gid
}

proc battleship::release {gid x y} {
    variable options
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    set x [$board canvasx $x]
    set y [$board canvasy $y]
    $board dtag dst_sq
    $board addtag dst_sq overlapping [expr {$x-1}] [expr {$y-1}] $x $y

    set tags [$board gettags dst_sq&&obackground]
    lassign [lindex $tags [lsearch $tags cr*]] cr c r
    $board dtag dst_sq

    if {[is_my_move $gid]} {
        if {[start_do_move $gid $c $r $state(position,draw)]} {
            $board itemconfigure [list cr $c $r]&&square -outline ""
        }
    }

    update_controls $gid
    draw_position $gid

    highlight_last_move $gid
}

proc battleship::highlight_last_move {gid} {
    variable $gid
    upvar 0 $gid state

    $state(board) itemconfigure mlast -outline ""
    $state(board) itemconfigure olast -outline ""

    if {[catch {lassign $state(position,last_move) c r}]} {
        return
    }

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

    if {$state(position,my_last_move)} {
        $state(board) itemconfigure [list cr $c $r]&&mlast -outline $color
    } else {
        $state(board) itemconfigure [list cr $c $r]&&olast -outline $color
    }
}

proc battleship::start_do_move {gid c r draw} {
    variable $gid
    upvar 0 $gid state

    if {$c == "" || $r == ""} {
        return 0
    }

    set my_move [is_my_move $gid]

    if {!$my_move} {
        return 0
    }

    save_position $gid

    set state(position,mshot,$c,$r) -1
    set state(position,last_move) [list $c $r]
    set state(position,my_last_move) 1

    update_controls $gid
    draw_position $gid
    highlight_last_move $gid
    send_move $gid $c $r $draw
    return 1
}

proc battleship::do_move {gid c r result draw} {
    variable options
    variable ships
    variable $gid
    upvar 0 $gid state

    if {$c == "" || $r == ""} {
        return 0
    }

    switch -- $result {
        destroy -
        hit { set hit 1 }
        default { set hit 0 }
    }

    set my_move [is_my_move $gid]

    if {!$my_move} {
        save_position $gid
        set state(position,oshot,$c,$r) $hit
        set state(position,last_move) [list $c $r]
        set state(position,my_last_move) 0
    } else {
        set state(position,mshot,$c,$r) $hit
        if {$result == "destroy"} {
            set ship [find_destroyed_ship $gid $c $r]
            if {[llength $ship] > 0} {
                lappend state(position,destroyed_ships) $ship
            }
        }
    }

    add_move_to_history $gid $c $r $result $draw

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

    switch -glob -- $state(position,turn)/$hit/$draw {
        first/1/0 {
            # Add skipping move to history
            add_move_to_history $gid
            set state(position,turn) first
        }
        second/1/0 {
            # Add skipping move to history
            add_move_to_history $gid
            set state(position,turn) second
        }
        first/1/1 -
        first/0/* {
            set state(position,turn) second
        }
        second/1/1 -
        second/0/* {
            set state(position,turn) first
        }
    }

    find_reasonable_moves $gid $state(position,turn)

    set endgame 0
    if {[llength $state(reasonable_moves)] == 0} {
        set endgame 1
    }

    if {$endgame} {
        set total 0
        foreach {name size} $ships {
            incr total $size
        }
        if {[llength $state(position,destroyed_ships)] >= $total &&
                [llength $state(position,destroyed_my_ships)] < $total} {
            # I win
            end_game $gid 1 [::msgcat::mc "You win"]
        } elseif {[llength $state(position,destroyed_my_ships)] >= $total &&
                [llength $state(position,destroyed_ships)] < $total} {
            # Opponent wins
            end_game $gid 0 [::msgcat::mc "Opponent wins"]
        } else {
            # Can't be here
            end_game $gid 0.5 [::msgcat::mc "Impossible draw"]
        }
    }

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

proc battleship::accept_draw {gid} {
    variable $gid
    upvar 0 $gid state

    ::xmpp::sendIQ $state(xlib) set \
        -query [::xmpp::xml::create turn \
                    -xmlns games:board \
                    -attrs [list type battleship \
                                 id $state(id)] \
                    -subelement [::xmpp::xml::create accept]] \
        -to $state(opponent) \
        -command [namespace code [list accept_draw_result $gid]]

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

proc battleship::accept_draw_result {gid status xml} {
    variable $gid
    upvar 0 $gid state

    if {![string equal $status ok]} {
        attention_message $gid \
                [::msgcat::mc "\n\n Opponent rejected accepted\
                               draw:\n %s\n\n" \
                              [error_to_string $xml]]
    }
}

proc battleship::send_resign {gid} {
    variable $gid
    upvar 0 $gid state

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

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

proc battleship::send_board {gid} {
    variable board_size
    variable $gid
    upvar 0 $gid state

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            set pos($c,$r) 0
        }
    }

    set shipSubels {}
    foreach ship $state(position,ships) {
        set size 0
        set seed ""
        foreach {c r} [coordinates $ship] {
            incr size
            append seed $state(seed,$c,$r)
            set pos($c,$r) 1
        }
        lappend shipSubels [::xmpp::xml::create ship \
                                    -attrs [list length $size \
                                                 hash [sha1::sha1 $seed]]]
    }

    set subels {}
    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            lappend subels \
                [::xmpp::xml::create cell \
                        -attrs [list col $c \
                                     row $r \
                                     hash [sha1::sha1 \
                                               $state(seed,$c,$r)$pos($c,$r)]]]
        }
    }

    set state(board_is_sent) 1
    set_label_move $gid
    draw_position $gid
    update_controls $gid
    find_reasonable_moves $gid $state(position,turn)

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

    $state(board) bind figure <1> {}
    $state(board) bind figure <B1-Motion> {}
    $state(board) bind figure <ButtonRelease-1> {}

    bind $state(board) <Any-Enter>  [namespace code [list motion $gid %x %y]]
    bind $state(board) <Any-Motion> [namespace code [list motion $gid %x %y]]
    bind $state(board) <Any-Leave>  [namespace code [list leave $gid %x %y]]
    bind $state(board) <ButtonRelease-1> \
         [namespace code [list release $gid %x %y]]

    ::xmpp::sendIQ $state(xlib) set \
            -query [::xmpp::xml::create board \
                            -xmlns games:board \
                            -attrs [list type battleship \
                                         id $state(id)] \
                            -subelements $subels \
                            -subelements $shipSubels] \
            -to $state(opponent) \
            -command [namespace code [list send_result board $gid]]
}

proc battleship::send_board2 {gid} {
    variable board_size
    variable $gid
    upvar 0 $gid state

    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            set pos($c,$r) 0
        }
    }

    foreach ship $state(position,ships) {
        foreach {c r} [coordinates $ship] {
            set pos($c,$r) 1
        }
    }

    set subels {}
    for {set c 0} {$c < $board_size} {incr c} {
        for {set r 0} {$r < $board_size} {incr r} {
            lappend subels [::xmpp::xml::create cell \
                                    -attrs [list col $c \
                                                 row $r \
                                                 ship $pos($c,$r) \
                                                 seed $state(seed,$c,$r)]]
        }
    }

    ::xmpp::sendIQ $state(xlib) set \
            -query [::xmpp::xml::create board \
                            -xmlns games:board \
                            -attrs [list type battleship \
                                         id $state(id)] \
                            -subelements $subels] \
            -to $state(opponent) \
            -command [namespace code [list send_result board2 $gid]]
}

proc battleship::send_move {gid c r draw} {
    variable $gid
    upvar 0 $gid state

    set els [list [::xmpp::xml::create shot -attrs [list row $r col $c]]]
    if {$draw} {
        lappend els [::xmpp::xml::create draw]
    }

    ::xmpp::sendIQ $state(xlib) set \
            -query [::xmpp::xml::create turn \
                            -xmlns games:board \
                            -attrs [list type battleship \
                                         id $state(id)] \
                            -subelements $els] \
            -to $state(opponent) \
            -command [namespace code [list send_turn_result $gid $c $r $draw]]
}

proc battleship::send_turn_result {gid c r draw status xml} {
    variable $gid
    upvar 0 $gid state

    if {![string equal $status ok]} {
        attention_message $gid \
                [::msgcat::mc "\n\n Opponent rejected move:\n %s\n\n" \
                              [error_to_string $xml]]
        restore_position $gid
    } else {
        ::xmpp::xml::split $xml tag xmlns attrs cdata subels

        foreach subel $subels {
            ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels

            switch -- $stag {
                shot {
                    set result [::xmpp::xml::getAttr $sattrs result]
                    set seed [::xmpp::xml::getAttr $sattrs seed]
                    set state(oseed,$c,$r) $seed

                    switch -- $result {
                        hit {
                            set hit 1
                            set destroy 0
                        }
                        destroy {
                            set hit 1
                            set destroy 1
                        }
                        default {
                            set hit 0
                            set destroy 0
                        }
                    }

                    if {[sha1::sha1 $seed$hit] ne $state(hash,$c,$r)} {
                        attention_message $gid \
                                [::msgcat::mc "\n\n Opponent returned\
                                               incorrect cell seed"]
                        return
                    }

                    if {$hit} {
                        # Checking if the currenlty hit ship is destroyed

                        set ship [find_destroyed_ship $gid $c $r]
                        set acc ""
                        foreach {c1 r1} [coordinates $ship] {
                            append acc $state(oseed,$c1,$r1)
                        }
                        set hash [sha1::sha1 $acc]
                        if {$destroy && \
                               [lsearch -exact $state(shiphashes) $hash] < 0} {
                            attention_message $gid \
                                [::msgcat::mc "\n\n Opponent returned\
                                               incorrect destroy answer"]
                            return
                        } elseif {!$destroy && $hit && \
                              [lsearch -exact $state(shiphashes) $hash] >= 0} {
                            attention_message $gid \
                                [::msgcat::mc "\n\n Opponent returned\
                                               inconrrect hit answer"]
                            return
                        }
                    }

                    do_move $gid $c $r $result $draw
                    update_controls $gid $draw
                    draw_position $gid
                    highlight_last_move $gid
                    return
                }
            }
        }

        attention_message $gid \
                [::msgcat::mc "\n\n Opponent returned incorrect answer"]
    }
}

proc battleship::find_destroyed_ship {gid c r} {
    variable sizes
    variable board_size
    variable $gid
    upvar 0 $gid state

    set r1 $r
    while {$r1 >= 0 && ($state(position,mshot,$c,$r1) == 1 ||
                        $state(position,mshot,$c,$r1) == -1)} {
        incr r1 -1
    }
    incr r1
    set r2 $r
    while {$r2 < $board_size && ($state(position,mshot,$c,$r2) == 1 ||
                                 $state(position,mshot,$c,$r2) == -1)} {
        incr r2
    }
    incr r2 -1
    if {$r2 > $r1} {
        set size [expr {$r2 - $r1 + 1}]
        foreach {name s} $sizes {
            if {$s == $size} {
                return [list $name vertical $c $r1]
            }
        }
        return
    }

    set c1 $c
    while {$c1 >= 0 && ($state(position,mshot,$c1,$r) == 1 ||
                        $state(position,mshot,$c1,$r) == -1)} {
        incr c1 -1
    }
    incr c1
    set c2 $c
    while {$c2 < $board_size && ($state(position,mshot,$c2,$r) == 1 ||
                                 $state(position,mshot,$c2,$r) == -1)} {
        incr c2
    }
    incr c2 -1
    set size [expr {$c2 - $c1 + 1}]
    foreach {name s} $sizes {
        if {$s == $size} {
            return [list $name horizontal $c1 $r]
        }
    }
    return
}

proc battleship::send_result {type gid status xml} {
    variable $gid
    upvar 0 $gid state

    switch -- $type {
        board {
            if {![string equal $status ok]} {
                set state(board_is_sent) 0
                set_label_move $gid
                update_controls $gid
                attention_message $gid \
                        [::msgcat::mc "\n\n Opponent rejected\
                                       board:\n %s\n\n" \
                                      [error_to_string $xml]]
            }
        }
        board2 {
            if {![string equal $status ok]} {
                attention_message $gid \
                        [::msgcat::mc "\n\n Opponent rejected\
                                       board:\n %s\n\n" \
                                      [error_to_string $xml]]
            }
        }
    }
}

proc battleship::add_move_to_history {gid {c ""} {r ""} {result ""} {draw 0}} {
    variable board_size
    variable $gid
    upvar 0 $gid state

    incr state(position,halfmove)

    if {$c != "" && $r != ""} {
        lappend state(position,history) [list $c $r $result $draw]
    } else {
        lappend state(position,history) skip
    }

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

    if {$state(move_first)} {
        $hw insert end "\t[::msgcat::mc You]\t[::msgcat::mc Opponent]\n"
    } else {
        $hw insert end "\t[::msgcat::mc Opponent]\t[::msgcat::mc You]\n"
    }
    set i 1
    foreach {b w} $state(position,history) {
        $hw insert end "${i}.\t"
        if {$b == "skip"} {
            $hw insert end "--\t"
        } elseif {$b != {}} {
            lassign $b c r res d
            set r [expr {$board_size - $r}]
            set l [format %c [expr {$c+97}]]
            switch -- $res {
                destroy { set s # }
                hit     { set s + }
                default { set s "" }
            }
            if {$d} {
                set e "="
            } else {
                set e ""
            }
            $hw insert end "$l$r$s$e\t"
        }
        if {$w == "skip"} {
            $hw insert end "--\n"
        } elseif {$w != {}} {
            lassign $w c r res d
            set r [expr {$board_size - $r}]
            set l [format %c [expr {$c+97}]]
            switch -- $res {
                destroy { set s # }
                hit     { set s + }
                default { set s "" }
            }
            if {$d} {
                set e "="
            } else {
                set e ""
            }
            $hw insert end "$l$r$s$e\n"
        } else {
            $hw insert end "\n"
        }
        incr i
    }
    $hw see end
    $hw configure -state disabled
}

proc battleship::find_reasonable_moves {gid color} {
    variable board_size
    variable ships
    variable $gid
    upvar 0 $gid state

    set state(reasonable_moves) {}

    set total 0
    foreach {name number} $ships {
        incr total $number
    }

    if {[llength $state(position,destroyed_my_ships)] < $total &&
                [llength $state(position,destroyed_ships)] < $total} {
        for {set c 0} {$c < $board_size} {incr c} {
            for {set r 0} {$r < $board_size} {incr r} {
                if {$state(position,mshot,$c,$r) == ""} {
                    lappend state(reasonable_moves) [list $c $r]
                }
            }
        }
    }
    highlight_reasonable_moves $gid
}

proc battleship::is_move_reasonable {gid c r} {
    variable $gid
    upvar 0 $gid state

    expr {[lsearch -regexp $state(reasonable_moves) ^[list $c $r]] >= 0}
}

proc battleship::highlight_reasonable_moves {gid} {
    variable $gid
    upvar 0 $gid state

    set board $state(board)

    $board dtag reasonable
    foreach move $state(reasonable_moves) {
        lassign $move c r
        $board addtag reasonable withtag [list cr $c $r]&&square
    }
}

proc battleship::attention_message {gid message} {
    variable $gid
    upvar 0 $gid state

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

proc battleship::is_my_move {gid} {
    variable $gid
    upvar 0 $gid state
    if {$state(move_first) && $state(position,turn) == "first"} {
        return 1
    } elseif {!$state(move_first) && $state(position,turn) == "second"} {
        return 1
    } else {
        return 0
    }
}

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

proc battleship::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 "Battleship..."] \
        -command [namespace code [list invite_dialog $xlib $jid]]
}

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

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

    switch -- [::xmpp::xml::getAttr $attrs type] {
        battleship {
            if {[::xmpp::xml::isAttr $attrs first]} {
                set first [::xmpp::xml::getAttr $attrs first]
                switch -- $first {
                    true -
                    1 {
                        set first true
                    }
                    false -
                    0 {
                        set first false
                    }
                    default {
                        set var [list error modify bad-request]
                    }
                }
            } else {
                set first true
            }
            set var [invited_dialog $xlib $from $iqid \
                                    [::xmpp::xml::getAttr $attrs id] \
                                    $first]
        }
    }
    return
}

proc battleship::iq_init {varname xlib from xml} {
    upvar 2 $varname var

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

    switch -- [::xmpp::xml::getAttr $attrs type] {
        battleship {
            set gid [make_gid $from [::xmpp::xml::getAttr $attrs id]]
            if {[exists $gid]} {
                set var [board_recv $gid $subels]
            } else {
                set var [list error cancel item-not-found]
            }
        }
    }
    return
}

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

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

    switch -- [::xmpp::xml::getAttr $attrs type] {
        battleship {
            set gid [make_gid $from [::xmpp::xml::getAttr $attrs id]]
            if {[exists $gid]} {
                set var [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_init {xlib from xml args} {
    set res [list error cancel feature-not-implemented]
    hook::run games_board_init_hook res $xlib $from $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
