1# $Id$ 2 3package require msgcat 4 5namespace eval chess { 6 ::msgcat::mcload [file join [file dirname [info script]] msgs] 7 8 if {![::plugins::is_registered chess]} { 9 ::plugins::register chess \ 10 -namespace [namespace current] \ 11 -source [info script] \ 12 -description [::msgcat::mc "Whether the Chess plugin is loaded."] \ 13 -loadcommand [namespace code load] \ 14 -unloadcommand [namespace code unload] 15 return 16 } 17 18 variable square_size 48 19 variable line_width 1 20 array set piece_name [list \ 21 wk [::msgcat::mc "K"] \ 22 wq [::msgcat::mc "Q"] \ 23 wr [::msgcat::mc "R"] \ 24 wb [::msgcat::mc "B"] \ 25 wn [::msgcat::mc "N"] \ 26 wp {} \ 27 bk [::msgcat::mc "K"] \ 28 bq [::msgcat::mc "Q"] \ 29 br [::msgcat::mc "R"] \ 30 bb [::msgcat::mc "B"] \ 31 bn [::msgcat::mc "N"] \ 32 bp {}] 33 array set prom_name [list q queen r rook b bishop n knight] 34 array set prom_rev [list queen q rook r bishop b knight n] 35 36 variable themes 37 set dirs \ 38 [glob -nocomplain -directory [file join [file dirname [info script]] \ 39 pixmaps] *] 40 foreach dir $dirs { 41 pixmaps::load_theme_name [namespace current]::themes $dir 42 } 43 set values {} 44 foreach theme [lsort [array names themes]] { 45 lappend values $theme $theme 46 } 47 48 custom::defgroup Plugins [::msgcat::mc "Plugins options."] \ 49 -group Tkabber 50 51 custom::defgroup Chess [::msgcat::mc "Chess plugin options."] \ 52 -group Plugins 53 custom::defvar options(theme) Classic \ 54 [::msgcat::mc "Chess figures theme."] -group Chess \ 55 -type options -values $values \ 56 -command [namespace current]::load_stored_theme 57 custom::defvar options(flip_black_view) 1 \ 58 [::msgcat::mc "Flip board view when playing black by default."] \ 59 -type boolean -group Chess 60 custom::defvar options(show_last_move) 0 \ 61 [::msgcat::mc "Show last move by default."] \ 62 -type boolean -group Chess 63 custom::defvar options(always_queen) 0 \ 64 [::msgcat::mc "Promote pawns always as queens."] \ 65 -type boolean -group Chess 66 custom::defvar options(show_tooltips) 1 \ 67 [::msgcat::mc "Show tooltips with short instructions."] \ 68 -type boolean -group Chess \ 69 -command [list [namespace current]::set_tooltips] 70 custom::defvar options(sound) "" \ 71 [::msgcat::mc "Sound to play after opponent's turn"] \ 72 -type file -group Chess 73 custom::defvar options(allow_illegal) 0 \ 74 [::msgcat::mc "Allow illegal moves (useful for debugging)."] \ 75 -type boolean -group Chess 76 custom::defvar options(accept_illegal) 0 \ 77 [::msgcat::mc "Accept opponent illegal moves (useful for\ 78 debugging)."] \ 79 -type boolean -group Chess 80} 81 82proc chess::load {} { 83 hook::add roster_create_groupchat_user_menu_hook \ 84 [namespace current]::add_groupchat_user_menu_item 48 85 hook::add chat_create_user_menu_hook \ 86 [namespace current]::add_groupchat_user_menu_item 48 87 hook::add roster_jid_popup_menu_hook \ 88 [namespace current]::add_groupchat_user_menu_item 48 89 90 hook::add games_board_create_hook [namespace current]::iq_create 91 hook::add games_board_turn_hook [namespace current]::iq_turn 92 93 ::xmpp::iq::register set create games:board \ 94 [namespace parent]::iq_games_board_create 95 ::xmpp::iq::register set turn games:board \ 96 [namespace parent]::iq_games_board_turn 97 98 load_stored_theme 99 calc_moves 100} 101 102proc chess::unload {} { 103 hook::remove roster_create_groupchat_user_menu_hook \ 104 [namespace current]::add_groupchat_user_menu_item 48 105 hook::remove chat_create_user_menu_hook \ 106 [namespace current]::add_groupchat_user_menu_item 48 107 hook::remove roster_jid_popup_menu_hook \ 108 [namespace current]::add_groupchat_user_menu_item 48 109 110 hook::remove games_board_create_hook [namespace current]::iq_create 111 hook::remove games_board_turn_hook [namespace current]::iq_turn 112 113 if {[hook::is_empty games_board_create_hook]} { 114 ::xmpp::iq::unregister set create games:board 115 rename [namespace parent]::iq_games_board_create "" 116 } 117 118 if {[hook::is_empty games_board_turn_hook]} { 119 ::xmpp::iq::unregister set turn games:board 120 rename [namespace parent]::iq_games_board_turn "" 121 } 122 123 foreach var [info vars [namespace current]::*] { 124 upvar #0 $var flags 125 if {[info exists flags(window)]} { 126 destroy_win $flags(window) 127 } 128 } 129 130 foreach var [info vars [namespace current]::*] { 131 if {$var ne "[namespace current]::options"} { 132 unset $var 133 } 134 } 135 136 foreach img [image names] { 137 if {[string first chess/ $img] == 0} { 138 image delete $img 139 } 140 } 141} 142 143proc chess::load_stored_theme {args} { 144 variable options 145 variable themes 146 147 pixmaps::load_dir $themes($options(theme)) 148} 149 150proc chess::get_nick {xlib jid type} { 151 if {[catch {chat::get_nick $xlib $jid $type} nick]} { 152 return [chat::get_nick $jid $type] 153 } else { 154 return $nick 155 } 156} 157 158proc chess::invite_dialog {xlib jid} { 159 set w .chess_invite 160 161 if {[winfo exists $w]} { 162 destroy $w 163 } 164 165 Dialog $w -title [::msgcat::mc "Chess Invitation"] \ 166 -modal none -separator 1 -anchor e -default 0 167 168 set wf [$w getframe] 169 message $wf.message -aspect 50000 \ 170 -text [::msgcat::mc "Sending chess game invitation to %s (%s)" \ 171 [get_nick $xlib $jid chat] \ 172 $jid] 173 174 pack $wf.message -pady 2m 175 176 $w add -text [::msgcat::mc "I want play white"] \ 177 -command [list [namespace current]::invite $xlib $jid white] 178 $w add -text [::msgcat::mc "I want play black"] \ 179 -command [list [namespace current]::invite $xlib $jid black] 180 $w add -text [::msgcat::mc "Cancel invitation"] \ 181 -command [list destroy $w] 182 183 $w draw 184} 185 186proc chess::invite {xlib jid color} { 187 destroy .chess_invite 188 189 set id chess[rand 1000000000] 190 191 # FIX 192 #set rjid [get_jid_of_user $jid] 193 194 ::xmpp::sendIQ $xlib set \ 195 -query [::xmpp::xml::create create \ 196 -xmlns games:board \ 197 -attrs [list type chess \ 198 id $id \ 199 color $color]] \ 200 -to $jid \ 201 -command [list [namespace current]::invite_res $xlib $jid $id $color] 202} 203 204proc chess::invite_res {xlib jid id color status xml} { 205 if {![string equal $status ok]} { 206 after idle [list NonmodalMessageDlg .chess_invite_error -aspect 50000 -icon error \ 207 -message [::msgcat::mc "%s (%s) has refused chess invitation: %s" \ 208 [get_nick $xlib $jid chat] \ 209 $jid [error_to_string $xml]]] 210 return "" 211 } 212 213 start_play $xlib $jid $id $color 214} 215 216 217proc chess::invited_dialog {xlib jid iqid id color} { 218 set w .chess_invited 219 220 if {[winfo exists $w]} { 221 destroy $w 222 } 223 224 Dialog $w -title [::msgcat::mc "Chess Invitation from %s" $jid] \ 225 -modal none -separator 1 -anchor e -default 0 226 227 set wf [$w getframe] 228 bind $wf <Destroy> [namespace code [list invited_res $w $xlib $jid $iqid $id $color 0]] 229 230 set nick [get_nick $xlib $jid chat] 231 set message1 [::msgcat::mc "Chess game invitation from %s (%s) is received." \ 232 $nick $jid] 233 switch -- $color { 234 white { 235 set message2 [::msgcat::mc "%s wants play white." $nick] 236 } 237 black { 238 set message2 [::msgcat::mc "%s wants play black." $nick] 239 } 240 default { 241 return [list error modify bad-request] 242 } 243 } 244 message $wf.message1 -aspect 50000 -text $message1 245 message $wf.message2 -aspect 50000 -text $message2 246 pack $wf.message1 -pady 1m 247 pack $wf.message2 -pady 1m 248 249 $w add -text [::msgcat::mc "Agree to play"] \ 250 -command [namespace code [list invited_res $w $xlib $jid $iqid $id $color 1]] 251 $w add -text [::msgcat::mc "Refuse to play"] \ 252 -command [namespace code [list invited_res $w $xlib $jid $iqid $id $color 0]] 253 254 $w draw 255 return 256} 257 258proc chess::invited_res {w xlib jid iqid id color res} { 259 catch { 260 set wf [$w getframe] 261 bind $wf <Destroy> {} 262 destroy $w 263 } 264 265 if {$res} { 266 switch -- $color { 267 white { 268 start_play $xlib $jid $id black 269 } 270 black { 271 start_play $xlib $jid $id white 272 } 273 default { 274 ::xmpp::sendIQ $xlib error \ 275 -error [::xmpp::stanzaerror::error \ 276 modify bad-request] \ 277 -to $jid \ 278 -id $iqid 279 } 280 } 281 282 ::xmpp::sendIQ $xlib result \ 283 -query [::xmpp::xml::create create \ 284 -xmlns games:board \ 285 -attrs [list type chess \ 286 id $id]] \ 287 -to $jid \ 288 -id $iqid 289 } else { 290 ::xmpp::sendIQ $xlib error \ 291 -error [::xmpp::stanzaerror::error \ 292 modify not-acceptable] \ 293 -to $jid \ 294 -id $iqid 295 } 296 return 297} 298 299proc chess::start_play {xlib jid id color} { 300 set gid [make_gid $jid $id] 301 variable $gid 302 variable options 303 upvar 0 $gid flags 304 305 set flags(window) [win_id chess $gid] 306 set flags(xlib) $xlib 307 set flags(opponent) $jid 308 set flags(id) $id 309 set flags(flip) 0 310 set flags(our_color) $color 311 312 trace variable [namespace current]::${gid}(position,turn) w \ 313 [list [namespace current]::set_label_move $gid] 314 315 make_default_position $gid 316 317 open $gid 318} 319 320proc chess::set_label_move {gid args} { 321 variable $gid 322 upvar 0 $gid flags 323 324 switch -- $flags(position,turn) { 325 white { 326 set flags(move_label) [::msgcat::mc "White"] 327 set move 1 328 } 329 black { 330 set flags(move_label) [::msgcat::mc "Black"] 331 set move 1 332 } 333 default { 334 set move 0 335 } 336 } 337 if {$move && [is_my_move $gid]} { 338 append flags(move_label) [::msgcat::mc " (You)"] 339 } else { 340 append flags(move_label) [::msgcat::mc " (Opponent)"] 341 } 342} 343 344proc chess::make_default_position {gid} { 345 variable $gid 346 upvar 0 $gid flags 347 348 for {set c 0} {$c < 8} {incr c} { 349 for {set r 0} {$r < 8} {incr r} { 350 set flags(position,$c,$r) "" 351 } 352 } 353 for {set c 0} {$c < 8} {incr c} { 354 set flags(position,$c,1) wp 355 set flags(position,$c,6) bp 356 } 357 set c 0 358 foreach f {r n b q k b n r} { 359 set flags(position,$c,0) w$f 360 set flags(position,$c,7) b$f 361 incr c 362 } 363 set flags(position,wk,c) 4 364 set flags(position,wk,r) 0 365 set flags(position,bk,c) 4 366 set flags(position,bk,r) 7 367 368 set flags(position,wk,kcastling) 1 369 set flags(position,wk,qcastling) 1 370 set flags(position,bk,kcastling) 1 371 set flags(position,bk,qcastling) 1 372 set flags(position,enpassant) {} 373 374 set flags(position,turn) white 375 376 catch {unset flags(position,last_move)} 377 set flags(position,draw) 0 378 set flags(position,halfmove) 0 379 set flags(position,history) {} 380 381 set flags(position,repetitions) [list [code_position $gid] 1] 382} 383 384proc chess::save_position {gid} { 385 variable $gid 386 upvar 0 $gid flags 387 388 set flags(saved_position) [array get flags position,*] 389} 390 391proc chess::restore_position {gid} { 392 variable $gid 393 upvar 0 $gid flags 394 395 array set flags $flags(saved_position) 396 draw_position $gid 397 unhighlight_legal_moves $gid 398 update_controls $gid 399 find_legal_moves $gid $flags(position,turn) 400} 401 402proc chess::code_position {gid} { 403 variable $gid 404 upvar 0 $gid flags 405 406 set code "" 407 for {set c 0} {$c < 8} {incr c} { 408 for {set r 0} {$r < 8} {incr r} { 409 switch -- $flags(position,$c,$r) { 410 wk {append code K} 411 wq {append code Q} 412 wr {append code R} 413 wb {append code B} 414 wn {append code N} 415 wp {append code P} 416 bk {append code k} 417 bq {append code q} 418 br {append code r} 419 bb {append code b} 420 bn {append code n} 421 bp {append code p} 422 default {append code .} 423 } 424 } 425 } 426 427 append code $flags(position,wk,kcastling) 428 append code $flags(position,wk,qcastling) 429 append code $flags(position,bk,kcastling) 430 append code $flags(position,bk,qcastling) 431 432 if {[llength $flags(position,enpassant)] > 0} { 433 lassign $flags(position,enpassant) c r 434 set cp1 [expr {$c + 1}] 435 set cm1 [expr {$c - 1}] 436 if {$r == 2} { 437 if {($cp1 < 8 && $flags(position,$cp1,3) == "bp") || \ 438 ($cm1 >= 0 && $flags(position,$cm1,3) == "bp")} { 439 append code $c$r 440 } 441 } elseif {$r == 5} { 442 if {($cp1 < 8 && $flags(position,$cp1,4) == "wp") || \ 443 ($cm1 >= 0 && $flags(position,$cm1,4) == "wp")} { 444 append code $c$r 445 } 446 } 447 } 448 449 return $code 450} 451 452proc chess::make_gid {jid id} { 453 jid_to_tag [concat $jid $id] 454} 455 456proc chess::turn_recv {gid xmlList} { 457 variable options 458 variable prom_rev 459 variable $gid 460 upvar 0 $gid flags 461 462 set move 0 463 set draw 0 464 465 foreach xml $xmlList { 466 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 467 switch -- $tag { 468 move { 469 set pos [::xmpp::xml::getAttr $attrs pos] 470 set poss [split $pos ";"] 471 if {[llength $poss] == 2} { 472 set pos1 [split [lindex $poss 0] ,] 473 set pos2 [split [lindex $poss 1] ,] 474 if {[llength $pos1] == 2 && [llength $pos2] == 2} { 475 set cf [lindex $pos1 0] 476 set rf [lindex $pos1 1] 477 set ct [lindex $pos2 0] 478 set rt [lindex $pos2 1] 479 set prom "" 480 foreach subel $subels { 481 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 482 if {$stag == "promotion"} { 483 if {[info exists prom_rev($scdata)]} { 484 set prom $prom_rev($scdata) 485 } 486 } 487 } 488 set move 1 489 if {$options(sound) != "" && ![::sound::is_mute]} { 490 ::sound::play $options(sound) 491 } 492 493 } 494 } 495 } 496 resign { 497 end_game $gid 1 [::msgcat::mc "You win (Opponent resigned)"] 498 update_controls $gid 499 draw_position $gid 500 highlight_last_move $gid 501 return [list result [::xmpp::xml::create turn \ 502 -xmlns games:board \ 503 -attrs [list type chess \ 504 id $flags(id)]]] 505 } 506 accept { 507 if {$flags(position,draw)} { 508 end_game $gid 0.5 [::msgcat::mc "Draw (Opponent accepted)"] 509 update_controls $gid 510 draw_position $gid 511 highlight_last_move $gid 512 return [list result [::xmpp::xml::create turn \ 513 -xmlns games:board \ 514 -attrs [list type chess \ 515 id $flags(id)]]] 516 } else { 517 return [list error modify not-acceptable] 518 } 519 } 520 draw { 521 set draw 1 522 } 523 } 524 } 525 526 if {$move && [do_move $gid $cf $rf $ct $rt $prom $draw]} { 527 update_controls $gid $draw 528 draw_position $gid 529 highlight_last_move $gid 530 531 return [list result [::xmpp::xml::create turn \ 532 -xmlns games:board \ 533 -attrs [list type chess \ 534 id $flags(id)]]] 535 } else { 536 return [list error modify not-acceptable] 537 } 538} 539 540 541############################################################################### 542 543proc chess::calc_moves {} { 544 variable moves 545 546 for {set c 0} {$c < 8} {incr c} { 547 for {set r 0} {$r < 8} {incr r} { 548 for {set moves(d1,$c,$r) {}; set x [expr {$c+1}]; set y [expr {$r+1}]} \ 549 {($x < 8) && ($y < 8)} {incr x; incr y} { 550 lappend moves(d1,$c,$r) $x $y 551 } 552 for {set moves(d2,$c,$r) {}; set x [expr {$c-1}]; set y [expr {$r+1}]} \ 553 {($x >= 0) && ($y < 8)} {incr x -1; incr y} { 554 lappend moves(d2,$c,$r) $x $y 555 } 556 for {set moves(d3,$c,$r) {}; set x [expr {$c-1}]; set y [expr {$r-1}]} \ 557 {($x >= 0) && ($y >= 0)} {incr x -1; incr y -1} { 558 lappend moves(d3,$c,$r) $x $y 559 } 560 for {set moves(d4,$c,$r) {}; set x [expr {$c+1}]; set y [expr {$r-1}]} \ 561 {($x < 8) && ($y >= 0)} {incr x; incr y -1} { 562 lappend moves(d4,$c,$r) $x $y 563 } 564 for {set moves(h1,$c,$r) {}; set x [expr {$c+1}]} {$x < 8} {incr x} { 565 lappend moves(h1,$c,$r) $x $r 566 } 567 for {set moves(h2,$c,$r) {}; set x [expr {$c-1}]} {$x >= 0} {incr x -1} { 568 lappend moves(h2,$c,$r) $x $r 569 } 570 for {set moves(v1,$c,$r) {}; set y [expr {$r+1}]} {$y < 8} {incr y} { 571 lappend moves(v1,$c,$r) $c $y 572 } 573 for {set moves(v2,$c,$r) {}; set y [expr {$r-1}]} {$y >= 0} {incr y -1} { 574 lappend moves(v2,$c,$r) $c $y 575 } 576 set moves(n,$c,$r) {} 577 foreach {dx dy} {1 2 -1 2 -2 1 -2 -1 -1 -2 1 -2 2 -1 2 1} { 578 set x [expr {$c + $dx}] 579 set y [expr {$r + $dy}] 580 if {($x >= 0) && ($x < 8) && ($y >= 0) && ($y < 8)} { 581 lappend moves(n,$c,$r) $x $y 582 } 583 } 584 set moves(wpt,$c,$r) {} 585 if {$r <= 6} { 586 if {$c <= 6} { 587 lappend moves(wpt,$c,$r) [expr {$c + 1}] [expr {$r + 1}] 588 } 589 if {$c >= 1} { 590 lappend moves(wpt,$c,$r) [expr {$c - 1}] [expr {$r + 1}] 591 } 592 } 593 set moves(bpt,$c,$r) {} 594 if {$r >= 1} { 595 if {$c <= 6} { 596 lappend moves(bpt,$c,$r) [expr {$c + 1}] [expr {$r - 1}] 597 } 598 if {$c >= 1} { 599 lappend moves(bpt,$c,$r) [expr {$c - 1}] [expr {$r - 1}] 600 } 601 } 602 set moves(k,$c,$r) {} 603 foreach {dx dy} {0 1 -1 1 -1 0 -1 -1 0 -1 1 -1 1 0 1 1} { 604 set x [expr {$c + $dx}] 605 set y [expr {$r + $dy}] 606 if {($x >= 0) && ($x < 8) && ($y >= 0) && ($y < 8)} { 607 lappend moves(k,$c,$r) $x $y 608 } 609 } 610 } 611 } 612} 613 614proc chess::center {c r} { 615 variable square_size 616 variable line_width 617 618 set r [expr {7 - $r}] 619 list [expr {$line_width + ($square_size * 0.5) + \ 620 (($square_size + $line_width) * $c)}] \ 621 [expr {$line_width + ($square_size * 0.5) + \ 622 (($square_size + $line_width) * $r)}] 623} 624 625proc chess::close {gid} { 626 variable $gid 627 upvar 0 $gid flags 628 629 array unset flags 630} 631 632proc chess::exists {gid} { 633 variable $gid 634 info exists $gid 635} 636 637proc chess::open {gid} { 638 variable options 639 variable square_size 640 variable line_width 641 variable piece_name 642 variable $gid 643 upvar 0 $gid flags 644 645 set jid $flags(opponent) 646 647 set w $flags(window) 648 if {[winfo exists $w]} { 649 raise_win $w 650 return 651 } 652 653 set title [::msgcat::mc "Chess with %s" [get_nick $flags(xlib) $jid chat]] 654 add_win $w -title $title \ 655 -tabtitle $title \ 656 -class Chess \ 657 -raise 1 658 659 set board [canvas $w.board \ 660 -width [expr {($square_size + $line_width) * 8}] \ 661 -height [expr {($square_size + $line_width) * 8}]] 662 pack $board -side left -anchor w -padx 10 663 664 set flags(board) $board 665 666 set flags(show_last_move) $options(show_last_move) 667 set relief [expr {$flags(show_last_move) ? "sunken" : "raised"}] 668 set slm [Button $w.show_last_move -text [::msgcat::mc "Show last move"] \ 669 -relief $relief \ 670 -command [list [namespace current]::toggle_show_last_move $gid]] 671 pack $slm -side top -anchor w -fill x 672 set flags(show_last_move_button) $slm 673 674 set flags(flip) 0 675 set slm [Button $w.flip -text [::msgcat::mc "Flip view"] \ 676 -relief raised \ 677 -command [list [namespace current]::toggle_flip_view $gid]] 678 pack $slm -side top -anchor w -fill x 679 set flags(flip_button) $slm 680 681 frame $w.move 682 pack $w.move -side top -anchor w 683 label $w.move.title -text [::msgcat::mc "Move: "] 684 pack $w.move.title -side left 685 label $w.move.on_move -anchor w \ 686 -textvariable [namespace current]::${gid}(move_label) 687 pack $w.move.on_move -side left -anchor w 688 689 set bbox [ButtonBox $w.bbox -orient vertical -spacing 0] 690 $bbox add -text [::msgcat::mc "Propose a draw"] \ 691 -command [list [namespace current]::toggle_draw $gid] 692 $bbox add -text [::msgcat::mc "Accept the draw proposal"] \ 693 -state disabled \ 694 -command [list [namespace current]::accept_draw $gid] 695 $bbox add -text [::msgcat::mc "Resign the game"] \ 696 -command [list [namespace current]::send_resign $gid] 697 grid columnconfigure $bbox 0 -weight 1 698 pack $bbox -side bottom -anchor w -fill x 699 set flags(bbox) $bbox 700 set_tooltips 701 702 #label $w.history -text [::msgcat::mc "History"] 703 #pack $w.history -side top -anchor w 704 set hsw [ScrolledWindow $w.hsw] 705 pack $hsw -side top -fill x -expand yes 706 set ht [text $w.text -wrap word -height 60 -state disabled] 707 set font [$ht cget -font] 708 set tabstop1 [font measure $font "99.."] 709 set tabstop2 [font measure $font "99..Qa8-a8+= "] 710 $ht configure -tabs "$tabstop1 $tabstop2" 711 $ht tag configure attention -foreground [option get $ht errorForeground Text] 712 $hsw setwidget $ht 713 set flags(hw) $ht 714 715 set dsq_color #77a26d 716 set lsq_color #c8c365 717 718 for {set c 0} {$c < 8} {incr c} { 719 for {set r 0} {$r < 8} {incr r} { 720 set x1 [expr {$line_width + (($square_size + $line_width) * $c)}] 721 set x2 [expr {($square_size + $line_width) * ($c + 1)}] 722 set y1 [expr {$line_width + (($square_size + $line_width) * $r)}] 723 set y2 [expr {($square_size + $line_width) * ($r + 1)}] 724 set color [expr {($c+$r) % 2 ? $dsq_color : $lsq_color}] 725 set img [expr {($c+$r) % 2 ? "bf" : "wf"}] 726 727 $board create image $x1 $y1 -image chess/$img -anchor nw \ 728 -tags [list background [list cr $c [expr {7-$r}]]] 729 $board create rectangle $x1 $y1 $x2 $y2 \ 730 -outline {} \ 731 -tags [list square [list cr $c [expr {7-$r}]]] 732 } 733 } 734 735 $board bind figure <1> \ 736 [list [namespace current]::start_drag_figure $gid %x %y] 737 $board bind figure <B1-Motion> \ 738 [list [namespace current]::drag_figure $gid %x %y] 739 $board bind figure <ButtonRelease-1> \ 740 [list [namespace current]::drag_end $gid %x %y] 741 742 bind $w <Destroy> [list [namespace current]::close $gid] 743 744 if {[is_black $flags(our_color)] && $options(flip_black_view)} { 745 toggle_flip_view $gid 746 } 747 748 draw_position $gid 749 update_controls $gid 750 find_legal_moves $gid $flags(position,turn) 751} 752 753proc chess::toggle_flip_view {gid} { 754 variable $gid 755 upvar 0 $gid flags 756 757 set flags(flip) [expr {!$flags(flip)}] 758 759 set board $flags(board) 760 761 for {set c 0} {$c < 8} {incr c} { 762 for {set r 0} {$r < 8} {incr r} { 763 $board addtag [list temp [expr {7-$c}] [expr {7-$r}]] \ 764 withtag [list cr $c $r] 765 $board dtag [list cr $c $r] 766 } 767 } 768 769 for {set c 0} {$c < 8} {incr c} { 770 for {set r 0} {$r < 8} {incr r} { 771 $board addtag [list cr $c $r] withtag [list temp $c $r] 772 $board dtag [list temp $c $r] 773 } 774 } 775 776 set relief [expr {$flags(flip) ? "sunken" : "raised"}] 777 $flags(flip_button) configure -relief $relief 778 779 draw_position $gid 780 highlight_last_move $gid 781} 782 783proc chess::set_tooltips {args} { 784 variable options 785 786 if {$options(show_tooltips)} { 787 set tooltip0 [::msgcat::mc "Press button and make move if you want propose draw"] 788 set tooltip1 [::msgcat::mc "Press button if you want accept the draw proposal"] 789 set tooltip2 [::msgcat::mc "Press button if you want resign"] 790 } else { 791 set tooltip0 "" 792 set tooltip1 "" 793 set tooltip2 "" 794 } 795 796 foreach var [info vars [namespace current]::*] { 797 upvar 0 $var flags 798 if {[info exists flags(bbox)]} { 799 catch { 800 $flags(bbox) itemconfigure 0 -helptext $tooltip0 801 $flags(bbox) itemconfigure 1 -helptext $tooltip1 802 $flags(bbox) itemconfigure 2 -helptext $tooltip2 803 } 804 } 805 } 806} 807 808proc chess::toggle_show_last_move {gid} { 809 variable $gid 810 upvar 0 $gid flags 811 812 set flags(show_last_move) [expr {!$flags(show_last_move)}] 813 814 set relief [expr {$flags(show_last_move) ? "sunken" : "raised"}] 815 $flags(show_last_move_button) configure -relief $relief 816 817 highlight_last_move $gid 818} 819 820proc chess::toggle_draw {gid} { 821 variable $gid 822 upvar 0 $gid flags 823 824 set flags(position,draw) [expr {!$flags(position,draw)}] 825 826 if {$flags(position,draw)} { 827 $flags(bbox) itemconfigure 0 -relief sunken 828 } else { 829 $flags(bbox) itemconfigure 0 -relief raised 830 } 831} 832 833proc chess::update_controls {gid {draw_proposed 0}} { 834 variable $gid 835 upvar 0 $gid flags 836 837 $flags(bbox) itemconfigure 0 -relief raised 838 839 if {[is_my_move $gid]} { 840 $flags(board) config -cursor "" 841 set flags(position,draw) 0 842 if {$draw_proposed} { 843 $flags(bbox) itemconfigure 0 -state disabled 844 $flags(bbox) itemconfigure 1 -state normal 845 $flags(bbox) itemconfigure 2 -state disabled 846 } else { 847 $flags(bbox) itemconfigure 0 -state normal 848 $flags(bbox) itemconfigure 1 -state disabled 849 $flags(bbox) itemconfigure 2 -state normal 850 } 851 } elseif {![is_white $flags(position,turn)] && \ 852 ![is_black $flags(position,turn)]} { 853 $flags(board) config -cursor "" 854 $flags(bbox) itemconfigure 0 -state disabled 855 $flags(bbox) itemconfigure 1 -state disabled 856 $flags(bbox) itemconfigure 2 -state disabled 857 } else { 858 $flags(board) config -cursor watch 859 $flags(bbox) itemconfigure 0 -state disabled 860 $flags(bbox) itemconfigure 1 -state disabled 861 $flags(bbox) itemconfigure 2 -state disabled 862 } 863} 864 865proc chess::end_game {gid my_score message} { 866 variable $gid 867 upvar 0 $gid flags 868 869 set opponent_score [expr {1 - $my_score}] 870 871 if {[is_white $flags(our_color)]} { 872 set score "$my_score : $opponent_score" 873 } else { 874 set score "$opponent_score : $my_score" 875 } 876 877 set flags(position,turn) none 878 set flags(move_label) $message 879 880 set hw $flags(hw) 881 $hw configure -state normal 882 catch {$hw delete attention.first attention.last} 883 $hw delete {end -1 char} end 884 $hw insert end "\n\t\t$score\n" 885 $hw see end 886 $hw configure -state disabled 887} 888 889proc chess::draw_position {gid} { 890 variable $gid 891 upvar 0 $gid flags 892 893 $flags(board) delete figure 894 895 for {set c 0} {$c < 8} {incr c} { 896 for {set r 0} {$r < 8} {incr r} { 897 if {$flags(position,$c,$r) != ""} { 898 if {$flags(flip)} { 899 set c1 [expr {7 - $c}] 900 set r1 [expr {7 - $r}] 901 } else { 902 set c1 $c 903 set r1 $r 904 } 905 $flags(board) create image [center $c1 $r1] \ 906 -image chess/$flags(position,$c,$r) \ 907 -tags [list figure $flags(position,$c,$r) [list cr $c $r]] 908 } 909 } 910 } 911} 912 913proc chess::start_drag_figure {gid x y} { 914 variable $gid 915 upvar 0 $gid flags 916 917 set board $flags(board) 918 919 lassign [lindex [lmatch -regexp [$board gettags current] ^cr] 0] cr \ 920 flags(currentc) flags(currentr) 921 922 set flags(last_x) [$board canvasx $x] 923 set flags(last_y) [$board canvasy $y] 924 $board raise current 925 $board config -cursor hand2 926 927 highlight_legal_moves $gid $flags(currentc) $flags(currentr) 928} 929 930proc chess::drag_figure {gid x y} { 931 variable $gid 932 upvar 0 $gid flags 933 934 set board $flags(board) 935 936 set x [$board canvasx $x] 937 set y [$board canvasy $y] 938 $board move current \ 939 [expr {$x - $flags(last_x)}] [expr {$y - $flags(last_y)}] 940 set flags(last_x) $x 941 set flags(last_y) $y 942 943 $board itemconfigure dst_sq&&square -outline "" 944 $board dtag dst_sq 945 $board itemconfigure legal&&square -outline blue 946 $board addtag dst_sq overlapping $x $y $x $y 947 lassign [lindex [lmatch -regexp [$board gettags dst_sq&&background] ^cr] 0] \ 948 cr c r 949 $board addtag dst_sq withtag [list cr $c $r]&&square 950 $board itemconfigure dst_sq&&square -outline red 951 $board itemconfigure dst_sq&&legal&&square -outline white 952} 953 954proc chess::drag_end {gid x y} { 955 variable options 956 variable $gid 957 upvar 0 $gid flags 958 959 set board $flags(board) 960 961 set x [$board canvasx $x] 962 set y [$board canvasy $y] 963 $board itemconfigure dst_sq&&square -outline "" 964 $board dtag dst_sq 965 $board addtag dst_sq overlapping $x $y $x $y 966 967 lassign [lindex [lmatch \ 968 -regexp [$board gettags dst_sq&&background] \ 969 ^cr] 0] cr c r 970 $board dtag dst_sq 971 972 if {$options(allow_illegal) || [is_my_move $gid]} { 973 do_move $gid $flags(currentc) $flags(currentr) \ 974 $c $r "" $flags(position,draw) 975 } 976 977 update_controls $gid 978 draw_position $gid 979 980 unhighlight_legal_moves $gid 981 982 highlight_last_move $gid 983} 984 985proc chess::highlight_last_move {gid} { 986 variable $gid 987 upvar 0 $gid flags 988 989 $flags(board) itemconfigure square -outline "" 990 $flags(board) itemconfigure square -outline "" 991 992 if {[catch {lassign $flags(position,last_move) cf rf ct rt}]} { 993 return 994 } 995 996 if {$flags(show_last_move)} { 997 set color white 998 } else { 999 set color {} 1000 } 1001 1002 $flags(board) itemconfigure [list cr $cf $rf]&&square -outline $color 1003 $flags(board) itemconfigure [list cr $ct $rt]&&square -outline $color 1004} 1005 1006proc chess::do_move {gid cf rf ct rt prom draw} { 1007 variable options 1008 variable $gid 1009 upvar 0 $gid flags 1010 1011 if {$cf == $ct && $rf == $rt || $ct == "" || $rt == ""} { 1012 return 0 1013 } 1014 1015 set opts "-" 1016 set prm "" 1017 set suffix "" 1018 set checkmate 0 1019 set stalemate 0 1020 set my_move [is_my_move $gid] 1021 1022 if {![is_move_legal $gid $cf $rf $ct $rt]} { 1023 if {$my_move && !$options(allow_illegal)} { 1024 return 0 1025 } 1026 if {!$my_move && !$options(accept_illegal)} { 1027 return 0 1028 } 1029 } 1030 1031 save_position $gid 1032 1033 if {$flags(position,$ct,$rt) != ""} { 1034 set opts ":" 1035 } 1036 set f $flags(position,$cf,$rf) 1037 set flags(position,$ct,$rt) $flags(position,$cf,$rf) 1038 set flags(position,$cf,$rf) "" 1039 1040 if {$flags(position,$ct,$rt) == "wk"} { 1041 set flags(position,wk,c) $ct 1042 set flags(position,wk,r) $rt 1043 } elseif {$flags(position,$ct,$rt) == "bk"} { 1044 set flags(position,bk,c) $ct 1045 set flags(position,bk,r) $rt 1046 } 1047 1048 if {[is_white $flags(position,turn)]} { 1049 set p "w" 1050 set opp "b" 1051 set r 0 1052 } else { 1053 set p "b" 1054 set opp "w" 1055 set r 7 1056 } 1057 1058 if {$rt == (7 - $r)} { 1059 if {$ct == 0} { 1060 set flags(position,${opp}k,qcastling) 0 1061 } elseif {$ct == 7} { 1062 set flags(position,${opp}k,kcastling) 0 1063 } 1064 } 1065 if {$flags(position,$ct,$rt) == "${p}k"} { 1066 set flags(position,${p}k,kcastling) 0 1067 set flags(position,${p}k,qcastling) 0 1068 if {($ct - $cf) == 2} { 1069 set opts {0-0} 1070 set flags(position,5,$r) "${p}r" 1071 set flags(position,7,$r) "" 1072 } elseif {($ct - $cf) == -2} { 1073 set opts {0-0-0} 1074 set flags(position,3,$r) "${p}r" 1075 set flags(position,0,$r) "" 1076 } 1077 } elseif {$flags(position,$ct,$rt) == "${p}r"} { 1078 if {($cf == 0) && ($rf == $r)} { 1079 set flags(position,${p}k,qcastling) 0 1080 } elseif {($cf == 7) && ($rf == $r)} { 1081 set flags(position,${p}k,kcastling) 0 1082 } 1083 } 1084 1085 set enpassant 0 1086 if {$flags(position,$ct,$rt) == "${p}p"} { 1087 if {(($p == "w") && ($rt == 7)) || \ 1088 (($p == "b") && ($rt == 0))} { 1089 if {$my_move} { 1090 set promote [promote_pawn $gid $p] 1091 if {$promote == -1} { 1092 set flags(position,$ct,$rt) "${p}q" 1093 } else { 1094 set flags(position,$ct,$rt) $promote 1095 } 1096 } else { 1097 if {$prom != ""} { 1098 set flags(position,$ct,$rt) "${p}$prom" 1099 } 1100 # If we are here, then it's an error... 1101 } 1102 set prm $flags(position,$ct,$rt) 1103 } elseif {$flags(position,enpassant) == [list $ct $rt]} { 1104 if {[is_white $flags(position,turn)]} { 1105 set flags(position,$ct,4) "" 1106 } else { 1107 set flags(position,$ct,3) "" 1108 } 1109 set opts ":" 1110 } else { 1111 if {($rt - $rf) == 2} { 1112 set flags(position,enpassant) [list $ct [expr {$rt - 1}]] 1113 set enpassant 1 1114 } elseif {($rt - $rf) == -2} { 1115 set flags(position,enpassant) [list $ct [expr {$rt + 1}]] 1116 set enpassant 1 1117 } 1118 } 1119 } 1120 1121 if {!$enpassant} { 1122 set flags(position,enpassant) {} 1123 } 1124 1125 set flags(position,last_move) [list $cf $rf $ct $rt] 1126 1127 if {[is_white $flags(position,turn)]} { 1128 set flags(position,turn) black 1129 set check [test_check $gid $flags(position,bk,c) $flags(position,bk,r) \ 1130 $flags(position,bk,c) $flags(position,bk,r)] 1131 } else { 1132 set flags(position,turn) white 1133 set check [test_check $gid $flags(position,wk,c) $flags(position,wk,r) \ 1134 $flags(position,wk,c) $flags(position,wk,r)] 1135 } 1136 1137 find_legal_moves $gid $flags(position,turn) 1138 1139 if {$check} { 1140 if {[lempty $flags(legal_moves)]} { 1141 set suffix "#" 1142 set draw 0 1143 set checkmate 1 1144 } else { 1145 set suffix "+" 1146 } 1147 } else { 1148 if {[lempty $flags(legal_moves)]} { 1149 set stalemate 1 1150 } 1151 } 1152 if {$draw} { 1153 append suffix "=" 1154 } 1155 lappend opts $prm $suffix 1156 add_move_to_history $gid $cf $rf $ct $rt $f $opts 1157 1158 set repetitions [add_to_repetitions $gid] 1159 1160 if {$draw && !$my_move} { 1161 attention_message $gid \ 1162 [::msgcat::mc "\n\n Opponent proposes a draw\n\n"] 1163 } 1164 1165 if {$my_move} { 1166 send_move $gid $cf $rf $ct $rt $prm 1167 } 1168 1169 if {$stalemate} { 1170 # Draw by stalemate 1171 end_game $gid 0.5 [::msgcat::mc "Draw (Stalemate)"] 1172 } elseif {$repetitions >= 3} { 1173 # Draw by repetition 1174 end_game $gid 0.5 [::msgcat::mc "Draw (Repetition)"] 1175 } elseif {$checkmate} { 1176 if {$my_move} { 1177 # I win 1178 end_game $gid 1 [::msgcat::mc "You win (Checkmate)"] 1179 } else { 1180 # Opponent wins 1181 end_game $gid 0 [::msgcat::mc "Opponent wins (Checkmate)"] 1182 } 1183 } 1184 1185 tab_set_updated [winfo parent $flags(board)] 1 mesg_to_user 1186 return 1 1187} 1188 1189proc chess::promote_pawn {gid color} { 1190 variable options 1191 variable square_size 1192 variable line_width 1193 variable $gid 1194 upvar 0 $gid flags 1195 1196 if {$options(always_queen)} { 1197 return -1 1198 } 1199 1200 set w .promote 1201 if {[winfo exists $w]} { 1202 destroy $w 1203 } 1204 1205 Dialog .promote -title [::msgcat::mc "Pawn promotion"] \ 1206 -separator 0 -anchor e -default 0 1207 1208 set fr [frame $w.fr] 1209 set select [canvas $w.select \ 1210 -width [expr {($square_size + $line_width) * 4}] \ 1211 -height [expr {($square_size + $line_width)}]] 1212 1213 pack $fr -padx 3m -pady 1m 1214 pack $select -padx 3m -pady 1m 1215 1216 set c 0 1217 foreach fig {q r b n} { 1218 set img [expr {$c % 2 ? "bf" : "wf"}] 1219 set x1 [expr {$line_width + (($square_size + $line_width) * $c)}] 1220 set x2 [expr {($square_size + $line_width) * ($c + 1)}] 1221 set y1 [expr {$line_width + (($square_size + $line_width) * 0)}] 1222 set y2 [expr {($square_size + $line_width) * (0 + 1)}] 1223 $select create image $x1 $y1 -image chess/$img -anchor nw \ 1224 -tags [list background fg$fig] 1225 $select create image $x1 $y1 -image chess/$color$fig -anchor nw \ 1226 -tags [list figure fg$fig] 1227 $select create rectangle $x1 $y1 $x2 $y2 \ 1228 -outline {} \ 1229 -tags [list square fg$fig] 1230 incr c 1231 } 1232 1233 bind $select <Any-Enter> [list [namespace current]::promotion:motion %W %x %y] 1234 bind $select <Any-Motion> [list [namespace current]::promotion:motion %W %x %y] 1235 bind $select <Any-Leave> [list [namespace current]::promotion:leave %W %x %y] 1236 foreach fig {q r b n} { 1237 $select bind fg$fig <ButtonRelease-1> \ 1238 [list Dialog::enddialog $w $color$fig] 1239 } 1240 1241 $w draw 1242} 1243 1244proc chess::promotion:motion {c x y} { 1245 1246 set x [$c canvasx $x] 1247 set y [$c canvasy $y] 1248 1249 $c itemconfigure dst_sq&&square -outline "" 1250 $c dtag dst_sq 1251 1252 $c addtag dst_sq overlapping $x $y $x $y 1253 set tags [$c gettags dst_sq&&background] 1254 set tag [lindex $tags [lsearch $tags fg*]] 1255 if {$tag != ""} { 1256 $c addtag dst_sq withtag $tag&&square 1257 } 1258 1259 $c itemconfigure dst_sq&&square -outline blue 1260} 1261 1262proc chess::promotion:leave {c x y} { 1263 $c itemconfigure dst_sq&&square -outline "" 1264 $c dtag dst_sq 1265} 1266 1267proc chess::accept_draw {gid} { 1268 variable $gid 1269 upvar 0 $gid flags 1270 1271 ::xmpp::sendIQ $flags(xlib) set \ 1272 -query [::xmpp::xml::create turn \ 1273 -xmlns games:board \ 1274 -attrs [list type chess \ 1275 id $flags(id)] \ 1276 -subelement [::xmpp::xml::create accept]] \ 1277 -to $flags(opponent) 1278 1279 end_game $gid 0.5 [::msgcat::mc "Draw (You accepted)"] 1280 update_controls $gid 1281 draw_position $gid 1282 highlight_last_move $gid 1283} 1284 1285proc chess::send_resign {gid} { 1286 variable $gid 1287 upvar 0 $gid flags 1288 1289 ::xmpp::sendIQ $flags(xlib) set \ 1290 -query [::xmpp::xml::create turn \ 1291 -xmlns games:board \ 1292 -attrs [list type chess \ 1293 id $flags(id)] \ 1294 -subelement [::xmpp::xml::create resign]] \ 1295 -to $flags(opponent) 1296 1297 end_game $gid 0 [::msgcat::mc "Opponent wins (You resigned)"] 1298 update_controls $gid 1299 draw_position $gid 1300 highlight_last_move $gid 1301} 1302 1303proc chess::send_move {gid cf rf ct rt prom} { 1304 variable $gid 1305 upvar 0 $gid flags 1306 1307 set move_tags [list [make_move_tag $gid $cf $rf $ct $rt $prom]] 1308 if {$flags(position,draw)} { 1309 lappend move_tags [::xmpp::xml::create draw] 1310 } 1311 1312 ::xmpp::sendIQ $flags(xlib) set \ 1313 -query [::xmpp::xml::create turn \ 1314 -xmlns games:board \ 1315 -attrs [list type chess \ 1316 id $flags(id)] \ 1317 -subelements $move_tags] \ 1318 -to $flags(opponent) \ 1319 -command [list [namespace current]::send_result $gid] 1320} 1321 1322proc chess::send_result {gid status xml} { 1323 if {$status == "error"} { 1324 attention_message $gid \ 1325 [::msgcat::mc "\n\n Opponent rejected move:\n %s\n\n" \ 1326 [error_to_string $xml]] 1327 restore_position $gid 1328 } 1329} 1330 1331proc chess::make_move_tag {gid cf rf ct rt prom} { 1332 variable prom_name 1333 1334 if {$prom == ""} { 1335 ::xmpp::xml::create move \ 1336 -attrs [list pos "$cf,$rf;$ct,$rt"] 1337 } else { 1338 set f [string index $prom 1] 1339 ::xmpp::xml::create move \ 1340 -attrs [list pos "$cf,$rf;$ct,$rt"] \ 1341 -subelement [::xmpp::xml::create promotion \ 1342 -cdata $prom_name($f)] 1343 } 1344} 1345 1346proc chess::add_to_repetitions {gid} { 1347 variable $gid 1348 upvar 0 $gid flags 1349 1350 array set repetitions $flags(position,repetitions) 1351 set code [code_position $gid] 1352 if {[info exists repetitions($code)]} { 1353 incr repetitions($code) 1354 } else { 1355 set repetitions($code) 1 1356 } 1357 set flags(position,repetitions) [array get repetitions] 1358 return $repetitions($code) 1359} 1360 1361proc chess::add_move_to_history {gid cf rf ct rt f opts} { 1362 variable piece_name 1363 variable $gid 1364 upvar 0 $gid flags 1365 1366 incr flags(position,halfmove) 1 1367 1368 lappend flags(position,history) [list $cf $rf $ct $rt $f $opts] 1369 1370 set hw $flags(hw) 1371 $hw configure -state normal 1372 $hw delete 0.0 end 1373 1374 $hw insert end "\t[::msgcat::mc White]\t[::msgcat::mc Black]\n" 1375 set i 1 1376 foreach {w b} $flags(position,history) { 1377 $hw insert end "${i}.\t" 1378 if {$w != {}} { 1379 lassign $w cf rf ct rt f opts 1380 lassign $opts opt prom check 1381 if {$prom == ""} { 1382 set m "" 1383 } else { 1384 set m $piece_name($prom) 1385 } 1386 if {($opt == "0-0") || ($opt == "0-0-0")} { 1387 $hw insert end "$opt$check\t" 1388 } else { 1389 incr rf 1390 incr rt 1391 set lf [format %c [expr {$cf+97}]] 1392 set lt [format %c [expr {$ct+97}]] 1393 set n $piece_name($f) 1394 $hw insert end "$n${lf}$rf${opt}${lt}$rt$m$check\t" 1395 } 1396 } 1397 if {$b != {}} { 1398 lassign $b cf rf ct rt f opts 1399 lassign $opts opt prom check 1400 if {$prom == ""} { 1401 set m "" 1402 } else { 1403 set m $piece_name($prom) 1404 } 1405 if {($opt == "0-0") || ($opt == "0-0-0")} { 1406 $hw insert end "$opt$check\n" 1407 } else { 1408 incr rf 1409 incr rt 1410 set lf [format %c [expr {$cf+97}]] 1411 set lt [format %c [expr {$ct+97}]] 1412 set n $piece_name($f) 1413 $hw insert end "$n${lf}$rf${opt}${lt}$rt$m$check\n" 1414 } 1415 } 1416 incr i 1417 } 1418 $hw see end 1419 $hw configure -state disabled 1420} 1421 1422proc chess::find_pseudo_legal_moves {gid color callback} { 1423 variable moves 1424 variable $gid 1425 upvar 0 $gid flags 1426 1427 set c [string index $color 0] 1428 1429 for {set cf 0} {$cf < 8} {incr cf} { 1430 for {set rf 0} {$rf < 8} {incr rf} { 1431 if {[string index $flags(position,$cf,$rf) 0] != $c} { 1432 continue 1433 } 1434 1435 switch -- $flags(position,$cf,$rf) { 1436 "" { continue } 1437 1438 wp { 1439 set rt [expr {$rf + 1}] 1440 if {$rf < 7 && $flags(position,$cf,$rt) == ""} { 1441 if {$rf == 6} { 1442 eval $callback $gid $cf $rf $cf $rt promotion 1443 } else { 1444 eval $callback $gid $cf $rf $cf $rt 1445 } 1446 } 1447 1448 if {$rf == 1 && $flags(position,$cf,2) == "" && \ 1449 $flags(position,$cf,3) == ""} { 1450 eval $callback $gid $cf $rf $cf 3 1451 } 1452 1453 foreach {ct rt} $moves(wpt,$cf,$rf) { 1454 if {[is_black $flags(position,$ct,$rt)] || \ 1455 ($flags(position,enpassant) == [list $ct $rt])} { 1456 if {$rf == 6} { 1457 eval $callback $gid $cf $rf $ct $rt promotion 1458 } else { 1459 eval $callback $gid $cf $rf $ct $rt 1460 } 1461 } 1462 } 1463 } 1464 1465 bp { 1466 set rt [expr {$rf - 1}] 1467 if {$rf > 0 && $flags(position,$cf,$rt) == ""} { 1468 if {$rf == 1} { 1469 eval $callback $gid $cf $rf $cf $rt promotion 1470 } else { 1471 eval $callback $gid $cf $rf $cf $rt 1472 } 1473 } 1474 1475 if {$rf == 6 && $flags(position,$cf,5) == "" && \ 1476 $flags(position,$cf,4) == ""} { 1477 eval $callback $gid $cf $rf $cf 4 1478 } 1479 1480 foreach {ct rt} $moves(bpt,$cf,$rf) { 1481 if {[is_white $flags(position,$ct,$rt)] || \ 1482 $flags(position,enpassant) == [list $ct $rt]} { 1483 if {$rf == 1} { 1484 eval $callback $gid $cf $rf $ct $rt promotion 1485 } else { 1486 eval $callback $gid $cf $rf $ct $rt 1487 } 1488 } 1489 } 1490 } 1491 1492 wn - 1493 bn { 1494 foreach {ct rt} $moves(n,$cf,$rf) { 1495 if {[is_same_color $flags(position,$cf,$rf) \ 1496 $flags(position,$ct,$rt)]} \ 1497 continue 1498 eval $callback $gid $cf $rf $ct $rt 1499 } 1500 } 1501 1502 wb - 1503 bb { 1504 foreach d {d1 d2 d3 d4} { 1505 foreach {ct rt} $moves($d,$cf,$rf) { 1506 if {[is_same_color $flags(position,$cf,$rf) \ 1507 $flags(position,$ct,$rt)]} \ 1508 break 1509 eval $callback $gid $cf $rf $ct $rt 1510 if {$flags(position,$ct,$rt) != ""} \ 1511 break 1512 } 1513 } 1514 } 1515 1516 wr - 1517 br { 1518 foreach d {h1 h2 v1 v2} { 1519 foreach {ct rt} $moves($d,$cf,$rf) { 1520 if {[is_same_color $flags(position,$cf,$rf) \ 1521 $flags(position,$ct,$rt)]} \ 1522 break 1523 eval $callback $gid $cf $rf $ct $rt 1524 if {$flags(position,$ct,$rt) != ""} \ 1525 break 1526 } 1527 } 1528 } 1529 1530 wq - 1531 bq { 1532 foreach d {d1 d2 d3 d4 h1 h2 v1 v2} { 1533 foreach {ct rt} $moves($d,$cf,$rf) { 1534 if {[is_same_color $flags(position,$cf,$rf) \ 1535 $flags(position,$ct,$rt)]} \ 1536 break 1537 eval $callback $gid $cf $rf $ct $rt 1538 if {$flags(position,$ct,$rt) != ""} \ 1539 break 1540 } 1541 } 1542 } 1543 1544 wk { 1545 foreach {ct rt} $moves(k,$cf,$rf) { 1546 if {[is_same_color $flags(position,$cf,$rf) \ 1547 $flags(position,$ct,$rt)]} \ 1548 continue 1549 eval $callback $gid $cf $rf $ct $rt 1550 } 1551 if {($cf == 4) && ($rf == 0)} { 1552 if {$flags(position,wk,kcastling) && \ 1553 $flags(position,5,0) == "" && \ 1554 $flags(position,6,0) == ""} { 1555 eval $callback $gid 4 0 6 0 kcastling 1556 } 1557 if {$flags(position,wk,qcastling) && \ 1558 $flags(position,3,0) == "" && \ 1559 $flags(position,2,0) == "" && \ 1560 $flags(position,1,0) == ""} { 1561 eval $callback $gid 4 0 2 0 qcastling 1562 } 1563 } 1564 } 1565 bk { 1566 foreach {ct rt} $moves(k,$cf,$rf) { 1567 if {[is_same_color $flags(position,$cf,$rf) \ 1568 $flags(position,$ct,$rt)]} \ 1569 continue 1570 eval $callback $gid $cf $rf $ct $rt 1571 } 1572 if {($cf == 4) && ($rf == 7)} { 1573 if {$flags(position,bk,kcastling) && \ 1574 $flags(position,5,7) == "" && \ 1575 $flags(position,6,7) == ""} { 1576 eval $callback $gid 4 7 6 7 kcastling 1577 } 1578 if {$flags(position,bk,qcastling) && \ 1579 $flags(position,3,7) == "" && \ 1580 $flags(position,2,7) == "" && \ 1581 $flags(position,1,7) == ""} { 1582 eval $callback $gid 4 7 2 7 qcastling 1583 } 1584 } 1585 } 1586 } 1587 } 1588 } 1589} 1590 1591proc chess::find_legal_moves {gid color} { 1592 variable $gid 1593 upvar 0 $gid flags 1594 1595 set flags(legal_moves) {} 1596 find_pseudo_legal_moves $gid $color check_legal_callback 1597} 1598 1599proc chess::check_legal_callback {gid cf rf ct rt {opt ""}} { 1600 variable $gid 1601 upvar 0 $gid flags 1602 1603 if {![test_check $gid $cf $rf $ct $rt $opt]} { 1604 lappend flags(legal_moves) [list $cf $rf $ct $rt $opt] 1605 } 1606} 1607 1608proc chess::test_check {gid cf rf ct rt {opt ""}} { 1609 variable $gid 1610 upvar 0 $gid flags 1611 1612 set enpassantback "" 1613 set enpassantx "" 1614 set enpassanty "" 1615 if {[is_white $flags(position,turn)]} { 1616 set color black 1617 set f wk 1618 set of bk 1619 if {($rf == 4) && \ 1620 ($flags(position,$cf,$rf) == "wp") && \ 1621 ($flags(position,enpassant) == [list $ct $rt])} { 1622 set enpassantback "bp" 1623 set enpassantx $ct 1624 set enpassanty [expr {$rt - 1}] 1625 set flags(position,$enpassantx,$enpassanty) "" 1626 } 1627 } else { 1628 set color white 1629 set f bk 1630 set of wk 1631 if {($rf == 3) && \ 1632 ($flags(position,$cf,$rf) == "bp") && \ 1633 ($flags(position,enpassant) == [list $ct $rt])} { 1634 set enpassantback "wp" 1635 set enpassantx $ct 1636 set enpassanty [expr {$rt + 1}] 1637 set flags(position,$enpassantx,$enpassanty) "" 1638 } 1639 } 1640 set checks 0 1641 1642 set back $flags(position,$ct,$rt) 1643 set flags(position,$ct,$rt) $flags(position,$cf,$rf) 1644 set flags(position,$cf,$rf) "" 1645 if {$flags(position,$ct,$rt) == "wk"} { 1646 set flags(position,wk,c) $ct 1647 set flags(position,wk,r) $rt 1648 } elseif {$flags(position,$ct,$rt) == "bk"} { 1649 set flags(position,bk,c) $ct 1650 set flags(position,bk,r) $rt 1651 } 1652 1653 set kc $flags(position,$f,c) 1654 set kr $flags(position,$f,r) 1655 set okc $flags(position,$of,c) 1656 set okr $flags(position,$of,r) 1657 1658 1659 if {$opt == "kcastling"} { 1660 set kcs [list 4 5 6] 1661 } elseif {$opt == "qcastling"} { 1662 set kcs [list 4 3 2] 1663 } else { 1664 set kcs [list $kc] 1665 } 1666 1667 foreach c $kcs { 1668 incr checks [test_figures $gid $color $c $kr] 1669 incr checks [test_pawns $gid $color $c $kr] 1670 if {[info exists okc]} { 1671 set dx [expr {abs($c-$okc)}] 1672 set dy [expr {abs($kr-$okr)}] 1673 if {($dx <= 1) && ($dy <= 1)} { 1674 incr checks 1675 } 1676 } 1677 } 1678 1679 set flags(position,$cf,$rf) $flags(position,$ct,$rt) 1680 set flags(position,$ct,$rt) $back 1681 if {$flags(position,$cf,$rf) == "wk"} { 1682 set flags(position,wk,c) $cf 1683 set flags(position,wk,r) $rf 1684 } elseif {$flags(position,$cf,$rf) == "bk"} { 1685 set flags(position,bk,c) $cf 1686 set flags(position,bk,r) $rf 1687 } 1688 if {$enpassantback != ""} { 1689 set flags(position,$enpassantx,$enpassanty) $enpassantback 1690 } 1691 1692 return $checks 1693} 1694 1695proc chess::test_pawns {gid color c r} { 1696 variable moves 1697 variable $gid 1698 upvar 0 $gid flags 1699 1700 if {[is_white $color]} { 1701 foreach {x y} $moves(bpt,$c,$r) { 1702 if {$flags(position,$x,$y) == "wp"} { 1703 return 1 1704 } 1705 } 1706 } else { 1707 foreach {x y} $moves(wpt,$c,$r) { 1708 if {$flags(position,$x,$y) == "bp"} { 1709 return 1 1710 } 1711 } 1712 } 1713 return 0 1714} 1715 1716proc chess::test_figures {gid color c r} { 1717 variable moves 1718 variable $gid 1719 upvar 0 $gid flags 1720 1721 if {[is_white $color]} { 1722 foreach i {d1 d2 d3 d4} { 1723 foreach {x y} $moves($i,$c,$r) { 1724 switch -- $flags(position,$x,$y) { 1725 "" {continue} 1726 wq - 1727 wb {return 1} 1728 default {break} 1729 } 1730 } 1731 } 1732 foreach i {h1 h2 v1 v2} { 1733 foreach {x y} $moves($i,$c,$r) { 1734 switch -- $flags(position,$x,$y) { 1735 "" {continue} 1736 wq - 1737 wr {return 1} 1738 default {break} 1739 } 1740 } 1741 } 1742 foreach {x y} $moves(n,$c,$r) { 1743 switch -- $flags(position,$x,$y) { 1744 wn {return 1} 1745 default {continue} 1746 } 1747 } 1748 } else { 1749 foreach i {d1 d2 d3 d4} { 1750 foreach {x y} $moves($i,$c,$r) { 1751 switch -- $flags(position,$x,$y) { 1752 "" {continue} 1753 bq - 1754 bb {return 1} 1755 default {break} 1756 } 1757 } 1758 } 1759 foreach i {h1 h2 v1 v2} { 1760 foreach {x y} $moves($i,$c,$r) { 1761 switch -- $flags(position,$x,$y) { 1762 "" {continue} 1763 bq - 1764 br {return 1} 1765 default {break} 1766 } 1767 } 1768 } 1769 foreach {x y} $moves(n,$c,$r) { 1770 switch -- $flags(position,$x,$y) { 1771 bn {return 1} 1772 default {continue} 1773 } 1774 } 1775 } 1776 return 0 1777} 1778 1779proc chess::is_move_legal {gid cf rf ct rt} { 1780 variable $gid 1781 upvar 0 $gid flags 1782 1783 expr {[lmatch -regexp $flags(legal_moves) ^[list $cf $rf $ct $rt]] != {}} 1784} 1785 1786proc chess::highlight_legal_moves {gid cf rf} { 1787 variable $gid 1788 upvar 0 $gid flags 1789 1790 foreach move [lmatch -regexp $flags(legal_moves) ^[list $cf $rf]] { 1791 lassign $move cft rft ct rt 1792 $flags(board) addtag legal withtag [list cr $ct $rt]&&square 1793 1794 } 1795 $flags(board) itemconfigure legal&&square -outline blue 1796} 1797 1798proc chess::unhighlight_legal_moves {gid} { 1799 variable $gid 1800 upvar 0 $gid flags 1801 1802 foreach sq [$flags(board) find withtag legal&&square] { 1803 $flags(board) itemconfigure $sq \ 1804 -outline [$flags(board) itemcget $sq -fill] 1805 } 1806 $flags(board) dtag legal 1807} 1808 1809proc chess::attention_message {gid message} { 1810 variable $gid 1811 upvar 0 $gid flags 1812 1813 set hw $flags(hw) 1814 $hw configure -state normal 1815 $hw delete {end -1 char} end 1816 $hw insert end $message attention 1817 $hw see end 1818 $hw configure -state disabled 1819} 1820 1821proc chess::is_my_move {gid} { 1822 variable $gid 1823 upvar 0 $gid flags 1824 1825 is_same_color $flags(position,turn) $flags(our_color) 1826} 1827 1828proc chess::is_white {f} { 1829 string equal -length 1 $f w 1830} 1831 1832proc chess::is_black {f} { 1833 string equal -length 1 $f b 1834} 1835 1836proc chess::is_same_color {f1 f2} { 1837 string equal -length 1 $f1 $f2 1838} 1839 1840proc chess::add_groupchat_user_menu_item {m xlib jid} { 1841 set mm $m.gamesmenu 1842 if {![winfo exists $mm]} { 1843 menu $mm -tearoff 0 1844 $m add cascade -label [::msgcat::mc "Games"] -menu $mm 1845 } 1846 $mm add command -label [::msgcat::mc "Chess..."] \ 1847 -command [list [namespace current]::invite_dialog $xlib $jid] 1848} 1849 1850proc chess::iq_create {varname xlib from iqid xml} { 1851 upvar 2 $varname var 1852 1853 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1854 1855 if {[::xmpp::xml::getAttr $attrs type] == "chess"} { 1856 if {[::xmpp::xml::isAttr $attrs color]} { 1857 set color [::xmpp::xml::getAttr $attrs color] 1858 switch -- $color { 1859 white - 1860 black { } 1861 default { 1862 set var [list error modify bad-request] 1863 } 1864 } 1865 } else { 1866 set color white 1867 } 1868 set var [[namespace current]::invited_dialog \ 1869 $xlib $from $iqid \ 1870 [::xmpp::xml::getAttr $attrs id] \ 1871 $color] 1872 } 1873 return 1874} 1875 1876proc chess::iq_turn {varname xlib from xml} { 1877 upvar 2 $varname var 1878 1879 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1880 1881 if {[::xmpp::xml::getAttr $attrs type] == "chess"} { 1882 set gid [make_gid $from [::xmpp::xml::getAttr $attrs id]] 1883 if {[exists $gid]} { 1884 set var [[namespace current]::turn_recv $gid $subels] 1885 } else { 1886 set var [list error cancel item-not-found] 1887 } 1888 } 1889 return 1890} 1891 1892 1893# Common games:board part 1894proc iq_games_board_create {xlib from xml args} { 1895 set res [list error cancel feature-not-implemented] 1896 set iqid [::xmpp::xml::getAttr $args -id] 1897 hook::run games_board_create_hook res $xlib $from $iqid $xml 1898 return $res 1899} 1900 1901proc iq_games_board_turn {xlib from xml args} { 1902 set res [list error cancel feature-not-implemented] 1903 hook::run games_board_turn_hook res $xlib $from $xml 1904 return $res 1905} 1906 1907