Реверси на TCL в 64 строки

На хабре уже есть топики про написание игры Реверси (Отелло) на Python, Silverlight.
Изобретем велосипед на Tcl/Tk. Кроссплатформенно (работает даже на Windows Mobile при небольшой модификации), всего в 64 строки.



Код, небольшое описание и скрин с WinMobile под хабракатом.


Исходник (reversi.tcl):

package require Tk 8.5
for {set i 0} {$i<64} {incr i} {lappend icells [expr {$i/8}] [expr {$i%8}]}
array set vs [list 1 2 2 1 cl,1 black cl,2 white pn,1 черные pn,2 белые]
ttk::button .b1 -text "Новая игра" -command {newgame 1 2}
ttk::button .b2 -text "Выход" -command {exit}
ttk::label  .l1 -text "Добро пожаловать в игру Реверси"
canvas .cv -width 479 -height 479
grid rowconfigure . 1 -weight 1
grid columnconfigure . 2 -weight 1
grid .b1 .b2 .l1 -padx 4 -pady 4 -sticky e
grid .cv -padx 4 -pady 4 -columnspan 3
foreach {x y} $icells {
  set cr1 [list [expr {$x*60+2}] [expr {$y*60+2}] [expr {$x*60+60}] [expr {$y*60+60}]]
  set cr2 [list [expr {$x*60+4}] [expr {$y*60+4}] [expr {$x*60+58}] [expr {$y*60+58}]]
  .cv create rectangle $cr1 -fill gray -tag "cell,$x,$y"
  .cv create oval $cr2 -state hidden -tag "piece $x,$y"
  .cv bind cell,$x,$y <1> [list evuser $x $y]}
proc pieceset {x y p}  {
  .cv itemconfigure $x,$y -state normal -fill $::vs(cl,$p)
  incr ::score($p)        [expr {+($::board($x,$y) != $p)}]
  incr ::score($::vs($p)) [expr {-($::board($x,$y) == $::vs($p))}]
  set  ::board($x,$y)     [list $p]}
proc newgame {p1 p2} {
  .cv itemconfigure piece -state hidden
  array set ::score  [list 0 0 1 0 2 0]
  array set ::player [list 1 $p1 2 $p2]
  foreach {x y} $::icells {set ::board($x,$y) 0}
  foreach {x y s} {3 3 2 4 4 2 3 4 1 4 3 1} {pieceset $x $y $s}
  set ::cur 1; waitturn}
proc getflips {x y p} {
  if {$::board($x,$y) != 0} return;
  set result {}
  foreach {ix iy} {0 -1 0 1 -1 0 1 0 -1 -1 1 1 1 -1 -1 1} {
    set temp {}
    for {set i [expr {$x+$ix}]; set j [expr {$y+$iy}]} \
        {[info exists ::board($i,$j)]} {incr i $ix; incr j $iy} {
        switch -- $::board($i,$j) \
          $::vs($p) {lappend temp $i $j} \
          $p        {foreach {m n} $temp {lappend result $m $n}; break} \
          0         {break}
  }}
  return $result}
proc waitturn {} {
  .l1 configure -text "Ходят $::vs(pn,$::cur) ($::score(1):$::score(2))"
  array set v [list $::cur {} $::vs($::cur) {}]  
  foreach {x y} $::icells {
    set l [getflips $x $y $::cur]; if {[llength $l]} {lappend v($::cur) [list $x $y]}
    set l [getflips $x $y $::vs($::cur)]; if {[llength $l]} {lappend v($::vs($::cur)) [list $x $y]}}
  if {[llength $v($::cur)] == 0 && [llength $v($::vs($::cur))] == 0} {
    tk_messageBox -title "Reversi" -message "Игра окончена"; return}
  if {$::player($::cur) == 1 && [llength $v($::cur)]} {
    set ::waituser 1; return}
  if {$::player($::cur) == 2 && [llength $v($::cur)]} {
    set ::waituser 0
    set ::flip [lindex $v($::cur) [expr {int([llength $v($::cur)]*rand())}]]
    turn [lindex $::flip 0] [lindex $::flip 1] $::cur}
  set ::cur $::vs($::cur); after idle waitturn}
proc evuser {x y} {
  if {[info exists ::waituser] && $::waituser && [turn $x $y $::cur]} {
    set ::cur $::vs($::cur); after idle waitturn}}
proc turn {x y p} {
  set flips [getflips $x $y $p]
  foreach {i j} $flips  {pieceset $i $j $p}
  if {[llength $flips]} {pieceset $x $y $p; return 1} else {return 0}}

Чтобы удобней было работать с координатами, создадим список icells (0 0 0 1… 1 1 1 2..).
В дальнейшем вместо вложенного цикла можем пользоваться foreach {x y} $icells.

Далее идет создание интерфейса, работа с канвой и привязка события (evuser) при нажатии на клетку.

Глобальные переменные:
vs — хеш массив, определяет ID противников, цвета фишек. vs(1) = 2; vs(2) = 1.
score — счет (количество черных и белых фишек)
player — конфигурация игроков (1 — человек, 2 — компьютер)
board — игровое поле
cur — идентификатор текущего игрока
waituser — флаг ожидания хода пользователя

Рассмотрим объявленные функции.
newgame {p1 p2}
Начало новой игры. Аргументы определяют тип игрока:
1 — Человек
2 — Компьютер

В прочем, AI здесь совершенно нет, но можно посмотреть как будут играть Random vs Random передав {2 2}

pieceset {x y p}
Устанавливает фишку игрока p, в клетку x,y
Пересчитывает текущий счет. Здесь небольшая магия

incr ::score($p)        [expr {+($::board($x,$y) != $p)}]
incr ::score($::vs($p)) [expr {-($::board($x,$y) == $::vs($p))}].

Мы увеличиваем счет текущего игрока p, и его оппонента $vs($p)
Для текущего игрока, если его фишка еще не стояла в клетке, то +1 иначе +0
Если стоила фишка противника, то ему уменьшаем счет на -1.

getflips {x y p}
Возвращает список всех возможных фишек, который игрок (p) может захватить сходив в x y

waitturn {}
Ожидание хода.
Определяет количество всех возможных ходов для каждого игрока. Решает, когда игра окончена и кто сейчас должен сделать ход.

evuser {x y}
Процедура вызываемая каждый раз, когда человек нажимает на одну из клеток.
Если установлена глобальная переменная ::waituser и есть возможность сходить текущему пользователю, то передаем управление оппоненту:
set ::cur $::vs($::cur); after idle waitturn}}

turn {x y p}
Сделать ход в x y. Перевернуть захваченные фишки противника, если получилось — возвращает 1, иначе 0.

Ссылки:
Реверси на Википедии
ActiveTcl (дистрибутив Tcl для Windows/OSX/Linux)
eTcl (Windows Mobile)


Ну и напоследок, скрин с Windows Mobile


UPD:
Скриншот с Ubuntu. Правда, чтобы привести к нормальному виду, подключил модуль tile-gtk

Google Code
Старкит и сборка под Windows (1.2 мб)