1# $Id$ 2 3# This plugin uses long arithmetics, so it requires Tcl 8.5 4 5if {![package vsatisfies [package present Tcl] 8.5]} return 6 7package require msgcat 8 9namespace eval poker { 10 ::msgcat::mcload [file join [file dirname [info script]] msgs] 11 12 if {![::plugins::is_registered poker]} { 13 ::plugins::register poker \ 14 -namespace [namespace current] \ 15 -source [info script] \ 16 -description \ 17 [::msgcat::mc "Whether the Poker (Texas\ 18 hold'em) plugin is loaded."] \ 19 -loadcommand [namespace code load] \ 20 -unloadcommand [namespace code unload] 21 return 22 } 23 24 variable themes 25 set dirs \ 26 [glob -nocomplain -directory [file join [file dirname [info script]] \ 27 pixmaps] *] 28 foreach dir $dirs { 29 pixmaps::load_theme_name [namespace current]::themes $dir 30 } 31 set values {} 32 foreach theme [lsort [array names themes]] { 33 lappend values $theme $theme 34 } 35 36 custom::defgroup Plugins [::msgcat::mc "Plugins options."] \ 37 -group Tkabber 38 39 custom::defgroup Poker [::msgcat::mc "Poker (Texas hold'em) plugin\ 40 options."] \ 41 -group Plugins 42 custom::defvar options(theme) Classic \ 43 [::msgcat::mc "Poker playing cards theme."] -group Poker \ 44 -type options -values $values \ 45 -command [namespace code load_stored_theme] 46 custom::defvar options(show_tooltips) 1 \ 47 [::msgcat::mc "Show tooltips with short instructions."] \ 48 -type boolean -group Poker \ 49 -command [namespace code set_tooltips] 50 custom::defvar options(sound) "" \ 51 [::msgcat::mc "Sound to play after opponent's deal or bet"] \ 52 -type file -group Poker 53 54 variable prime1 \ 55 0x[join {FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1 56 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD 57 EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245 58 E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF} ""] 59 variable generator1 2 60 variable bytesp1 96 ; # Prime1 length 61 variable bytes1 40 ; # Key length 62 63 option add *Poker*tableBackground #8fbc8f widgetDefault 64 option add *Poker*tableForeground #cdddcd widgetDefault 65 66 variable card_width 71 67 variable card_height 96 68 variable line_width 5 69 variable line_pad 5 70 variable line_margin 10 71 variable text_height 20 72} 73 74proc poker::load {} { 75 hook::add roster_create_groupchat_user_menu_hook \ 76 [namespace current]::add_groupchat_user_menu_item 48.4 77 hook::add chat_create_user_menu_hook \ 78 [namespace current]::add_groupchat_user_menu_item 48.4 79 hook::add roster_jid_popup_menu_hook \ 80 [namespace current]::add_groupchat_user_menu_item 48.4 81 82 hook::add games_cards_create_hook [namespace current]::iq_create 83 hook::add games_cards_turn_hook [namespace current]::iq_turn 84 85 ::xmpp::iq::register set create games:cards \ 86 [namespace parent]::iq_games_cards_create 87 ::xmpp::iq::register set * games:cards \ 88 [namespace parent]::iq_games_cards_turn 89 90 load_stored_theme 91} 92 93proc poker::unload {} { 94 hook::remove roster_create_groupchat_user_menu_hook \ 95 [namespace current]::add_groupchat_user_menu_item 48.4 96 hook::remove chat_create_user_menu_hook \ 97 [namespace current]::add_groupchat_user_menu_item 48.4 98 hook::remove roster_jid_popup_menu_hook \ 99 [namespace current]::add_groupchat_user_menu_item 48.4 100 101 hook::remove games_cards_create_hook [namespace current]::iq_create 102 hook::remove games_cards_turn_hook [namespace current]::iq_turn 103 104 if {[hook::is_empty games_cards_create_hook]} { 105 ::xmpp::iq::unregister set create games:cards 106 rename [namespace parent]::iq_games_cards_create "" 107 } 108 109 if {[hook::is_empty games_cards_turn_hook]} { 110 ::xmpp::iq::unregister set * games:cards 111 rename [namespace parent]::iq_games_cards_turn "" 112 } 113 114 foreach var [info vars [namespace current]::*] { 115 upvar #0 $var flags 116 if {[info exists flags(window)]} { 117 destroy_win $flags(window) 118 } 119 } 120 121 foreach var [info vars [namespace current]::*] { 122 if {$var ne "[namespace current]::options"} { 123 unset $var 124 } 125 } 126 127 foreach img [image names] { 128 if {[string first poker/ $img] == 0} { 129 image delete $img 130 } 131 } 132} 133 134proc poker::load_stored_theme {args} { 135 variable options 136 variable themes 137 138 pixmaps::load_dir $themes($options(theme)) 139} 140 141proc poker::make_gid {jid id} { 142 jid_to_tag [concat $jid $id] 143} 144 145proc poker::invite_dialog {xlib jid} { 146 set w .poker_invite 147 148 if {[winfo exists $w]} { 149 destroy $w 150 } 151 152 Dialog $w -title [::msgcat::mc "Poker Invitation"] \ 153 -modal none \ 154 -separator 1 \ 155 -anchor e \ 156 -default 0 157 158 set wf [$w getframe] 159 message $wf.message -aspect 50000 \ 160 -text [::msgcat::mc "Sending Poker (Texas hold'em) game\ 161 invitation to %s (%s)" \ 162 [chat::get_nick $xlib $jid chat] \ 163 $jid] 164 pack $wf.message -pady 2m 165 166 $w add -text [::msgcat::mc "I want to deal first"] \ 167 -command [namespace code [list invite $xlib $jid true]] 168 $w add -text [::msgcat::mc "I want to deal second"] \ 169 -command [namespace code [list invite $xlib $jid false]] 170 $w add -text [::msgcat::mc "Cancel invitation"] \ 171 -command [list destroy $w] 172 173 $w draw 174} 175 176proc poker::invite {xlib jid deal} { 177 destroy .poker_invite 178 179 set id poker[rand 1000000000] 180 181 # FIX 182 #set rjid [get_jid_of_user $jid] 183 184 set fields [concat [::xmpp::data::formField field \ 185 -var FORM_TYPE \ 186 -type hidden \ 187 -value games:cards:dn] \ 188 [::xmpp::data::formField field \ 189 -var modp \ 190 -type list-single \ 191 -options {"" 1}]] 192 set feature \ 193 [::xmpp::xml::create feature \ 194 -xmlns http://jabber.org/protocol/feature-neg \ 195 -subelement [::xmpp::data::form $fields]] 196 197 ::xmpp::sendIQ $xlib set \ 198 -query [::xmpp::xml::create create \ 199 -xmlns games:cards \ 200 -attrs [list type poker:th:1 \ 201 id $id \ 202 deal $deal] \ 203 -subelement $feature] \ 204 -to $jid \ 205 -command [namespace code [list invite_res $xlib $jid $id $deal]] 206} 207 208proc poker::invite_res {xlib jid id deal status xml} { 209 if {![string equal $status ok]} { 210 after idle [list NonmodalMessageDlg .poker_invite_error \ 211 -aspect 50000 \ 212 -icon error \ 213 -message [::msgcat::mc "%s (%s) has refused poker\ 214 invitation: %s" \ 215 [chat::get_nick $xlib $jid chat] \ 216 $jid [error_to_string $xml]]] 217 return 218 } 219 220 # TODO: Parse negotiation submit form 221 start_play $xlib $jid $id $deal 1 222} 223 224proc poker::invited_dialog {xlib jid iqid id deal modp} { 225 set w .poker_invited 226 227 if {[winfo exists $w]} { 228 destroy $w 229 } 230 231 Dialog $w -title [::msgcat::mc "Poker Invitation from %s" $jid] \ 232 -modal none \ 233 -separator 1 \ 234 -anchor e \ 235 -default 0 236 237 set wf [$w getframe] 238 bind $wf <Destroy> [namespace code [list invited_res $w $xlib $jid $iqid $id $deal $modp 0]] 239 240 set nick [chat::get_nick $xlib $jid chat] 241 set message1 [::msgcat::mc "Poker (Texas hold'em) game invitation from %s (%s) is received." \ 242 $nick $jid] 243 switch -- $deal { 244 true { 245 set message2 [::msgcat::mc "%s wants to deal first." $nick] 246 } 247 false { 248 set message2 [::msgcat::mc "%s wants to deal second." $nick] 249 } 250 default { 251 return [list error modify bad-request] 252 } 253 } 254 message $wf.message1 -aspect 50000 -text $message1 255 message $wf.message2 -aspect 50000 -text $message2 256 pack $wf.message1 -pady 1m 257 pack $wf.message2 -pady 1m 258 259 $w add -text [::msgcat::mc "Agree to play"] \ 260 -command [namespace code [list invited_res $w $xlib $jid $iqid $id $deal $modp 1]] 261 $w add -text [::msgcat::mc "Refuse to play"] \ 262 -command [namespace code [list invited_res $w $xlib $jid $iqid $id $deal $modp 0]] 263 264 $w draw 265 return 266} 267 268proc poker::invited_res {w xlib jid iqid id deal modp res} { 269 catch { 270 set wf [$w getframe] 271 bind $wf <Destroy> {} 272 destroy $w 273 } 274 275 if {$res} { 276 switch -- $deal { 277 true { 278 start_play $xlib $jid $id false $modp 279 } 280 false { 281 start_play $xlib $jid $id true $modp 282 } 283 default { 284 ::xmpp::sendIQ $xlib error \ 285 -error [::xmpp::stanzaerror::error \ 286 modify bad-request] \ 287 -to $jid \ 288 -id $iqid 289 } 290 } 291 292 set feature \ 293 [::xmpp::xml::create feature \ 294 -xmlns http://jabber.org/protocol/feature-neg \ 295 -subelement [::xmpp::data::submitForm [list FORM_TYPE games:cards:dn \ 296 modp $modp]]] 297 298 ::xmpp::sendIQ $xlib result \ 299 -query [::xmpp::xml::create create \ 300 -xmlns games:cards \ 301 -attrs [list type poker:th:1 \ 302 id $id] \ 303 -subelement $feature] \ 304 -to $jid \ 305 -id $iqid 306 } else { 307 ::xmpp::sendIQ $xlib error \ 308 -error [::xmpp::stanzaerror::error \ 309 modify not-acceptable] \ 310 -to $jid \ 311 -id $iqid 312 } 313 return 314} 315 316proc poker::start_play {xlib jid id deal modp} { 317 set gid [make_gid $jid $id] 318 variable $gid 319 variable options 320 upvar 0 $gid flags 321 322 set flags(window) [win_id poker $gid] 323 set flags(xlib) $xlib 324 set flags(opponent) $jid 325 set flags(id) $id 326 set flags(modp) $modp 327 set flags(deal_first) $deal 328 set flags(deals) 0 329 set flags(stop) 0 330 331 # TODO: Negotiate these values 332 set flags(my_stack) 2000 333 set flags(opp_stack) 2000 334 set flags(small_blind) 10 335 set flags(big_blind) 20 336 set flags(double_blinds) 4 337 338 trace variable [namespace current]::${gid}(state) w \ 339 [namespace code [list on_state_change $gid]] 340 341 open $gid 342} 343 344proc poker::close {gid} { 345 variable $gid 346 upvar 0 $gid flags 347 348 array unset flags 349} 350 351proc poker::exists {gid} { 352 variable $gid 353 info exists $gid 354} 355 356proc poker::open {gid} { 357 variable line_margin 358 variable line_width 359 variable line_pad 360 variable card_width 361 variable card_height 362 variable text_height 363 variable options 364 variable $gid 365 upvar 0 $gid flags 366 367 set jid $flags(opponent) 368 369 set w $flags(window) 370 if {[winfo exists $w]} { 371 raise_win $w 372 return 373 } 374 375 set title [::msgcat::mc "Poker with %s" [chat::get_nick $flags(xlib) $jid chat]] 376 add_win $w -title $title \ 377 -tabtitle $title \ 378 -class Poker \ 379 -raise 1 380 381 variable board_width [expr {4*$line_margin + 6*$line_width + 8*$line_pad + 5*$card_width}] 382 variable board_height [expr {8*$line_margin + 6*$line_width + 6*$line_pad + 3*$card_height + 2*$text_height}] 383 384 set board [canvas $w.board \ 385 -width $board_width \ 386 -height $board_height] 387 set background [option get $board tableBackground Poker] 388 $board configure -background $background 389 pack $board -side left -anchor w -padx 10 390 391 set color [option get $board tableForeground Poker] 392 set x1 [expr {($board_width - 2*$line_width - 3*$line_pad - 2*$card_width)/2}] 393 set y1 [expr {$board_height - $line_margin}] 394 set x2 [expr {$board_width - $x1}] 395 set y2 [expr {$y1 - 2*$line_width - 2*$line_pad - $card_height}] 396 $board create polygon $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ 397 -fill "" -outline $color -width $line_width -joinstyle round 398 399 set y1 [expr {$board_height - $y1}] 400 set y2 [expr {$board_height - $y2}] 401 $board create polygon $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ 402 -fill "" -outline $color -width $line_width -joinstyle round 403 404 set x1 [expr {$line_margin}] 405 set x2 [expr {$x1 + 2*$line_width + 4*$line_pad + 3*$card_width}] 406 set y1 [expr {($board_height - 2*$line_width - 2*$line_pad - $card_height)/2}] 407 set y2 [expr {$board_height - $y1}] 408 $board create polygon $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ 409 -fill "" -outline $color -width $line_width -joinstyle round 410 411 set x1 [expr {$x2 + $line_margin}] 412 set x2 [expr {$x1 + 2*$line_width + 2*$line_pad + $card_width}] 413 $board create polygon $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ 414 -fill "" -outline $color -width $line_width -joinstyle round 415 416 set x1 [expr {$x2 + $line_margin}] 417 set x2 [expr {$x1 + 2*$line_width + 2*$line_pad + $card_width}] 418 $board create polygon $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ 419 -fill "" -outline $color -width $line_width -joinstyle round 420 421 frame $w.mystack -background $background 422 label $w.mystack.label -text [::msgcat::mc "Stack: "] -background $background 423 grid $w.mystack.label -row 1 -column 0 -sticky w 424 label $w.mystack.stack -anchor w -background $background \ 425 -textvariable [namespace current]::${gid}(my_stack) 426 grid $w.mystack.stack -row 1 -column 1 -sticky w 427 label $w.mystack.lbet -text [::msgcat::mc "Bet:"] -background $background 428 grid $w.mystack.lbet -row 0 -column 0 -sticky w 429 label $w.mystack.bet -anchor w -background $background \ 430 -textvariable [namespace current]::${gid}(my_bet) 431 grid $w.mystack.bet -row 0 -column 1 -sticky w 432 set x [expr {($board_width - $line_pad)/2 - $card_width - $line_pad - $line_width - $line_margin}] 433 set y [expr {$board_height - ($line_margin + 2*$line_width + 2*$line_pad + $card_height)}] 434 $board create window $x $y -window $w.mystack -anchor ne 435 436 frame $w.oppstack -background $background 437 label $w.oppstack.label -text [::msgcat::mc "Stack: "] -background $background 438 grid $w.oppstack.label -row 0 -column 0 -sticky w 439 label $w.oppstack.stack -anchor w -background $background \ 440 -textvariable [namespace current]::${gid}(opp_stack) 441 grid $w.oppstack.stack -row 0 -column 1 -sticky w 442 label $w.oppstack.lbet -text [::msgcat::mc "Bet:"] -background $background 443 grid $w.oppstack.lbet -row 1 -column 0 -sticky w 444 label $w.oppstack.bet -anchor w -background $background \ 445 -textvariable [namespace current]::${gid}(opp_bet) 446 grid $w.oppstack.bet -row 1 -column 1 -sticky w 447 set x [expr {($board_width - $line_pad)/2 - $card_width - $line_pad - $line_width - $line_margin}] 448 set y [expr {$line_margin + 2*$line_width + 2*$line_pad + $card_height}] 449 $board create window $x $y -window $w.oppstack -anchor se 450 451 set flags(board) $board 452 453 frame $w.info1 454 pack $w.info1 -side top -anchor w 455 label $w.info1.ldealer -text [::msgcat::mc "Dealer: "] 456 grid $w.info1.ldealer -row 0 -column 0 -sticky w 457 label $w.info1.dealer -anchor w \ 458 -textvariable [namespace current]::${gid}(dealer) 459 grid $w.info1.dealer -row 0 -column 1 -sticky w 460 461 label $w.info1.lsblind -text [::msgcat::mc "Small blind: "] 462 grid $w.info1.lsblind -row 1 -column 0 -sticky w 463 label $w.info1.sblind -anchor w \ 464 -textvariable [namespace current]::${gid}(small_blind) 465 grid $w.info1.sblind -row 1 -column 1 -sticky w 466 467 label $w.info1.lbblind -text [::msgcat::mc "Big blind: "] 468 grid $w.info1.lbblind -row 2 -column 0 -sticky w 469 label $w.info1.bblind -anchor w \ 470 -textvariable [namespace current]::${gid}(big_blind) 471 grid $w.info1.bblind -row 2 -column 1 -sticky w 472 473 set bbox [ButtonBox $w.bbox -orient vertical -spacing 0] 474 $bbox add -text [::msgcat::mc "Bet"] \ 475 -state disabled \ 476 -command [namespace code [list bet $gid bet]] 477 $bbox add -text [string trim [::msgcat::mc "Check "]] \ 478 -state disabled \ 479 -command [namespace code [list bet $gid check]] 480 $bbox add -text [string trim [::msgcat::mc "Fold "]] \ 481 -state disabled \ 482 -command [namespace code [list bet $gid fold]] 483 $bbox add -text [::msgcat::mc "Stop the game"] \ 484 -command [namespace code [list stop_game $gid]] 485 grid columnconfigure $bbox 0 -weight 1 486 pack $bbox -side bottom -anchor w -fill x 487 set flags(bbox) $bbox 488 #set_tooltips 489 490 frame $w.info5 491 pack $w.info5 -side bottom -anchor w -fill x 492 scale $w.info5.scale -state disabled -orient horizontal \ 493 -showvalue 0 -from $flags(big_blind) -to $flags(my_stack) \ 494 -resolution $flags(big_blind) \ 495 -variable [namespace current]::${gid}(bet_or_raise_amount) 496 pack $w.info5.scale -side left -anchor w -expand yes -fill x 497 set flags(scale) $w.info5.scale 498 499 frame $w.info4 500 pack $w.info4 -side bottom -anchor w -fill x 501 label $w.info4.lamount -state disabled -text [::msgcat::mc "Amount to bet: "] 502 pack $w.info4.lamount -side left 503 entry $w.info4.amount -state disabled \ 504 -textvariable [namespace current]::${gid}(bet_or_raise_amount) 505 pack $w.info4.amount -side left -anchor w -expand yes -fill x 506 set flags(lentry) $w.info4.lamount 507 set flags(entry) $w.info4.amount 508 509 trace variable [namespace current]::${gid}(bet_or_raise_amount) w \ 510 [namespace code [list configure_raise_button $gid]] 511 512 Button $w.allin -text [string trim [::msgcat::mc "All-In "]] \ 513 -state disabled \ 514 -command [namespace code [list bet $gid allin]] 515 pack $w.allin -side bottom -anchor w -fill x 516 set flags(button_allin) $w.allin 517 518 set hsw [ScrolledWindow $w.hsw] 519 pack $hsw -side top -fill x -expand yes 520 set ht [text $w.text -wrap word -height 60 -state disabled] 521 $ht tag configure attention -foreground [option get $ht errorForeground Text] 522 $hsw setwidget $ht 523 set flags(hw) $ht 524 525 bind $w <Destroy> [namespace code [list close $gid]] 526 527 add_to_log $gid [::msgcat::mc "Starting the game"] 528 add_to_log $gid [::msgcat::mc "Your stack is %s" $flags(my_stack)] 529 add_to_log $gid [::msgcat::mc "Opponent's stack is %s" $flags(opp_stack)] 530 add_to_log $gid [::msgcat::mc "Small blind is %s" $flags(small_blind)] 531 add_to_log $gid [::msgcat::mc "Big blind is %s" $flags(big_blind)] 532 add_to_log $gid [::msgcat::mc "Blinds are doubled every %s deals" $flags(double_blinds)] 533 if {$flags(deal_first)} { 534 add_to_log $gid [::msgcat::mc "You deal first"] 535 536 set_state $gid new 537 } else { 538 add_to_log $gid [::msgcat::mc "Opponent deals first"] 539 540 # Can't use set_state here because of sync problem if the opponent is 541 # already sent us a deck 542 set flags(state) new 543 } 544} 545 546proc poker::add_to_log {gid message} { 547 variable $gid 548 upvar 0 $gid flags 549 550 $flags(hw) configure -state normal 551 $flags(hw) insert end "\[[clock format [clock seconds] -format %H:%M:%S]\] $message\n" 552 $flags(hw) configure -state disabled 553 $flags(hw) see end 554} 555 556proc poker::configure_raise_button {gid args} { 557 variable $gid 558 upvar 0 $gid flags 559 560 if {$flags(state) eq "new"} return 561 562 if {$flags(my_bet) == $flags(opp_bet)} { 563 $flags(bbox) itemconfigure 0 \ 564 -text [::msgcat::mc "Bet %s" $flags(bet_or_raise_amount)] \ 565 -command [namespace code [list bet $gid bet $flags(bet_or_raise_amount)]] 566 } else { 567 $flags(bbox) itemconfigure 0 \ 568 -text [::msgcat::mc "Raise %s" $flags(bet_or_raise_amount)] \ 569 -command [namespace code [list bet $gid raise $flags(bet_or_raise_amount)]] 570 } 571} 572 573proc poker::bet {gid tag {amount ""}} { 574 variable $gid 575 upvar 0 $gid flags 576 577 if {$amount ne ""} { 578 set attrs [list amount $amount] 579 } else { 580 set attrs {} 581 } 582 583 ::xmpp::sendIQ $flags(xlib) set \ 584 -query [::xmpp::xml::create bet \ 585 -xmlns games:cards \ 586 -attrs [list type poker:th:1 id $flags(id)] \ 587 -subelement [::xmpp::xml::create $tag \ 588 -attrs $attrs]] \ 589 -to $flags(opponent) \ 590 -command [namespace code [list bet_result $gid $tag $amount]] 591} 592 593proc poker::bet_result {gid tag amount status xml} { 594 variable $gid 595 upvar 0 $gid flags 596 597 if {![string equal $status ok]} { 598 # TODO 599 return 600 } 601 602 set state $flags(state) 603 switch -- $flags(state) { 604 preflop { 605 set newstate flop-deal 606 } 607 flop { 608 set newstate turn-deal 609 } 610 turn { 611 set newstate river-deal 612 } 613 river { 614 set newstate finish 615 } 616 default { 617 # TODO: Some error message 618 return 619 } 620 } 621 622 set flags(bet) [expr {!$flags(bet)}] 623 incr flags(bets) 624 625 switch -- $tag { 626 call { 627 set call [expr {$flags(opp_bet) - $flags(my_bet)}] 628 incr flags(my_stack) -$call 629 incr flags(my_bet) $call 630 draw_bet $gid 1 [::msgcat::mc "Call"] 631 add_to_log $gid [::msgcat::mc "You call %s" $call] 632 } 633 allin { 634 incr flags(my_bet) $flags(my_stack) 635 set flags(my_stack) 0 636 set flags(my_all_in) 1 637 draw_bet $gid 1 [::msgcat::mc "All-In"] 638 add_to_log $gid [::msgcat::mc "You go all-in"] 639 } 640 bet - 641 raise { 642 incr flags(my_stack) -$amount 643 incr flags(my_bet) $amount 644 draw_bet $gid 1 [::msgcat::mc "Raise"] 645 add_to_log $gid [::msgcat::mc "You raise %s" $amount] 646 } 647 check { 648 draw_bet $gid 1 [::msgcat::mc "Check"] 649 add_to_log $gid [::msgcat::mc "You check"] 650 } 651 fold { 652 draw_bet $gid 1 [::msgcat::mc "Fold"] 653 draw_bet $gid 0 [::msgcat::mc "Winner"] 654 add_to_log $gid [::msgcat::mc "You fold"] 655 set pot [expr {$flags(my_bet) + $flags(opp_bet)}] 656 incr flags(opp_stack) $pot 657 add_to_log $gid [::msgcat::mc "Opponent won pot %s" $pot] 658 set flags(my_bet) 0 659 set flags(opp_bet) 0 660 set_state $gid check 661 return 662 } 663 } 664 665 # Non-dealer sending call, or calling all-in, or closing check 666 # should switch to the next state without after idle. 667 668 switch -- $tag { 669 check { 670 if {$flags(bets) % 2 == 0} { 671 if {$newstate eq "finish"} { 672 send_open_cards $gid 673 } 674 set flags(state) $newstate 675 } 676 } 677 call { 678 if {$flags(opp_all_in)} { 679 set flags(showdown) 1 680 send_open_cards $gid 681 } 682 if {$flags(bets) != 1} { 683 if {$newstate eq "finish"} { 684 send_open_cards $gid 685 } 686 set flags(state) $newstate 687 } 688 } 689 allin { 690 # All-In is not always closing 691 if {$flags(opp_all_in) || $flags(my_bet) <= $flags(opp_bet)} { 692 set flags(showdown) 1 693 send_open_cards $gid 694 set flags(state) $newstate 695 } 696 } 697 } 698 699 if {$flags(state) eq $state} { 700 start_betting $gid 701 } 702} 703 704proc poker::stop_game {gid} { 705 variable $gid 706 upvar 0 $gid flags 707 708 set flags(stop) 1 709 disable_controls $gid 710 add_to_log $gid [::msgcat::mc "The game is terminated by you"] 711 712 ::xmpp::sendIQ $flags(xlib) set \ 713 -query [::xmpp::xml::create stop \ 714 -xmlns games:cards \ 715 -attrs [list type poker:th:1 \ 716 id $flags(id)]] \ 717 -to $flags(opponent) 718} 719 720proc poker::disable_controls {gid} { 721 variable $gid 722 upvar 0 $gid flags 723 724 $flags(bbox) itemconfigure 0 -text [::msgcat::mc "Bet"] -state disabled 725 $flags(bbox) itemconfigure 1 -text [string trim [::msgcat::mc "Check "]] -state disabled 726 $flags(bbox) itemconfigure 2 -state disabled 727 $flags(bbox) itemconfigure 3 -state disabled 728 $flags(button_allin) configure -state disabled 729 $flags(scale) configure -state disabled 730 $flags(lentry) configure -state disabled 731 $flags(entry) configure -state disabled 732} 733 734proc poker::send_deck {gid} { 735 variable prime1 736 variable bytesp1 737 variable $gid 738 upvar 0 $gid flags 739 740 set deck {} 741 for {set i 0} {$i < 52} {incr i} { 742 set msg [expr {([gen_rnd $bytesp1] & ~0x3f) | $i}] 743 lappend deck $msg 744 } 745 746 set subels {} 747 set ekey [ekey $flags(key)] 748 foreach msg [shuffle $deck] { 749 lappend subels \ 750 [::xmpp::xml::create card \ 751 -attrs [list msg [dec2hex [encipher $ekey $msg]]]] 752 update 753 754 # During update many things may happen 755 if {![exists $gid] || $flags(stop)} return 756 } 757 758 # We don't store the shuffled deck because there will be another 759 # reshuffle at the other side, so this cards order will be useless. 760 761 add_to_log $gid [::msgcat::mc "Sending shuffled deck"] 762 763 ::xmpp::sendIQ $flags(xlib) set \ 764 -query [::xmpp::xml::create deck \ 765 -xmlns games:cards \ 766 -attrs [list type poker:th:1 \ 767 id $flags(id)] \ 768 -subelements $subels] \ 769 -to $flags(opponent) \ 770 -command [namespace code [list send_deck_result $gid]] 771 772 add_to_log $gid [::msgcat::mc "Waiting for reshuffled deck"] 773} 774 775proc poker::send_deck_result {gid status xml} { 776 variable $gid 777 upvar 0 $gid flags 778 779 if {![string equal $status ok]} { 780 # TODO 781 return 782 } 783 784 set flags(deck) {} 785 786 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 787 788 foreach subel $subels { 789 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 790 791 if {[string equal $stag card]} { 792 lappend flags(deck) [hex2dec [::xmpp::xml::getAttr $sattrs msg]] 793 } 794 } 795 796 if {[llength $flags(deck)] != 52} { 797 # TODO 798 return 799 } 800 801 add_to_log $gid [::msgcat::mc "Received reshuffled deck"] 802 803 send_deck2 $gid 804} 805 806proc poker::send_deck2 {gid} { 807 variable prime1 808 variable bytes1 809 variable $gid 810 upvar 0 $gid flags 811 812 set flags(keys) {} 813 for {set i 0} {$i < 52} {incr i} { 814 lappend flags(keys) [gen_rnd $bytes1] 815 } 816 817 set subels {} 818 set dkey [dkey $flags(key)] 819 foreach msg $flags(deck) key $flags(keys) { 820 set ekey [ekey $key] 821 lappend subels \ 822 [::xmpp::xml::create card \ 823 -attrs [list msg [dec2hex [encipher $ekey [decipher $dkey $msg]]]]] 824 update 825 826 # During update many things may happen 827 if {![exists $gid] || $flags(stop)} return 828 } 829 830 # We don't store the shuffled deck because there will be another 831 # reshuffle at the other side, so this cards order will be useless. 832 833 add_to_log $gid [::msgcat::mc "Sending reencrypted deck"] 834 835 ::xmpp::sendIQ $flags(xlib) set \ 836 -query [::xmpp::xml::create redeck \ 837 -xmlns games:cards \ 838 -attrs [list type poker:th:1 \ 839 id $flags(id)] \ 840 -subelements $subels] \ 841 -to $flags(opponent) \ 842 -command [namespace code [list send_deck2_result $gid]] 843 844 add_to_log $gid [::msgcat::mc "Waiting for doubly reencrypted deck"] 845} 846 847proc poker::send_deck2_result {gid status xml} { 848 variable $gid 849 upvar 0 $gid flags 850 851 if {![string equal $status ok]} { 852 # TODO 853 return 854 } 855 856 set flags(deck) {} 857 858 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 859 860 foreach subel $subels { 861 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 862 863 if {[string equal $stag card]} { 864 lappend flags(deck) [hex2dec [::xmpp::xml::getAttr $sattrs msg]] 865 } 866 } 867 868 if {[llength $flags(deck)] != 52} { 869 # TODO 870 return 871 } 872 873 add_to_log $gid [::msgcat::mc "Received doubly reencrypted deck"] 874 875 set_state $gid preflop-deal 876} 877 878proc poker::send_open_cards {gid} { 879 variable $gid 880 upvar 0 $gid flags 881 882 set subels {} 883 884 foreach {seq card} $flags(mvisible_cards) { 885 if {[lsearch -exact $flags(hole_cards) $card] >= 0} { 886 lappend subels \ 887 [::xmpp::xml::create card \ 888 -attrs [list seq $seq \ 889 msg [dec2hex $card]]] 890 lappend flags(ovisible_cards) $seq 891 } 892 } 893 894 ::xmpp::sendIQ $flags(xlib) set \ 895 -query [::xmpp::xml::create open \ 896 -xmlns games:cards \ 897 -attrs [list type poker:th:1 \ 898 id $flags(id)] \ 899 -subelements $subels] \ 900 -to $flags(opponent) \ 901 -command [namespace code [list send_open_cards_result $gid]] 902} 903 904proc poker::send_open_cards_result {gid status xml} { 905 variable $gid 906 upvar 0 $gid flags 907 908 if {![string equal $status ok]} { 909 # TODO 910 return 911 } 912 913 add_to_log $gid [::msgcat::mc "You opened pocket cards to opponent"] 914 915 switch -- $flags(state) { 916 preflop { 917 set_state $gid flop-deal 918 } 919 flop { 920 set_state $gid turn-deal 921 } 922 turn { 923 set_state $gid river-deal 924 } 925 river { 926 set_state $gid finish 927 } 928 } 929} 930 931proc poker::send_hole_cards {gid} { 932 variable $gid 933 upvar 0 $gid flags 934 935 set subels {} 936 937 # Opponent's cards 938 939 foreach seq {0 1} { 940 set dkey [dkey [lindex $flags(keys) $seq]] 941 lappend subels \ 942 [::xmpp::xml::create card \ 943 -attrs [list seq [expr {$seq + 1}] \ 944 hold true \ 945 msg [dec2hex [decipher $dkey [lindex $flags(deck) $seq]]]]] 946 } 947 948 lappend flags(ovisible_cards) 1 2 949 950 # Dealer's cards 951 952 foreach seq {2 3} { 953 lappend subels \ 954 [::xmpp::xml::create card \ 955 -attrs [list seq [expr {$seq + 1}] \ 956 hold false \ 957 msg [dec2hex [lindex $flags(deck) $seq]]]] 958 } 959 960 ::xmpp::sendIQ $flags(xlib) set \ 961 -query [::xmpp::xml::create deal \ 962 -xmlns games:cards \ 963 -attrs [list type poker:th:1 \ 964 id $flags(id)] \ 965 -subelements $subels] \ 966 -to $flags(opponent) \ 967 -command [namespace code [list send_hole_cards_result $gid {3 4}]] 968} 969 970proc poker::send_hole_cards_result {gid seqlist status xml} { 971 variable $gid 972 upvar 0 $gid flags 973 974 if {![string equal $status ok]} { 975 # TODO 976 return 977 } 978 979 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 980 981 foreach subel $subels { 982 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 983 984 if {[string equal $stag card]} { 985 set seq [::xmpp::xml::getAttr $sattrs seq] 986 set dkey [dkey [lindex $flags(keys) [expr {$seq - 1}]]] 987 if {[set idx [lsearch -exact $seqlist $seq]] < 0} { 988 # TODO 989 return 990 } 991 set seqlist [lreplace $seqlist $idx $idx] 992 set card [expr {[decipher $dkey [hex2dec [::xmpp::xml::getAttr $sattrs msg]]] & 0x3f}] 993 lappend flags(mvisible_cards) $seq $card 994 lappend flags(hole_cards) $card 995 } 996 } 997 998 if {[llength $flags(hole_cards)] != 2 || [llength $seqlist] != 0} { 999 # TODO 1000 return 1001 } 1002 1003 add_to_log $gid [::msgcat::mc "You got pocket cards %s" \ 1004 [join [lmap [namespace current]::num2card $flags(hole_cards)] ", "]] 1005 1006 # We're not using set_state here to ensure that immediate bet will 1007 # be processed if any. 1008 1009 set flags(state) preflop 1010} 1011 1012proc poker::draw_hole_cards {gid} { 1013 variable board_height 1014 variable board_width 1015 variable card_height 1016 variable card_width 1017 variable line_margin 1018 variable line_width 1019 variable line_pad 1020 variable $gid 1021 upvar 0 $gid flags 1022 1023 set x [expr {$board_width/2 - $card_width - $line_pad/2}] 1024 set y1 [expr {$board_height - $line_margin - $line_width - $line_pad - $card_height}] 1025 set y2 [expr {$line_margin + $line_width + $line_pad}] 1026 1027 foreach card $flags(hole_cards) { 1028 set c [num2card $card] 1029 $flags(board) create image $x $y1 -anchor nw -image poker/$c -tags card 1030 $flags(board) create image $x $y2 -anchor nw -image poker/back -tags card 1031 set x [expr {$x + $line_pad + $card_width}] 1032 } 1033 1034 set x [expr {$board_width/2 - $card_width - $line_pad/2}] 1035 1036 foreach card $flags(opp_hole_cards) { 1037 set c [num2card $card] 1038 $flags(board) create image $x $y2 -anchor nw -image poker/$c -tags card 1039 set x [expr {$x + $line_pad + $card_width}] 1040 } 1041 1042 catch {$flags(board) lower card bet} 1043} 1044 1045proc poker::draw_flop {gid} { 1046 variable board_height 1047 variable board_width 1048 variable card_height 1049 variable card_width 1050 variable line_margin 1051 variable line_width 1052 variable line_pad 1053 variable $gid 1054 upvar 0 $gid flags 1055 1056 set x [expr {$line_margin + $line_width + $line_pad}] 1057 set y [expr {($board_height - $card_height)/2}] 1058 1059 foreach card $flags(flop) { 1060 set c [num2card $card] 1061 $flags(board) create image $x $y -anchor nw -image poker/$c -tags card 1062 set x [expr {$x + $line_pad + $card_width}] 1063 } 1064} 1065 1066proc poker::draw_turn {gid} { 1067 variable board_height 1068 variable board_width 1069 variable card_height 1070 variable card_width 1071 variable line_margin 1072 variable line_width 1073 variable line_pad 1074 variable $gid 1075 upvar 0 $gid flags 1076 1077 set x [expr {2*$line_margin + 3*$line_width + 5*$line_pad + 3*$card_width}] 1078 set y [expr {($board_height - $card_height)/2}] 1079 1080 foreach card $flags(turn) { 1081 set c [num2card $card] 1082 $flags(board) create image $x $y -anchor nw -image poker/$c -tags card 1083 set x [expr {$x + $line_pad + $card_width}] 1084 } 1085} 1086 1087proc poker::draw_river {gid} { 1088 variable board_height 1089 variable board_width 1090 variable card_height 1091 variable card_width 1092 variable line_margin 1093 variable line_width 1094 variable line_pad 1095 variable $gid 1096 upvar 0 $gid flags 1097 1098 set x [expr {3*$line_margin + 5*$line_width + 7*$line_pad + 4*$card_width}] 1099 set y [expr {($board_height - $card_height)/2}] 1100 1101 foreach card $flags(river) { 1102 set c [num2card $card] 1103 $flags(board) create image $x $y -anchor nw -image poker/$c -tags card 1104 set x [expr {$x + $line_pad + $card_width}] 1105 } 1106} 1107 1108proc poker::draw_best_hand {gid} { 1109 variable board_height 1110 variable board_width 1111 variable card_height 1112 variable card_width 1113 variable line_margin 1114 variable line_width 1115 variable line_pad 1116 variable text_height 1117 variable $gid 1118 upvar 0 $gid flags 1119 1120 $flags(board) delete hand 1121 set color [option get $flags(board) tableForeground Poker] 1122 set x [expr {$board_width/2}] 1123 1124 set msg [score2msg [select_best_hand [concat $flags(hole_cards) \ 1125 $flags(flop) \ 1126 $flags(turn) \ 1127 $flags(river)]]] 1128 set y [expr {($board_height + $card_height)/2 + $text_height + $line_width + $line_pad + $line_margin}] 1129 $flags(board) create text $x $y -anchor center -tags hand \ 1130 -text $msg -fill $color -font {Arial 20 bold} 1131 1132 if {[llength $flags(opp_hole_cards)] == 2} { 1133 # Opponent reveared his cards, so we can evaluate his hand 1134 1135 set msg [score2msg [select_best_hand [concat $flags(opp_hole_cards) \ 1136 $flags(flop) \ 1137 $flags(turn) \ 1138 $flags(river)]]] 1139 1140 set y [expr {($board_height - $card_height)/2 - $text_height - $line_width - $line_pad - $line_margin}] 1141 $flags(board) create text $x $y -anchor center -tags hand \ 1142 -text $msg -fill $color -font {Arial 20 bold} 1143 } 1144} 1145 1146proc poker::send_community_cards {gid seqlist} { 1147 variable $gid 1148 upvar 0 $gid flags 1149 1150 # This proc is calld from after command, so checking the game existence 1151 if {![exists $gid]} return 1152 1153 set flags(ovisible_cards) [concat $flags(ovisible_cards) $seqlist] 1154 set subels {} 1155 1156 foreach seq $seqlist { 1157 set dkey [dkey [lindex $flags(keys) [expr {$seq - 1}]]] 1158 lappend subels \ 1159 [::xmpp::xml::create card \ 1160 -attrs [list seq $seq \ 1161 community true \ 1162 msg [dec2hex [decipher $dkey [lindex $flags(deck) [expr {$seq - 1}]]]]]] 1163 } 1164 1165 ::xmpp::sendIQ $flags(xlib) set \ 1166 -query [::xmpp::xml::create deal \ 1167 -xmlns games:cards \ 1168 -attrs [list type poker:th:1 \ 1169 id $flags(id)] \ 1170 -subelements $subels] \ 1171 -to $flags(opponent) \ 1172 -command [namespace code [list send_community_cards_result $gid $seqlist]] 1173} 1174 1175proc poker::send_community_cards_result {gid seqlist status xml} { 1176 variable $gid 1177 upvar 0 $gid flags 1178 1179 if {![string equal $status ok]} { 1180 # TODO 1181 return 1182 } 1183 1184 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1185 1186 foreach subel $subels { 1187 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 1188 1189 if {[string equal $stag card]} { 1190 set seq [::xmpp::xml::getAttr $sattrs seq] 1191 if {[set idx [lsearch -exact $seqlist $seq]] < 0} { 1192 # TODO 1193 return 1194 } 1195 set seqlist [lreplace $seqlist $idx $idx] 1196 set card [expr {[hex2dec [::xmpp::xml::getAttr $sattrs msg]] & 0x3f}] 1197 switch -- $flags(state) { 1198 flop-deal { 1199 lappend flags(flop) $card 1200 } 1201 turn-deal { 1202 lappend flags(turn) $card 1203 } 1204 river-deal { 1205 lappend flags(river) $card 1206 } 1207 } 1208 lappend flags(mvisible_cards) $seq $card 1209 } 1210 } 1211 1212 if {[llength $seqlist] != 0} { 1213 # TODO 1214 return 1215 } 1216 1217 # We're not using set_state here to ensure that immediate bet will 1218 # be processed if any. 1219 1220 switch -- $flags(state) { 1221 flop-deal { 1222 set flags(state) flop 1223 } 1224 turn-deal { 1225 set flags(state) turn 1226 } 1227 river-deal { 1228 set flags(state) river 1229 } 1230 } 1231} 1232 1233proc poker::start_betting {gid} { 1234 variable $gid 1235 upvar 0 $gid flags 1236 1237 if {$flags(bet) && !$flags(my_all_in)} { 1238 if {$flags(my_bet) == $flags(opp_bet)} { 1239 if {$flags(my_stack) < $flags(big_blind)} { 1240 set flags(bet_or_raise_amount) $flags(big_blind) 1241 $flags(bbox) itemconfigure 0 -text [::msgcat::mc "Bet"] -state disabled 1242 $flags(lentry) configure -state disabled 1243 $flags(entry) configure -state disabled 1244 } else { 1245 $flags(bbox) itemconfigure 0 -text [::msgcat::mc "Bet"] -state normal 1246 set flags(bet_or_raise_amount) $flags(big_blind) 1247 $flags(lentry) configure -state normal 1248 $flags(entry) configure -state normal 1249 } 1250 $flags(bbox) itemconfigure 1 -text [string trim [::msgcat::mc "Check "]] -state normal \ 1251 -command [namespace code [list bet $gid check]] 1252 } elseif {$flags(my_bet) < $flags(opp_bet)} { 1253 set call [expr {$flags(opp_bet) - $flags(my_bet)}] 1254 set raise [expr {2*$call}] 1255 if {$flags(my_stack) < $call} { 1256 set flags(bet_or_raise_amount) $raise 1257 $flags(bbox) itemconfigure 0 -text [string trim [::msgcat::mc "Raise "]] -state disabled 1258 $flags(bbox) itemconfigure 1 -text [string trim [::msgcat::mc "Call "]] -state disabled 1259 $flags(lentry) configure -state disabled 1260 $flags(entry) configure -state disabled 1261 } elseif {$flags(my_stack) < $raise} { 1262 set flags(bet_or_raise_amount) $raise 1263 $flags(bbox) itemconfigure 0 -text [string trim [::msgcat::mc "Raise "]] -state disabled 1264 $flags(bbox) itemconfigure 1 -text [::msgcat::mc "Call %s" $call] -state normal \ 1265 -command [namespace code [list bet $gid call]] 1266 $flags(lentry) configure -state disabled 1267 $flags(entry) configure -state disabled 1268 } else { 1269 $flags(bbox) itemconfigure 0 -text [string trim [::msgcat::mc "Raise "]] -state normal 1270 set flags(bet_or_raise_amount) $raise 1271 $flags(bbox) itemconfigure 1 -text [::msgcat::mc "Call %s" $call] -state normal \ 1272 -command [namespace code [list bet $gid call]] 1273 $flags(lentry) configure -state normal 1274 $flags(entry) configure -state normal 1275 } 1276 } else { 1277 # Can't happen 1278 } 1279 $flags(button_allin) configure -state normal 1280 $flags(bbox) itemconfigure 2 -state normal 1281 } else { 1282 if {$flags(bets) == 0} { 1283 $flags(bbox) itemconfigure 0 -text [::msgcat::mc "Bet"] -state disabled 1284 $flags(bbox) itemconfigure 1 -text [string trim [::msgcat::mc "Check "]] -state disabled 1285 } else { 1286 $flags(bbox) itemconfigure 0 -text [string trim [::msgcat::mc "Raise "]] -state disabled 1287 $flags(bbox) itemconfigure 1 -text [string trim [::msgcat::mc "Call "]] -state disabled 1288 } 1289 $flags(lentry) configure -state disabled 1290 $flags(entry) configure -state disabled 1291 $flags(button_allin) configure -state disabled 1292 $flags(bbox) itemconfigure 2 -state disabled 1293 } 1294} 1295 1296proc poker::turn_recv {gid tag xmllist} { 1297 variable bytes1 1298 variable $gid 1299 upvar 0 $gid flags 1300 1301 if {$flags(stop)} { 1302 # Return error if the game is terminated 1303 1304 return [list error cancel not-acceptable] 1305 } 1306 1307 switch -- $tag { 1308 deck { 1309 add_to_log $gid [::msgcat::mc "Received shuffled deck"] 1310 1311 switch -- $flags(state) { 1312 new { 1313 # We are ready to reshuffle and return the deck 1314 if {$flags(button)} { 1315 return [list error cancel not-acceptable] 1316 } 1317 } 1318 default { 1319 # The deck has come not in time. 1320 return [list error cancel not-acceptable] 1321 } 1322 } 1323 1324 set deck {} 1325 foreach xml $xmllist { 1326 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1327 1328 if {[string equal $tag card]} { 1329 lappend deck [hex2dec [::xmpp::xml::getAttr $attrs msg]] 1330 } 1331 } 1332 1333 add_to_log $gid [::msgcat::mc "Reshuffling deck"] 1334 1335 # Saving flags(deck) for checking for cheaters at the end of the deal 1336 set flags(deck) [shuffle $deck] 1337 1338 if {[llength $flags(deck)] != 52} { 1339 return [list error modify bad-request] 1340 } 1341 1342 set subelements {} 1343 set ekey [ekey $flags(key)] 1344 foreach message $flags(deck) { 1345 lappend subelements \ 1346 [::xmpp::xml::create card \ 1347 -attrs [list msg [dec2hex [encipher $ekey $message]]]] 1348 update 1349 1350 # During update many things may happen 1351 if {![exists $gid] || $flags(stop)} return 1352 } 1353 1354 set_state $gid renew 1355 1356 add_to_log $gid [::msgcat::mc "Returning reshuffled deck"] 1357 1358 return [list result [::xmpp::xml::create deck \ 1359 -xmlns games:cards \ 1360 -attrs [list type poker:th:1 \ 1361 id $flags(id)] \ 1362 -subelements $subelements]] 1363 } 1364 redeck { 1365 add_to_log $gid [::msgcat::mc "Received reencrypted deck"] 1366 1367 switch -- $flags(state) { 1368 renew { 1369 # We are ready to reshuffle and return the deck 1370 if {$flags(button)} { 1371 return [list error cancel not-acceptable] 1372 } 1373 } 1374 default { 1375 # The deck has come not in time. 1376 return [list error cancel not-acceptable] 1377 } 1378 } 1379 1380 set deck {} 1381 foreach xml $xmllist { 1382 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1383 1384 if {[string equal $tag card]} { 1385 lappend deck [hex2dec [::xmpp::xml::getAttr $attrs msg]] 1386 } 1387 } 1388 1389 add_to_log $gid [::msgcat::mc "Reencrypting deck"] 1390 1391 if {[llength $deck] != 52} { 1392 return [list error modify bad-request] 1393 } 1394 1395 set flags(keys) {} 1396 for {set i 0} {$i < 52} {incr i} { 1397 lappend flags(keys) [gen_rnd $bytes1] 1398 } 1399 1400 set subelements {} 1401 set flags(deck) {} 1402 set dkey [dkey $flags(key)] 1403 foreach message $deck key $flags(keys) { 1404 set ekey [ekey $key] 1405 set message2 [decipher $dkey $message] 1406 # Saving flags(deck) for checking for cheaters at the end of the deal 1407 lappend flags(deck) $message2 1408 lappend subelements \ 1409 [::xmpp::xml::create card \ 1410 -attrs [list msg [dec2hex [encipher $ekey $message2]]]] 1411 update 1412 1413 # During update many things may happen 1414 if {![exists $gid] || $flags(stop)} return 1415 } 1416 1417 set_state $gid preflop-deal 1418 1419 add_to_log $gid [::msgcat::mc "Returning doubly reencrypted deck"] 1420 1421 return [list result [::xmpp::xml::create redeck \ 1422 -xmlns games:cards \ 1423 -attrs [list type poker:th:1 \ 1424 id $flags(id)] \ 1425 -subelements $subelements]] 1426 } 1427 deal { 1428 if {$flags(button)} { 1429 return [list error cancel not-acceptable] 1430 } 1431 switch -- $flags(state) { 1432 preflop-deal { 1433 if {[llength $flags(hole_cards)] > 0} { 1434 return [list error cancel not-acceptable] 1435 } 1436 } 1437 flop-deal { 1438 if {[llength $flags(flop)] > 0} { 1439 return [list error cancel not-acceptable] 1440 } 1441 } 1442 turn-deal { 1443 if {[llength $flags(turn)] > 0} { 1444 return [list error cancel not-acceptable] 1445 } 1446 } 1447 river-deal { 1448 if {[llength $flags(river)] > 0} { 1449 return [list error cancel not-acceptable] 1450 } 1451 } 1452 default { 1453 return [list error cancel not-acceptable] 1454 } 1455 } 1456 1457 set subelements {} 1458 1459 foreach xml $xmllist { 1460 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1461 1462 if {[string equal $tag card]} { 1463 if {![::xmpp::xml::isAttr $attrs seq]} { 1464 return [list error cancel not-acceptable] 1465 } 1466 set seq [::xmpp::xml::getAttr $attrs seq] 1467 1468 if {[::xmpp::xml::isAttr $attrs hold]} { 1469 set hold [::xmpp::xml::getAttr $attrs hold] 1470 } else { 1471 set hold false 1472 } 1473 1474 if {[::xmpp::xml::isAttr $attrs community]} { 1475 set community [::xmpp::xml::getAttr $attrs community] 1476 } else { 1477 set community false 1478 } 1479 1480 set dkey [dkey [lindex $flags(keys) [expr {$seq - 1}]]] 1481 set msg [decipher $dkey [hex2dec [::xmpp::xml::getAttr $attrs msg]]] 1482 1483 if {$community} { 1484 lappend subelements \ 1485 [::xmpp::xml::create card \ 1486 -attrs [list seq $seq msg [dec2hex $msg]]] 1487 set card [expr {$msg & 0x3f}] 1488 lappend flags(ovisible_cards) $seq 1489 lappend flags(mvisible_cards) $seq $card 1490 switch -- $flags(state) { 1491 flop-deal { 1492 lappend flags(flop) $card 1493 } 1494 turn-deal { 1495 lappend flags(turn) $card 1496 } 1497 river-deal { 1498 lappend flags(river) $card 1499 } 1500 default { 1501 return [list error cancel not-acceptable] 1502 } 1503 } 1504 } elseif {$hold} { 1505 set card [expr {$msg & 0x3f}] 1506 lappend flags(mvisible_cards) $seq $card 1507 switch -- $flags(state) { 1508 preflop-deal { 1509 lappend flags(hole_cards) $card 1510 } 1511 default { 1512 return [list error cancel not-acceptable] 1513 } 1514 } 1515 } else { 1516 lappend flags(ovisible_cards) $seq 1517 lappend subelements \ 1518 [::xmpp::xml::create card \ 1519 -attrs [list seq $seq msg [dec2hex $msg]]] 1520 switch -- $flags(state) { 1521 preflop-deal {} 1522 default { 1523 return [list error cancel not-acceptable] 1524 } 1525 } 1526 } 1527 } 1528 } 1529 1530 switch -- $flags(state) { 1531 preflop-deal { 1532 add_to_log $gid [::msgcat::mc "You got pocket cards: %s" \ 1533 [join [lmap [namespace current]::num2card $flags(hole_cards)] ", "]] 1534 1535 set_state $gid preflop 1536 } 1537 flop-deal { 1538 set_state $gid flop 1539 } 1540 turn-deal { 1541 set_state $gid turn 1542 } 1543 river-deal { 1544 set_state $gid river 1545 } 1546 } 1547 1548 return [list result [::xmpp::xml::create deal \ 1549 -xmlns games:cards \ 1550 -attrs [list type poker:th:1 \ 1551 id $flags(id)] \ 1552 -subelements $subelements]] 1553 } 1554 bet { 1555 ::xmpp::xml::split [lindex $xmllist 0] tag xmlns attrs cdata subels 1556 1557 switch -- $flags(state) { 1558 preflop - 1559 flop - 1560 turn - 1561 river { 1562 if {$flags(bet)} { 1563 return [list error cancel not-acceptable] 1564 } 1565 } 1566 default { 1567 return [list error cancel not-acceptable] 1568 } 1569 } 1570 1571 set state $flags(state) 1572 switch -- $flags(state) { 1573 preflop { 1574 set newstate flop-deal 1575 } 1576 flop { 1577 set newstate turn-deal 1578 } 1579 turn { 1580 set newstate river-deal 1581 } 1582 river { 1583 set newstate finish 1584 } 1585 } 1586 1587 set flags(bet) [expr {!$flags(bet)}] 1588 incr flags(bets) 1589 1590 switch -- $tag { 1591 call { 1592 set call [expr {$flags(my_bet) - $flags(opp_bet)}] 1593 incr flags(opp_stack) -$call 1594 incr flags(opp_bet) $call 1595 draw_bet $gid 0 [::msgcat::mc "Call"] 1596 add_to_log $gid [::msgcat::mc "Opponent calls %s" $call] 1597 } 1598 allin { 1599 incr flags(opp_bet) $flags(opp_stack) 1600 set flags(opp_stack) 0 1601 set flags(opp_all_in) 1 1602 draw_bet $gid 0 [::msgcat::mc "All-In"] 1603 add_to_log $gid [::msgcat::mc "Opponent goes all-in"] 1604 } 1605 bet - 1606 raise { 1607 set amount [::xmpp::xml::getAttr $attrs amount] 1608 incr flags(opp_stack) -$amount 1609 incr flags(opp_bet) $amount 1610 draw_bet $gid 0 [::msgcat::mc "Raise"] 1611 add_to_log $gid [::msgcat::mc "Opponent raises %s" $amount] 1612 } 1613 check { 1614 draw_bet $gid 0 [::msgcat::mc "Check"] 1615 add_to_log $gid [::msgcat::mc "Opponent checks"] 1616 } 1617 fold { 1618 draw_bet $gid 0 [::msgcat::mc "Fold"] 1619 draw_bet $gid 1 [::msgcat::mc "Winner"] 1620 add_to_log $gid [::msgcat::mc "Opponent folds"] 1621 set pot [expr {$flags(my_bet) + $flags(opp_bet)}] 1622 incr flags(my_stack) $pot 1623 add_to_log $gid [::msgcat::mc "You won pot %s" $pot] 1624 set flags(my_bet) 0 1625 set flags(opp_bet) 0 1626 set_state $gid check 1627 return [list result {}] 1628 } 1629 } 1630 1631 switch -- $tag { 1632 check { 1633 if {$flags(bets) % 2 == 0} { 1634 if {$newstate eq "finish"} { 1635 send_open_cards $gid 1636 } 1637 set flags(state) $newstate 1638 } 1639 } 1640 call { 1641 if {$flags(my_all_in)} { 1642 set flags(showdown) 1 1643 send_open_cards $gid 1644 } 1645 if {$flags(bets) != 1} { 1646 if {$newstate eq "finish"} { 1647 send_open_cards $gid 1648 } 1649 set flags(state) $newstate 1650 } 1651 } 1652 allin { 1653 # All-In is not always closing 1654 if {$flags(my_all_in) || $flags(opp_bet) <= $flags(my_bet)} { 1655 set flags(showdown) 1 1656 send_open_cards $gid 1657 set flags(state) $newstate 1658 } 1659 } 1660 } 1661 1662 if {$flags(state) eq $state} { 1663 start_betting $gid 1664 } 1665 1666 return [list result {}] 1667 } 1668 open { 1669 set flags(opp_hole_cards) {} 1670 foreach xml $xmllist { 1671 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1672 1673 if {[string equal $tag card]} { 1674 if {![::xmpp::xml::isAttr $attrs seq]} { 1675 return [list error cancel not-acceptable] 1676 } 1677 set seq [::xmpp::xml::getAttr $attrs seq] 1678 set msg [hex2dec [::xmpp::xml::getAttr $attrs msg]] 1679 set card [expr {$msg & 0x3f}] 1680 lappend flags(mvisible_cards) $seq $card 1681 lappend flags(opp_hole_cards) $card 1682 } 1683 } 1684 1685 if {[llength $flags(opp_hole_cards)] != 2} { 1686 return [list error cancel not-acceptable] 1687 } else { 1688 draw_hole_cards $gid 1689 add_to_log $gid [::msgcat::mc "Opponent revealed pocket cards: %s" \ 1690 [join [lmap [namespace current]::num2card $flags(opp_hole_cards)] ", "]] 1691 return [list result {}] 1692 } 1693 } 1694 check { 1695 add_to_log $gid [::msgcat::mc "Received deck for checking"] 1696 1697 switch -- $flags(state) { 1698 check {} 1699 default { 1700 # The deck has come not in time. 1701 return [list error cancel not-acceptable] 1702 } 1703 } 1704 1705 set deck {} 1706 foreach {seq card} $flags(mvisible_cards) { 1707 lappend deck $card 1708 } 1709 foreach xml $xmllist { 1710 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 1711 1712 if {[string equal $tag card]} { 1713 set seq [::xmpp::xml::getAttr $attrs seq] 1714 set dkey [dkey [lindex $flags(keys) [expr {$seq - 1}]]] 1715 set msg [decipher $dkey [hex2dec [::xmpp::xml::getAttr $attrs msg]]] 1716 lappend deck [expr {$msg & 0x3f}] 1717 } 1718 update 1719 1720 # During update many things may happen 1721 if {![exists $gid] || $flags(stop)} return 1722 } 1723 1724 set sorted [lsort -integer $deck] 1725 if {[llength $deck] != 52 || [llength $sorted] != 52 || \ 1726 [lindex $sorted 0] != 0 || [lindex $sorted 51] != 51} { 1727 add_to_log $gid [::msgcat::mc "The opponent is cheating"] 1728 1729 return [list error cancel not-acceptable] 1730 } 1731 1732 add_to_log $gid [::msgcat::mc "The opponent's deck is checked successfully"] 1733 1734 set flags(opp_deck_checked) 1 1735 1736 if {$flags(my_deck_checked)} { 1737 set_state $gid new 1738 } 1739 1740 return [list result {}] 1741 } 1742 stop { 1743 set flags(stop) 1 1744 disable_controls $gid 1745 add_to_log $gid [::msgcat::mc "The game is terminated by opponent"] 1746 } 1747 } 1748} 1749 1750proc poker::draw_deck_and_buttons {gid} { 1751 variable board_width 1752 variable board_height 1753 variable card_width 1754 variable card_height 1755 variable line_width 1756 variable line_pad 1757 variable line_margin 1758 variable $gid 1759 upvar 0 $gid flags 1760 1761 set x [expr {$board_width - $line_margin - 4*$line_width - $card_width}] 1762 set x1 [expr {$board_width/2 - $card_width - 3*$line_pad/2 - $line_width - $line_margin}] 1763 set x2 [expr {$x1 - [image width poker/smallblind] - $line_pad}] 1764 if {$flags(button)} { 1765 set y [expr {$board_height - $line_margin - $line_width - $line_pad - $card_height}] 1766 set y1 [expr {$board_height - $line_margin - $line_width - $line_pad}] 1767 set a1 se 1768 set a2 ne 1769 } else { 1770 set y [expr {$line_margin + $line_width + $line_pad}] 1771 set y1 [expr {$line_margin + $line_width + $line_pad}] 1772 set a1 ne 1773 set a2 se 1774 } 1775 set y2 [expr {$board_height - $y1}] 1776 1777 #foreach i {1 2 3 4} { 1778 # $flags(board) create image $x $y -anchor nw -image poker/back -tags card 1779 # incr x $line_width 1780 #} 1781 1782 $flags(board) create image $x2 $y1 -anchor $a1 -image poker/button -tags button 1783 $flags(board) create image $x1 $y1 -anchor $a1 -image poker/smallblind -tags chip 1784 $flags(board) create image $x1 $y2 -anchor $a2 -image poker/bigblind -tags chip 1785} 1786 1787proc poker::draw_bet {gid my {message ""}} { 1788 variable board_width 1789 variable board_height 1790 variable card_width 1791 variable card_height 1792 variable line_width 1793 variable line_pad 1794 variable line_margin 1795 variable $gid 1796 upvar 0 $gid flags 1797 1798 if {$my} { 1799 set tag my_bet 1800 } else { 1801 set tag opp_bet 1802 } 1803 1804 $flags(board) delete $tag 1805 1806 if {$message eq ""} return 1807 1808 set font {Arial 20 bold} 1809 set x [expr {$board_width/2}] 1810 set y [expr {$line_margin + $line_width + $line_pad + $card_height/2}] 1811 if {$my} { 1812 set y [expr {$board_height - $y}] 1813 } 1814 1815 for {set i 0} {$i < 16} {incr i} { 1816 set x1 [expr {$x + 4*cos(3.141592*$i/8)}] 1817 set y1 [expr {$y + 4*sin(3.141592*$i/8)}] 1818 $flags(board) create text $x1 $y1 -text $message -font $font \ 1819 -tags [list bet $tag] -fill black 1820 } 1821 $flags(board) create text $x $y -text $message -font $font \ 1822 -tags [list bet $tag] -fill white 1823} 1824 1825proc poker::set_state {gid state} { 1826 after idle [list [namespace current]::set_state_aux $gid $state] 1827} 1828 1829proc poker::set_state_aux {gid state} { 1830 variable $gid 1831 upvar 0 $gid flags 1832 1833 set flags(state) $state 1834} 1835 1836proc poker::on_state_change {gid args} { 1837 variable bytes1 1838 variable $gid 1839 upvar 0 $gid flags 1840 1841 # This proc is called from after command, so checking the game existence 1842 if {![exists $gid]} return 1843 1844 #add_to_log $gid [::msgcat::mc "New state %s" $flags(state)] 1845 1846 switch -- $flags(state) { 1847 new { 1848 if {$flags(my_stack) <= 0} { 1849 add_to_log $gid [::msgcat::mc "You lost all chips"] 1850 add_to_log $gid [::msgcat::mc "The game is finished"] 1851 disable_controls $gid 1852 return 1853 } 1854 if {$flags(opp_stack) <= 0} { 1855 add_to_log $gid [::msgcat::mc "Opponent lost all chips"] 1856 add_to_log $gid [::msgcat::mc "The game is finished"] 1857 disable_controls $gid 1858 return 1859 } 1860 1861 $flags(board) delete card||button||chip||hand||bet 1862 if {$flags(deals) == 0} { 1863 set flags(button) $flags(deal_first) 1864 } else { 1865 set flags(button) [expr {!$flags(button)}] 1866 } 1867 1868 draw_deck_and_buttons $gid 1869 1870 incr flags(deals) 1871 add_to_log $gid [::msgcat::mc "Starting deal %s" $flags(deals)] 1872 add_to_log $gid [::msgcat::mc "Your stack is %s" $flags(my_stack)] 1873 add_to_log $gid [::msgcat::mc "Opponent's stack is %s" $flags(opp_stack)] 1874 if {($flags(deals) % $flags(double_blinds)) == 0} { 1875 set flags(small_blind) [expr {2*$flags(small_blind)}] 1876 set flags(big_blind) [expr {2*$flags(big_blind)}] 1877 } 1878 add_to_log $gid [::msgcat::mc "Small blind is %s" $flags(small_blind)] 1879 add_to_log $gid [::msgcat::mc "Big blind is %s" $flags(big_blind)] 1880 1881 set flags(my_deck_checked) 0 1882 set flags(opp_deck_checked) 0 1883 1884 set flags(dealer) [expr {$flags(button) ? [::msgcat::mc "You"] : [::msgcat::mc "Opponent"]}] 1885 set flags(bet_or_raise_amount) $flags(big_blind) 1886 set flags(key) [gen_rnd $bytes1] 1887 set flags(deck) {} 1888 set flags(hole_cards) {} 1889 set flags(opp_hole_cards) {} 1890 set flags(flop) {} 1891 set flags(turn) {} 1892 set flags(river) {} 1893 # Cards visible by me in form 'seq' 'card' 1894 set flags(mvisible_cards) {} 1895 # Cards visible by the opponent (only sequence numbers) 1896 set flags(ovisible_cards) {} 1897 1898 set flags(my_all_in) 0 1899 set flags(opp_all_in) 0 1900 set flags(showdown) 0 1901 1902 if {$flags(button)} { 1903 set my_bet $flags(small_blind) 1904 set my_bet_name [::msgcat::mc "small blind"] 1905 set opp_bet $flags(big_blind) 1906 set opp_bet_name [::msgcat::mc "big blind"] 1907 set flags(bet) 1 1908 } else { 1909 set my_bet $flags(big_blind) 1910 set my_bet_name [::msgcat::mc "big blind"] 1911 set opp_bet $flags(small_blind) 1912 set opp_bet_name [::msgcat::mc "small blind"] 1913 set flags(bet) 0 1914 } 1915 if {$flags(my_stack) <= $my_bet} { 1916 set flags(my_bet) $flags(my_stack) 1917 set flags(my_stack) 0 1918 set flags(my_all_in) 1 1919 draw_bet $gid 1 [::msgcat::mc "All-In"] 1920 set flags(bet) 0 1921 add_to_log $gid [::msgcat::mc "You have to go all-in (stack equals %s)" $flags(my_bet)] 1922 } else { 1923 set flags(my_bet) $my_bet 1924 set flags(my_stack) [expr {$flags(my_stack) - $my_bet}] 1925 add_to_log $gid [::msgcat::mc "You bet %s equals to %s" $my_bet_name $my_bet] 1926 } 1927 if {$flags(opp_stack) <= $opp_bet} { 1928 set flags(opp_bet) $flags(opp_stack) 1929 set flags(opp_stack) 0 1930 set flags(opp_all_in) 1 1931 draw_bet $gid 0 [::msgcat::mc "All-In"] 1932 if {!$flags(my_all_in)} { 1933 set flags(bet) 1 1934 } 1935 add_to_log $gid [::msgcat::mc "Opponent has to go all-in (stack equals %s)" $flags(opp_bet)] 1936 } else { 1937 set flags(opp_bet) $opp_bet 1938 set flags(opp_stack) [expr {$flags(opp_stack) - $opp_bet}] 1939 add_to_log $gid [::msgcat::mc "Opponent bets %s equals to %s" $opp_bet_name $opp_bet] 1940 } 1941 set flags(bets) 0 1942 1943 if {$flags(button)} { 1944 add_to_log $gid [::msgcat::mc "Shuffling deck"] 1945 send_deck $gid 1946 } else { 1947 add_to_log $gid [::msgcat::mc "Waiting for shuffled deck"] 1948 } 1949 } 1950 preflop-deal { 1951 if {$flags(button)} { 1952 send_hole_cards $gid 1953 } 1954 } 1955 preflop { 1956 draw_hole_cards $gid 1957 if {$flags(my_all_in) && ($flags(my_bet) <= $flags(opp_bet))} { 1958 # Opponent automagically calls 1959 1960 set flags(showdown) 1 1961 send_open_cards $gid 1962 } elseif {$flags(opp_all_in) && ($flags(opp_bet) <= $flags(my_bet))} { 1963 # Me automagically call 1964 1965 set flags(showdown) 1 1966 send_open_cards $gid 1967 } else { 1968 if {$flags(button)} { 1969 set flags(bet) 1 1970 } else { 1971 set flags(bet) 0 1972 } 1973 set flags(bets) 0 1974 start_betting $gid 1975 } 1976 } 1977 flop-deal { 1978 if {$flags(button)} { 1979 if {$flags(showdown)} { 1980 set delay 4000 1981 } else { 1982 set delay 0 1983 } 1984 after $delay [namespace code [list send_community_cards $gid {5 6 7}]] 1985 } 1986 1987 if {!$flags(showdown)} { 1988 # Erasing the previous bets 1989 draw_bet $gid 0 1990 draw_bet $gid 1 1991 } 1992 } 1993 flop { 1994 draw_flop $gid 1995 add_to_log $gid [::msgcat::mc "Flop is dealt: %s" \ 1996 [join [lmap [namespace current]::num2card $flags(flop)] ", "]] 1997 draw_best_hand $gid 1998 if {$flags(showdown)} { 1999 set_state $gid turn-deal 2000 } else { 2001 if {$flags(button)} { 2002 set flags(bet) 0 2003 } else { 2004 set flags(bet) 1 2005 } 2006 set flags(bets) 0 2007 start_betting $gid 2008 } 2009 } 2010 turn-deal { 2011 if {$flags(button)} { 2012 if {$flags(showdown)} { 2013 set delay 4000 2014 } else { 2015 set delay 0 2016 } 2017 after $delay [namespace code [list send_community_cards $gid {8}]] 2018 } 2019 2020 if {!$flags(showdown)} { 2021 # Erasing the previous bets 2022 draw_bet $gid 0 2023 draw_bet $gid 1 2024 } 2025 } 2026 turn { 2027 draw_turn $gid 2028 add_to_log $gid [::msgcat::mc "Turn is dealt: %s" \ 2029 [join [lmap [namespace current]::num2card $flags(turn)] ", "]] 2030 draw_best_hand $gid 2031 if {$flags(showdown)} { 2032 set_state $gid river-deal 2033 } else { 2034 if {$flags(button)} { 2035 set flags(bet) 0 2036 } else { 2037 set flags(bet) 1 2038 } 2039 set flags(bets) 0 2040 start_betting $gid 2041 } 2042 } 2043 river-deal { 2044 if {$flags(button)} { 2045 if {$flags(showdown)} { 2046 set delay 4000 2047 } else { 2048 set delay 0 2049 } 2050 after $delay [namespace code [list send_community_cards $gid {9}]] 2051 } 2052 2053 if {!$flags(showdown)} { 2054 # Erasing the previous bets 2055 draw_bet $gid 0 2056 draw_bet $gid 1 2057 } 2058 } 2059 river { 2060 draw_river $gid 2061 add_to_log $gid [::msgcat::mc "River is dealt: %s" \ 2062 [join [lmap [namespace current]::num2card $flags(river)] ", "]] 2063 draw_best_hand $gid 2064 if {$flags(showdown)} { 2065 set_state $gid finish 2066 } else { 2067 if {$flags(button)} { 2068 set flags(bet) 0 2069 } else { 2070 set flags(bet) 1 2071 } 2072 set flags(bets) 0 2073 start_betting $gid 2074 } 2075 } 2076 finish { 2077 disable_controls $gid 2078 $flags(bbox) itemconfigure 3 -state normal 2079 if {[llength $flags(opp_hole_cards)] != 2} { 2080 # Waiting for opponent's cards 2081 after 1000 [list [namespace current]::on_state_change $gid] 2082 } else { 2083 set my_hand [select_best_hand [concat $flags(hole_cards) \ 2084 $flags(flop) \ 2085 $flags(turn) \ 2086 $flags(river)]] 2087 set opp_hand [select_best_hand [concat $flags(opp_hole_cards) \ 2088 $flags(flop) \ 2089 $flags(turn) \ 2090 $flags(river)]] 2091 set my_score [score $my_hand] 2092 set opp_score [score $opp_hand] 2093 add_to_log $gid [::msgcat::mc "Your best hand is %s (%s)" \ 2094 [join [lmap [namespace current]::num2card $my_hand] ", "] \ 2095 [score2msg $my_hand]] 2096 add_to_log $gid [::msgcat::mc "Opponent's best hand is %s (%s)" \ 2097 [join [lmap [namespace current]::num2card $opp_hand] ", "] \ 2098 [score2msg $opp_hand]] 2099 if {$my_score > $opp_score} { 2100 draw_bet $gid 0 "" 2101 draw_bet $gid 1 [::msgcat::mc "Winner"] 2102 if {$flags(my_bet) >= $flags(opp_bet)} { 2103 add_to_log $gid [::msgcat::mc "You won pot %s" [expr {$flags(my_bet) + $flags(opp_bet)}]] 2104 set flags(my_stack) [expr {$flags(my_stack) + $flags(my_bet) + $flags(opp_bet)}] 2105 } else { 2106 add_to_log $gid [::msgcat::mc "You won pot %s" [expr {2*$flags(my_bet)}]] 2107 add_to_log $gid [::msgcat::mc "Opponent won side pot %s" [expr {$flags(opp_bet) - $flags(my_bet)}]] 2108 set flags(my_stack) [expr {$flags(my_stack) + 2*$flags(my_bet)}] 2109 set flags(opp_stack) [expr {$flags(opp_stack) + $flags(opp_bet) - $flags(my_bet)}] 2110 } 2111 } elseif {$my_score < $opp_score} { 2112 draw_bet $gid 1 "" 2113 draw_bet $gid 0 [::msgcat::mc "Winner"] 2114 if {$flags(opp_bet) >= $flags(my_bet)} { 2115 add_to_log $gid [::msgcat::mc "Opponent won pot %s" [expr {$flags(my_bet) + $flags(opp_bet)}]] 2116 set flags(opp_stack) [expr {$flags(opp_stack) + $flags(my_bet) + $flags(opp_bet)}] 2117 } else { 2118 add_to_log $gid [::msgcat::mc "Opponent won pot %s" [expr {2*$flags(opp_bet)}]] 2119 add_to_log $gid [::msgcat::mc "You won side pot %s" [expr {$flags(my_bet) - $flags(opp_bet)}]] 2120 set flags(opp_stack) [expr {$flags(opp_stack) + 2*$flags(opp_bet)}] 2121 set flags(my_stack) [expr {$flags(my_stack) + $flags(my_bet) - $flags(opp_bet)}] 2122 } 2123 } else { 2124 draw_bet $gid 0 [::msgcat::mc "Split"] 2125 draw_bet $gid 1 [::msgcat::mc "Split"] 2126 add_to_log $gid [::msgcat::mc "You and opponent split pot %s" [expr {$flags(my_bet) + $flags(opp_bet)}]] 2127 set flags(my_stack) [expr {$flags(my_stack) + $flags(my_bet)}] 2128 set flags(opp_stack) [expr {$flags(opp_stack) + $flags(opp_bet)}] 2129 } 2130 2131 set flags(my_bet) 0 2132 set flags(opp_bet) 0 2133 2134 set_state $gid check 2135 } 2136 } 2137 check { 2138 disable_controls $gid 2139 $flags(bbox) itemconfigure 3 -state normal 2140 add_to_log $gid [::msgcat::mc "Checking decks"] 2141 after 4000 [namespace code [list check_deck $gid]] 2142 } 2143 } 2144} 2145 2146proc poker::check_deck {gid} { 2147 variable $gid 2148 upvar 0 $gid flags 2149 2150 # This proc is called from after command, so checking the game existence 2151 if {![exists $gid]} return 2152 2153 set subels {} 2154 set seq 1 2155 foreach card $flags(deck) { 2156 if {[lsearch -exact $flags(ovisible_cards) $seq] < 0} { 2157 if {$flags(button)} { 2158 set dkey [dkey [lindex $flags(keys) [expr {$seq - 1}]]] 2159 set msg [dec2hex [decipher $dkey $card]] 2160 } else { 2161 set msg [dec2hex $card] 2162 } 2163 lappend subels [::xmpp::xml::create card \ 2164 -attrs [list seq $seq \ 2165 msg $msg]] 2166 update 2167 2168 # During update many things may happen 2169 if {![exists $gid] || $flags(stop)} return 2170 } 2171 2172 incr seq 2173 } 2174 2175 add_to_log $gid [::msgcat::mc "Sending unencrypted deck for checking"] 2176 2177 ::xmpp::sendIQ $flags(xlib) set \ 2178 -query [::xmpp::xml::create check \ 2179 -xmlns games:cards \ 2180 -attrs [list type poker:th:1 \ 2181 id $flags(id)] \ 2182 -subelements $subels] \ 2183 -to $flags(opponent) \ 2184 -command [namespace code [list check_deck_result $gid]] 2185 2186 add_to_log $gid [::msgcat::mc "Waiting for checked deck"] 2187} 2188 2189proc poker::check_deck_result {gid status xml} { 2190 variable $gid 2191 upvar 0 $gid flags 2192 2193 if {![string equal $status ok]} { 2194 # TODO 2195 add_to_log $gid [::msgcat::mc "Opponent thinks that you cheat"] 2196 return 2197 } 2198 2199 set flags(my_deck_checked) 1 2200 2201 if {$flags(opp_deck_checked)} { 2202 set flags(state) new 2203 } 2204} 2205 2206proc poker::gen_rnd {bytes} { 2207 variable prime1 2208 2209 # TODO: Support for other MODP groups 2210 set num 0 2211 for {set i 0} {$i < $bytes} {incr i 8} { 2212 set num [expr {$num * (16**8) + int((16**8) * rand())}] 2213 } 2214 return [expr {$num % $prime1}] 2215} 2216 2217proc poker::dec2hex {num} { 2218 return [format %llx $num] 2219} 2220 2221proc poker::hex2dec {num} { 2222 return [expr 0x$num] 2223} 2224 2225proc poker::shuffle {deck} { 2226 set deck1 {} 2227 foreach card $deck { 2228 lappend deck1 [list $card [expr {rand()}]] 2229 } 2230 set deck2 {} 2231 foreach card [lsort -real -index 1 $deck1] { 2232 lappend deck2 [lindex $card 0] 2233 } 2234 return $deck2 2235} 2236 2237proc poker::egcd {a b} { 2238 set r [expr {$a % $b}] 2239 if {$r == 0} { 2240 return {0 1} 2241 } else { 2242 lassign [egcd $b $r] x y 2243 return [list $y [expr {$x - $y * ($a / $b)}]] 2244 } 2245} 2246 2247proc poker::exp {a n p} { 2248 # a**n (mod p) 2249 2250 set b 1 2251 while {$n > 0} { 2252 if {$n % 2 == 0} { 2253 set n [expr {$n / 2}] 2254 set a [expr {($a * $a) % $p}] 2255 } else { 2256 incr n -1 2257 set b [expr {($b * $a) % $p}] 2258 } 2259 } 2260 return $b 2261} 2262 2263proc poker::ekey {key} { 2264 variable prime1 2265 variable generator1 2266 2267 exp $generator1 $key $prime1 2268} 2269 2270proc poker::encipher {ekey message} { 2271 variable prime1 2272 2273 expr {($message * $ekey) % $prime1} 2274} 2275 2276proc poker::dkey {key} { 2277 variable prime1 2278 variable generator1 2279 variable generatorm1 2280 2281 if {![info exists generatorm1]} { 2282 lassign [egcd $prime1 $generator1] x y 2283 set generatorm1 [expr {$y % $prime1}] 2284 } 2285 exp $generatorm1 $key $prime1 2286} 2287 2288proc poker::decipher {dkey message} { 2289 variable prime1 2290 2291 expr {($message * $dkey) % $prime1} 2292} 2293 2294proc poker::select_best_hand {cards} { 2295 switch -- [llength $cards] { 2296 5 { 2297 return $cards 2298 } 2299 6 { 2300 set score 0 2301 set hand {} 2302 for {set i 0} {$i < 6} {incr i} { 2303 set h [lreplace $cards $i $i] 2304 set s [score $h] 2305 if {$s > $score} { 2306 set score $s 2307 set hand $h 2308 } 2309 } 2310 return $hand 2311 } 2312 7 { 2313 set score 0 2314 set hand {} 2315 for {set i 0} {$i < 7} {incr i} { 2316 for {set j [expr {$i + 1}]} {$j < 7} {incr j} { 2317 set h [lreplace [lreplace $cards $j $j] $i $i] 2318 set s [score $h] 2319 if {$s > $score} { 2320 set score $s 2321 set hand $h 2322 } 2323 } 2324 } 2325 return $hand 2326 } 2327 default { 2328 return -code error 2329 } 2330 } 2331} 2332 2333proc poker::score2msg {hand} { 2334 set score [score $hand] 2335 2336 if {$score >= 9*16**7} { 2337 return [::msgcat::mc "Royal flush"] 2338 } 2339 if {$score >= 8*16**7} { 2340 return [::msgcat::mc "Straight flush"] 2341 } 2342 if {$score >= 7*16**7} { 2343 return [::msgcat::mc "Four of a kind"] 2344 } 2345 if {$score >= 6*16**7} { 2346 return [::msgcat::mc "Full house"] 2347 } 2348 if {$score >= 5*16**7} { 2349 return [::msgcat::mc "Flush"] 2350 } 2351 if {$score >= 4*16**7} { 2352 return [::msgcat::mc "Straight"] 2353 } 2354 if {$score >= 3*16**7} { 2355 return [::msgcat::mc "Three of a kind"] 2356 } 2357 if {$score >= 2*16**7} { 2358 return [::msgcat::mc "Two pairs"] 2359 } 2360 if {$score >= 1*16**7} { 2361 return [::msgcat::mc "Pair"] 2362 } 2363 if {$score >= 14*16**4} { 2364 return [::msgcat::mc "Ace"] 2365 } 2366 if {$score >= 13*16**4} { 2367 return [::msgcat::mc "King"] 2368 } 2369 if {$score >= 12*16**4} { 2370 return [::msgcat::mc "Queen"] 2371 } 2372 if {$score >= 11*16**4} { 2373 return [::msgcat::mc "Jack"] 2374 } 2375 if {$score >= 10*16**4} { 2376 return [::msgcat::mc "Ten"] 2377 } 2378 if {$score >= 9*16**4} { 2379 return [::msgcat::mc "Nine"] 2380 } 2381 if {$score >= 8*16**4} { 2382 return [::msgcat::mc "Eight"] 2383 } 2384 if {$score >= 7*16**4} { 2385 return [::msgcat::mc "Seven"] 2386 } 2387 # Couldn't reach here 2388 return "" 2389} 2390 2391proc poker::score {hand} { 2392 # hand is a list of numbers 0 <= num < 52 2393 set pips {} 2394 set suits {} 2395 foreach num $hand { 2396 lappend pips [expr {$num / 4 + 2}] 2397 lappend suits [expr {$num % 4}] 2398 } 2399 2400 set pips [lsort -integer $pips] 2401 lassign $pips c0 c1 c2 c3 c4 2402 2403 set straight [expr {($c0==$c1-1 && $c1==$c2-1 && $c2==$c3-1 && $c3==$c4-1) || \ 2404 ($c4==14 && $c0==2 && $c1==3 && $c2==4 && $c3==5)}] 2405 2406 # score could be 0xeeeed max (4 Aces and King) 2407 set score [expr {(((($c4*16) + $c3)*16 + $c2)*16 + $c1)*16 + $c0}] 2408 if {$straight && $c4==14 && $c3==5} { 2409 set score [expr {(((($c3*16) + $c2)*16 + $c1)*16 + $c0)*16 + $c4}] 2410 } 2411 2412 lassign [lsort $suits] s0 s1 s2 s3 s4 2413 set flush [expr {$s0 eq $s4}] 2414 2415 if {$straight == 1 && $flush && $c0 == 10} { 2416 # Royal flush 2417 return [expr {9*16**7}] 2418 } 2419 if {$straight == 1 && $flush} { 2420 # Straight flush 2421 return [expr {8*16**7 + $score}] 2422 } 2423 if {$c0 == $c3 || $c1 == $c4} { 2424 # Four of a kind 2425 return [expr {7*16**7 + $c3*16**6 + $score}] 2426 } 2427 if {$c0 == $c1 && $c2 == $c4} { 2428 # Full house 2429 return [expr {6*16**7 + $c4*16**6 + $score}] 2430 } 2431 if {$c0 == $c2 && $c3 == $c4} { 2432 # Full house 2433 return [expr {6*16**7 + $c2*16**6 + $score}] 2434 } 2435 if {$flush} { 2436 # Flush 2437 return [expr {5*16**7 + $score}] 2438 } 2439 if {$straight} { 2440 # Straight 2441 return [expr {4*16**7 + $score}] 2442 } 2443 if {$c0 == $c2 || $c1 == $c3 || $c2 == $c4} { 2444 # Three of a kind 2445 return [expr {3*16**7 + $c2*16**6 + $score}] 2446 } 2447 if {$c0 == $c1 && $c2 == $c3} { 2448 # Two pairs 2449 return [expr {2*16**7 + $c3*16**6 + $c1*16**5 + $score}] 2450 } 2451 if {$c0 == $c1 && $c3 == $c4} { 2452 # Two pairs 2453 return [expr {2*16**7 + $c4*16**6 + $c1*16**5 + $score}] 2454 } 2455 if {$c1 == $c2 && $c3 == $c4} { 2456 # Two pairs 2457 return [expr {2*16**7 + $c4*16**6 + $c1*16**5 + $score}] 2458 } 2459 if {$c0 == $c1} { 2460 # Pair 2461 return [expr {1*16**7 + $c1*16**6 + $score}] 2462 } 2463 if {$c1 == $c2} { 2464 # Pair 2465 return [expr {1*16**7 + $c2*16**6 + $score}] 2466 } 2467 if {$c2 == $c3} { 2468 # Pair 2469 return [expr {1*16**7 + $c3*16**6 + $score}] 2470 } 2471 if {$c3 == $c4} { 2472 # Pair 2473 return [expr {1*16**7 + $c4*16**6 + $score}] 2474 } 2475 return $score 2476} 2477 2478proc poker::num2card {num} { 2479 # 0 <= num < 52 2480 2481 set pip [string map {10 T 11 J 12 Q 13 K 14 A} [expr {$num / 4 + 2}]] 2482 set suit [string map {0 C 1 D 2 H 3 S} [expr {$num % 4}]] 2483 return $pip$suit 2484} 2485 2486proc poker::card2num {card} { 2487 lassign [split $card ""] pip suit 2488 set pip [string map {T 10 J 11 Q 12 K 13 A 14} $pip] 2489 set suit [string map {C 0 D 1 H 2 S 3} $suit] 2490 return [expr {($pip - 2) * 4 + $suit}] 2491} 2492 2493proc poker::add_groupchat_user_menu_item {m xlib jid} { 2494 set mm $m.gamesmenu 2495 if {![winfo exists $mm]} { 2496 menu $mm -tearoff 0 2497 $m add cascade -label [::msgcat::mc "Games"] -menu $mm 2498 } 2499 $mm add command -label [::msgcat::mc "Poker..."] \ 2500 -command [list [namespace current]::invite_dialog $xlib $jid] 2501} 2502 2503proc poker::iq_create {varname xlib from iqid xml} { 2504 upvar 2 $varname var 2505 2506 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 2507 2508 if {[::xmpp::xml::getAttr $attrs type] eq "poker:th:1"} { 2509 set modps {} 2510 foreach subel $subels { 2511 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 2512 2513 2514 if {[string equal $sxmlns http://jabber.org/protocol/feature-neg]} { 2515 lassign [::xmpp::data::findForm $ssubels] type form 2516 set fields [::xmpp::data::parseForm $form] 2517 2518 foreach {tag field} $fields { 2519 switch -- $tag { 2520 field { 2521 lassign $field var type label desc required options values media 2522 if {[string equal $var modp]} { 2523 foreach {olabel ovalue} $options { 2524 lappend modps $ovalue 2525 } 2526 } 2527 } 2528 } 2529 } 2530 } 2531 } 2532 2533 # TODO: Support of other MODP groups 2534 if {[lsearch -exact $modps 1] < 0} { 2535 set var [list error cancel not-acceptable] 2536 return 2537 } 2538 2539 if {[::xmpp::xml::isAttr $attrs deal]} { 2540 set deal [::xmpp::xml::getAttr $attrs deal] 2541 switch -- $deal { 2542 true - 2543 false { } 2544 1 { 2545 set deal true 2546 } 2547 0 { 2548 set deal false 2549 } 2550 default { 2551 set var [list error modify bad-request] 2552 } 2553 } 2554 } else { 2555 set deal true 2556 } 2557 # TODO: Support of other MODP groups 2558 set var [invited_dialog $xlib $from $iqid \ 2559 [::xmpp::xml::getAttr $attrs id] \ 2560 $deal 1] 2561 } 2562 return 2563} 2564 2565proc poker::iq_turn {varname xlib from xml} { 2566 upvar 2 $varname var 2567 2568 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 2569 2570 if {[::xmpp::xml::getAttr $attrs type] == "poker:th:1"} { 2571 set gid [make_gid $from [::xmpp::xml::getAttr $attrs id]] 2572 if {[exists $gid]} { 2573 set var [turn_recv $gid $tag $subels] 2574 } else { 2575 set var [list error cancel item-not-found] 2576 } 2577 } 2578 return 2579} 2580 2581 2582# Common games:cards part 2583proc iq_games_cards_create {xlib from xml args} { 2584 set res [list error cancel feature-not-implemented] 2585 set iqid [::xmpp::xml::getAttr $args -id] 2586 hook::run games_cards_create_hook res $xlib $from $iqid $xml 2587 return $res 2588} 2589 2590proc iq_games_cards_turn {xlib from xml args} { 2591 set res [list error cancel feature-not-implemented] 2592 hook::run games_cards_turn_hook res $xlib $from $xml 2593 return $res 2594} 2595 2596# vim:ts=8:sw=4:sts=4:et 2597