Роман Осипов

Шахматы в Mathematica

БЛОГ переехал на новый адрес: https://blog.wolframmathematica.ru/

Введение

Не так давно, на новогодние праздники, мне наконец-то удалось выехать из города в гости к моему другу, Чупрыгину Всеволоду, который является техническим администратором сайта Русскоязычной поддержки Wolfram Mathematica.
Вечерами мы играли в одну из самых лучших игр, в шахматы. Думаю, что те кто не очень знакомы с этой замечательной игрой, могут подробнее узнать о ней из Википедии или, что лучше, на сайте Wolfram MathWorld.
На фото ниже доска на некотором ходу нашей партии...
У шахмат множество достоинств, среди них можно отметить следующие:
  • по сути, если вы играете в шахматы, то почти наверное можете быть уверены, что никто до вас такую партию не играл, так как ориентировочное число возможных шахматных партий из 40 ходов (средняя длительность партии содержит их именно столько) оценивается примерно в 10^43 (число Шеннона), к слову сказать, звезд в видимой нам части Вселенной "всего" порядка 10^23, в то время как всех возможных шахматных партий может быть порядка 10^10^50, а это число уже вообразить совершенно невозможно...
  • шахматы отлично развивают логику, мышление, стратегию, это ни для кого не секрет...
  • наконец, шахматы — это просто очень интересно, азартно и захватывающе.
В процессе игры нам пришла в голову мысль, что хорошо бы написать по посту о том, как запрограммировать игру в шахматы в Mathematica — моя задача — и, скажем, на JavaScript (или jQuery, Java) — задача Всеволода, который будет опубликован в его блоге.
Безусловно, в связи с появлением компьютеров появилось множество всевозможных "электронных" шахмат (и интересное направление, компьютерные шахматы), однако, найти действительно стоящей их реализации в Mathematica мне не удалось, хотя на сайте Wolfram Demonstrations Project есть достаточно много интересных визуализаций решений всевозможных шахматных задач (скажем, о том, как пройти конем все поля шахматной доски, побывав в каждом один раз, или задача о ферзях), также есть и весьма специфичный манипулятор для игры в шахматы или игры в шахматы на кубе.
В этом посте передо мной не стоит, безусловно, задачи создать программу навроде Deep Fritz, которая обыграла в 2006 г. Владимира Крамника.
Задача скромнее: создать удобную шахматную доску на языке Wolfram, т.е., по сути, в системе Wolfram Mathematica, продемонстрировав дополнительно ее возможности в области создания в том числе сложных интерактивных приложений.
Среди того, что эта программа должна уметь и чем обладать, играя с другом, я понял следующее:
  • программа должна иметь красивый и удобный интерфейс (возможно во мне говорит перфекционист — очень люблю красивые удобные интерфейсы, поэтому считаю это важным, и здесь Mathematica позволяет реализовать это на все 100%, впрочем как и остальные пункты...);
  • в ней должна быть возможность осуществления подсказки для игрока(ов), которую, безусловно, можно отключить;
  • должны иметься часы, которые не особенно отвлекали бы от игры;
  • должна записываться история ходов;
  • должна быть возможность начинать партию не из стандартного положения, а после произвольного количества случайных ходов, что создает дополнительную сложность и интерес;
  • наконец, программа должна легко встраиваться и работать в браузере или в CDF Player с помощью технологии CDF (Computable Document Format - Формат Вычисляемых Документов) (т. е. без Mathematica для тех, у кого ее нет).

Отображение шахматной доски и фигур

Для начала, создадим шахматную доску и функцию, которая позволила бы отобразить заданную фигу в нужной позиции.
Для того, чтобы было проще читать код, стоит помнить, что по-английски:
rook — ладья; knight — лощадь; bishop — слон;
queen — ферзь; king — король; pawn — пешка.
Для начала, создадим шахматную доску и функцию, которая позволила бы отобразить заданную фигу в нужной позиции.
In[1]:=

(*разбиение картинки на части соответствующие фигурам, 580-размер будущей шахматной доски*)
chessFigures=
    ImageResize[#,580/8]&/@#&/@
        ImagePartition[
            chessFiguresAll,ImageDimensions[chessFiguresAll][[2]]/2
        ]
In[2]:=

(*функция для отображения фигуры на доске с возможностью подсветки, если это необходимо*)
chessFigureShow[figure_,color_,{i_,j_},background_:Transparent]:=
    Inset[        
        chessFigures[            
            [            
            If[color===White,1,2],            
            figure
            /.
            {rook->1,knight->2,bishop->3,queen->4,king->5,pawn->6}
            ]
        ],
        {i,j}-{12,12},
        Scaled[{12,12}],
        1,
        Background->background
    ]
In[3]:=

(*интерактивная шахматная доска с одной фигурой*)
Manipulate[
    (*доска*),    
    Deploy@
        ArrayPlot[
            (*цветаполейдоски*),            
            Table[If[OddQ[i+j],Gray,0],{i,1,8},{j,1,8}]
            ,
            Mesh->All
            ,
            MeshStyle->Black
            ,
            (*демонстрацияфигуры*)
            Epilog->{chessFigureShow[figure,color,{i,j}]}
            ,
            Ticks->
                {                    
                    MapThread[                        
                        {#1-12,#2,{0,0}}&,
                        {Range[1,8],CharacterRange["a","h"]}
                    ],
                    {#-12,#,0}&/@Range[1,8]
                }
            ,
            TicksStyle->
                Directive[Bold,FontFamily->"Myriad Pro Cond",25,Gray]
            ,
            Axes->True
            ,
            PlotRangePadding->0
            ,
            AxesStyle->Black
            ,
            ImageSize->580
        ],
    {{i,3,"Позиция по горизонтали:"},1,8,1,Appearance->"Labeled"},
    {{j,6,"Позиция по вертикали:"},1,8,1,Appearance->"Labeled"},
    {        
        {figure,queen,"Фигура:"},
        {            
            pawn->"Пешка",
            knight->"Конь",
            bishop->"Слон",
            rook->"Ладья",
            queen->"Ферзь",
            king->"Король"
        },
        SetterBar
    },
    {{color,White,"Цвет:"},{White->"Белые",Black->"Черные"}},
    AppearanceElements->None,
    Paneled->False,
    SaveDefinitions->True
]
//
Panel

Логика ходов шахматных фигур

После того, как мы создали первичную систему отображения шахматной доски и фигур на ней, можем заняться логикой перемещений шахматных фигур.
Всегда есть несколько вещей, которые нужно учитывать:
  • где в данный момент находится данная фигура,
  • что это за фигура,
  • каковы положения всех фигур одинакового цвета с выбранной,
  • каковы положения всех фигур противоположного цвета.
Аргументы у функций, представленных ниже имеют следующий смысл:
{i, j} — где в данный момент находится данная фигура,
головная часть функции — тип фигуры,
ownPositions — положения всех фигур одинакового цвета с выбранной,
enemyPositions — положения всех фигур противоположного цвета,
color — цвет выбранной фигуры (по сути нужен только для pawn (пешки), т. к. белые и черные пешки ходят принципиально по-разному (хотя и зеркально), а другие фигуры ходят по правилам, не зависящим от цвета, поэтому у всех функций кроме pawn этот аргумент имеет, для единообразия, опциональное значение, которое, по сути, не используется).
На выходе каждая функция дает список из двух списков:
  • первый — те позиции, на которые может перейти фигура на доске, с учетом расстановки всех имеющихся на доске фигур (тихий ход);
  • второй — список позиций, где стоят фигуры противника, которые можно атаковать.

Король (King)

Король может пойти на одну клетку в любую сторону, но не может пойти на ту клетку, которая находится под боем (т. е. там, где его сможет взять противник). С точки зрения программирования, король, пожалуй, самая простая фигура.
In[4]:=
king[{i_,j_},ownPositions_,enemyPositions_,color_:White]:=
    Module[{possiblePositions},        
        possiblePositions=
            Select[                
                ({i,j}+#)&/@
                    {                        
                        {-1,-1},
                        {-1,0},
                        {-1,1},
                        {0,-1},
                        {0,1},
                        {1,-1},
                        {1,0},
                        {1,1}
                    },
                ((1<=#[[1]]<=8)&&(1<=#[[2]]<=8))&
            ];        
        {            
            Complement[
                possiblePositions,Join[ownPositions,enemyPositions]
            ],
            Intersection[possiblePositions,enemyPositions]
        }
    ]

Вспомогательная функция, необходимая для функций queen, bishop, rook

Так как функции queen, bishop, rook, задающие логику возможных ходов для ферзя, слона и ладьи, соответственно, в целом весьма похожи, то можно создать некую общую функцию, которая искала бы на сколько клеток в заданном направлении direction может продвинуться данная фигура из начального состояния initial, если расстановка своих фигур на доске имеет вид ownPositions, а фигур противника — enemyPositions. Эта функция будет применяться к возможным направлениям для каждой из этих фигур.
In[5]:=
steps[initial_,direction_,ownPositions_,enemyPositions_]:=
    Module[        
        {steps,stepNew,atack,allPositions}
        ,
        (*все позиции на доске*)        
        allPositions=Join[ownPositions,enemyPositions]
        ;
        (*список, который будет содержать возможные позиции*)
        steps={}
        ;
        (*первый шаг в заданном направлении*)
        stepNew=initial+direction
        ;
        While[            
            (*если в клетке куда идем нет фигуры и она находится в пределах доски,
            то добавляем ее в список, иначе - останавливаемся*)            
            FreeQ[allPositions,stepNew]&&(And@@Thread[1<=stepNew<=8]),
            AppendTo[steps,stepNew];stepNew=stepNew+direction
        ]
        ;        
        (*список, состоящий из двух списков — списка позиций
        куда можно перейти в данном направлении и списка,
        содержащего конечную позицию, если она заканчивается фигурой врага,
        т. е. если ее можно атаковать*)
        {steps,If[FreeQ[enemyPositions,stepNew],{},{stepNew}]}
    ]

Ферзь (Queen)

Ферзь может пойти на произвольное число клеток по любой диагонали, вертикали или горизонтали, исходящим из точки, где он находится.
In[6]:=
queen[{i_,j_},ownPositions_,enemyPositions_,color_:White]:=
    Module[{possiblePositions,p},        
        possiblePositions=
            steps[{i,j},#,ownPositions,enemyPositions]&/@
                {                    
                    {-1,-1},
                    {-1,0},
                    {-1,1},
                    {0,-1},
                    {0,1},
                    {1,-1},
                    {1,0},
                    {1,1}
                };
        Flatten[#,1]&/@
            Transpose[Complement[possiblePositions,ownPositions]]
    ]

Ладья (Rook)

Ладья может пойти на произвольное число клеток по вертикали или горизонтали, исходящим из точки, где она находится.
In[7]:=
rook[{i_,j_},ownPositions_,enemyPositions_,color_:White]:=
    Module[{possiblePositions,p},        
        possiblePositions=
            steps[{i,j},#,ownPositions,enemyPositions]&/@
                {{1,0},{-1,0},{0,1},{0,-1}};
        Flatten[#,1]&/@
            Transpose[Complement[possiblePositions,ownPositions]]
    ]

Слон (Bishop)

Слон может пойти на произвольное число клеток по любой диагонали, исходящей из точки, где он находится.
In[8]:=
bishop[{i_,j_},ownPositions_,enemyPositions_,color_:White]:=
    Module[{possiblePositions,p},        
        possiblePositions=
            steps[{i,j},#,ownPositions,enemyPositions]&/@
                {{-1,-1},{-1,1},{1,-1},{1,1}};
        Flatten[#,1]&/@
            Transpose[Complement[possiblePositions,ownPositions]]
    ]

Конь (Knight)

Конь ходит специфически, он может пойти на две клетки в вертикальном и горизонтальном направлении и затем на еще одну в направлении, перпендикулярном выбранному, говоря проще, буквой Г или L.
С точки зрения программирования, конь мало чем отличается в своих возможных ходах от короля — он просто смещается в иных направлениях.
In[9]:=
knight[{i_,j_},ownPositions_,enemyPositions_,color_:White]:=
    Module[{possiblePositions},        
        possiblePositions=
            Select[                
                ({i,j}+#)&/@
                    {                        
                        {-1,2},
                        {1,2},
                        {-2,1},
                        {2,1},
                        {-1,-2},
                        {1,-2},
                        {-2,-1},
                        {2,-1}
                    },
                ((1<=#[[1]]<=8)&&(1<=#[[2]]<=8))&
            ];        
        {            
            Complement[
                possiblePositions,Join[ownPositions,enemyPositions]
            ],
            Intersection[possiblePositions,enemyPositions]
        }
    ]

Пешка (Pawn)

Пешка, как и конь, ходит специфически, если это ее первый шаг она может пойти на одну или две клетки вверх (для белых) или вниз (для черных), после она ходит на одну клетку вперед в том же направлении. Если на одну клетку вверх (вниз) по диагонали (в том же направлении, в котором идет пешка) стоит фигура противоположного цвета, то пешка может ее взять.
Пешка, пожалуй, самая интересная фигура с точки зрения программирования ее ходов, так как ее поведение сложнее чем у других фигур. Это несколько символично — проще всех ходит самая важная фигура — король, сложнее всех самая "простая" — пешка.
Направление ее движения зависит от ее цвета, в начале она может ходить двумя различными способами, а также у нее появляется возможность бить позиции слева и справа от себя по диагонали, если там стоит фигура противника.
In[10]:=
pawn[{i_,j_},ownPositions_,enemyPositions_,color_]:=
    Module[{possiblePositions},        
        If[            
            color===White
            ,
            (*ходыбелойпешки*)
            possiblePositions=
                If[j==2,{{i,j}+{0,1},{i,j}+{0,2}},{{i,j}+{0,1}}]
            ,
            (*ходычернойпешки*)
            possiblePositions=
                If[j==7,{{i,j}+{0,-1},{i,j}+{0,-2}},{{i,j}+{0,-1}}]
        ];
        Cases[#,{x_,y_}/;(1<=x<=8&&1<=y<=8)]&/@
            {                
                Complement[                    
                    possiblePositions,
                    Join[ownPositions,enemyPositions]
                ],
                Intersection[                                        
                    possiblePositions
                    ~
                    Join
                    ~
                    If[
                        color===White,
                        {{i,j}+{-1,1},{i,j}+{1,1}},
                        (* else *)
                        {{i,j}+{-1,-1},{i,j}+{1,-1}}
                    ],
                    enemyPositions
                ]
            }
    ]

Отображение шахматной фигуры на доске c её возможными ходами

После того, как мы задали логику поведения шахматных фигур, создадим доску, на которой мы могли бы посмотреть на их поведение.
In[11]:=

(*
вспомогательная функция
приводящая координаты
которые дают функции переходов фигур в формат созданной шахматной доски
*)
toChessBoard=((Reverse[#]{-1,1}+{9,0})&/@#)&;
In[12]:=

Manipulate[        
    stepsForFigure=
        toChessBoard/@
            figure[                
                {i,j},
                (color/.{White->own,Black->enemy}),
                (color/.{White->enemy,Black->own}),
                color
            ];
    Deploy@
        ArrayPlot[            
            ReplacePart[                
                Table[If[OddQ[i+j],Gray,0],{i,1,8},{j,1,8}],                
                Thread[stepsForFigure[[1]]->Lighter@Orange]
                ~
                Join
                ~
                Thread[stepsForFigure[[2]]->Lighter@Red]
            ],
            Mesh->All,
            MeshStyle->Black,
            Epilog->
                {                    
                    chessFigureShow[figure,color,{i,j}],
                    chessFigureShow[pawn,color,#]&/@
                        (color/.{White->own,Black->enemy}),                    
                    chessFigureShow[
                        pawn,color/.{White->Black,Black->White},#
                    ]&/@
                        (color/.{White->enemy,Black->own})
                },
            Ticks->
                {                    
                    MapThread[                        
                        {#1-1/2,#2,{0,0}}&,
                        {Range[1,8],CharacterRange["a","h"]}
                    ],
                    {#-1/2,#,0}&/@Range[1,8]
                },
            TicksStyle->
                Directive[Bold,FontFamily->"Myriad Pro Cond",25,Gray],
            Axes->True,
            PlotRangePadding->0,
            AxesStyle->Black,
            ImageSize->580
        ],
    {{i,3,"Позиция по горизонтали:"},1,8,1,Appearance->"Labeled"},
    {{j,6,"Позиция по вертикали:"},1,8,1,Appearance->"Labeled"},
    {        
        {figure,queen,"Фигура:"},
        {            
            pawn->"Пешка",
            knight->"Конь",
            bishop->"Слон",
            rook->"Ладья",
            queen->"Ферзь",
            king->"Король"
        },
        SetterBar
    },
    {{color,White,"Цвет:"},{White->"Белые",Black->"Черные"}},
    Button[        
        "Новая случайная расстановка пешек",        
        own=RandomInteger[{1,8},{8,2}];
        enemy=
            DeleteCases[RandomInteger[{1,8},{8,2}],Alternatives@@own];,
        Method->"Queued",
        ImageSize->{380,Automatic}
    ],
    Initialization:>
        {            
            own=(SeedRandom[6];RandomInteger[{1,8},{8,2}]);
            enemy=
                (                    
                    SeedRandom[2];
                    DeleteCases[
                        RandomInteger[{1,8},{8,2}],Alternatives@@own
                    ]
                );
        },
    AppearanceElements->None,
    Paneled->False,
    SaveDefinitions->True
]
//
Panel

Часы

Когда играешь в шахматы, иногда интересно следить за тем, сколько времени тратится на ход каждым из игроков, или ограничивать возможное время размышлений над ходом.
Для этих целей служат специальные шахматные часы. На картинке ниже представлены весьма распространенные в СССР часы марки "Янтарь". Нажимая на кнопку сверху игрок сигнализирует о том, что он закончил ход и после этого уже идут часы соперника.
Для нашей шахматной программы создадим упрощенные часы, чтобы они не загромождали много места, причем переключаться они будут автоматически, но прописано это будет уже в коде готового манипулятора-программы.
In[13]:=
chessClock[{timeWhite_,timeBlack_},l_:0.05,showLabel_:False]:=
    Module[{totalTime,tifeFraction},        
        totalTime=timeWhite+timeBlack;
        If[totalTime==0,tifeFraction=1,tifeFraction=timeWhitetotalTime];        
        If[
            showLabel,
            Labeled[                
                #,
                Style[                    
                    "Время, затраченное игроками, с",
                    16,
                    Bold,
                    Gray,
                    FontFamily->"Myriad Pro Cond"
                ]
            ],
            (* else *)
            Identity[#]
        ]&@
            Graphics[                
                {                    
                    White,
                    EdgeForm[{Thick,Black}],
                    Rectangle[{0,-110},{0.5-l,110}],
                    Rectangle[{0.5-l,-110},{0.5-l+2ltifeFraction,110}],
                    Gray,
                    Rectangle[{0.5-l+2ltifeFraction,-110},{0.5+l,110}],
                    Rectangle[{0.5+l,-110},{1,110}],
                    Black,
                    Text[                        
                        Style[                            
                            timeWhite,
                            20,
                            Bold,
                            FontFamily->"Myriad Pro Cond"
                        ],
                        {0.5-l2,0}
                    ],
                    Text[                        
                        Style[                            
                            timeBlack,
                            20,
                            Bold,
                            White,
                            FontFamily->"Myriad Pro Cond"
                        ],
                        {0.5+l+12,0}
                    ]
                },
                ImageSize->580,
                AspectRatio->120,
                PlotRangePadding->0
            ]
    ]
In[14]:=
Manipulate[    
    chessClock[{timeWhite,timeBlack},l,showLabel],
    {{timeWhite,10,"Время, потраченное белыми:"},1,50,1},
    {{timeBlack,3,"Время, потраченное черными:"},1,50,1},
    {{l,0.05,"Размер центрального отрезка шкалы:"},0.01,0.2},
    {{showLabel,False,"Показывать подпись?"},{True,False}},
    SaveDefinitions->True,
    ContentSize->{Automatic,80}
]

Детектор шаха и подозрения на ма

В игре в шахматы партия прекращается по достижению состояния, которое называется матом (т. е. когда король находится под ударом и ничто не может помешать устранить это состояние) или же состояния, называемого ничьей. Также есть промежуточное состояние, шах, т. е. когда король находится под ударом противника.
Для того, чтобы знать те моменты в игре, когда королю объявлен шах или подозрение на мат, создадим функцию checkMateDetection, которая на выходе выдает список из двух значений (True или False), первое значение говорит о том, объявлен ли шах королю, второе — подозрение на мат.
In[15]:=
checkMateDetection[kingPosition_,ownPositions_,enemyPositions_]:=
    Module[{kingPossibleSteps,enemyAllPositions,enemyAtackPositions},        
        kingPossibleSteps=
            king[                
                kingPosition,
                ownPositions[[;;,3]],
                enemyPositions[[;;,3]]
            ];
        enemyAtackPositions=
            DeleteDuplicates[
                Flatten[                    
                    (                        
                        #[[1]][                            
                            #[[3]],
                            enemyPositions[[;;,3]],
                            ownPositions[[;;,3]],
                            #[[2]]
                        ]&/@
                            Pick[                                
                                enemyPositions[[;;,1;;3]],
                                enemyPositions[[;;,4]],
                                True
                            ]
                    ),
                    2
                ]
            ];        
        {            
            Complement[{kingPosition},enemyAtackPositions]=={},            
            Complement[                
                Flatten[kingPossibleSteps,1]~Join~{kingPosition},
                enemyAtackPositions
            ]
            ==
            {}
        }
    ]

Генератор случайного начального расположения шахматных фигур на доске

В процессе игры с моим другом стало ясно, что было бы интересно также иметь возможность начинать игру не обязательно со стандартного расположения фигур (см. ниже), но и с произвольного.
Для того, чтобы задать некоторое произвольное состояние мы поступим следующим способом:
  • программа будет выбирать случайным образом фигуру на доске среди имеющихся, а также среди тех, которые могут пойти или атаковать;
  • после этого выбранная фигура пойдет случайным образом на некоторую новую позицию из тех, которые для нее доступны, возможно, атакуя при этом соперника;
  • затем право хода перейдет к другой стороне и все повторится некоторое наперед заданное количество раз.
Для того, чтобы реализовать этот процесс, нам потребуется создать несколько функций:
  • findPossibleFigure — поиск фигуры, которая может ходить (т. е. той, которая есть на доске в данный момент и у которой есть хотя бы одна возможная, отличная от занимаемой, новая позиция);
  • randomStep — один случайный шаг для выбранной случайной фигуры;
  • randomChessGame — функция, которая осуществляет несколько случайных ходов подряд с помощью предыдущих двух функций.
In[16]:=
findPossibleFigure[whoMoves_,white_,black_]:=
    If[        
        whoMoves===White
        ,
        (*возможная случайная фигура для белых*)
        {#[[1]],RandomChoice[Flatten[#[[2]],1]]}&@
            RandomChoice[
                DeleteCases[                    
                    (                        
                        {                            
                            #,
                            #[[1]][                                
                                #[[3]],
                                white[[;;,3]],
                                black[[;;,3]],
                                #[[2]]
                            ]
                        }&/@
                            Pick[white[[;;,1;;3]],white[[;;,4]],True]
                    ),
                    {_,{{},{}}}
                ]
            ]
        ,
        (*возможная случайная фигура для черных*)
        {#[[1]],RandomChoice[Flatten[#[[2]],1]]}&@
            RandomChoice[
                DeleteCases[                    
                    (                        
                        {                            
                            #,
                            #[[1]][                                
                                #[[3]],
                                black[[;;,3]],
                                white[[;;,3]],
                                #[[2]]
                            ]
                        }&/@
                            Pick[black[[;;,1;;3]],black[[;;,4]],True]
                    ),
                    {_,{{},{}}}
                ]
            ]
    ]
In[17]:=
randomStep[whoMovesValue_]:=
    Module[        
        {randomFigure}
        ,
        (*случайный выбор фигуры*)        
        randomFigure=findPossibleFigure[whoMovesValue,white,black];
        If[            
            whoMovesValue===White
            ,
            (*случайный шаг для белых*)            
            If[
                MemberQ[black[[;;,3]],randomFigure[[2]]],                
                black[
                    [Position[black[[;;,3]],randomFigure[[2]]][[1]],4]
                ]=
                    False;
                getQ=True;,
                (* else *)
                Null
            ];
            AppendTo[                
                history,
                Row@
                    {                        
                        Length[history]+1,
                        " | ",
                        randomFigure[[1,1]]/.figureNamesShortForm,
                        ": ",
                        chessPositionNotation[randomFigure[[1,3]]],
                        If[getQ,":","-"],
                        chessPositionNotation[randomFigure[[2]]]
                    }
            ];
            getQ=False;            
            With[
            {
                pos=
                    Position[white,{Sequence@@randomFigure[[1]],_}][
                        [1,1]
                    ]
            },
                white[[pos,3]]=randomFigure[[2]]
            ];
            whoMoves=Black;
            ,
            (*случайный шаг для черных*)            
            If[
                MemberQ[white[[;;,3]],randomFigure[[2]]],                
                white[
                    [Position[white[[;;,3]],randomFigure[[2]]][[1]],4]
                ]=
                    False;
                getQ=True;,
                (* else *)
                Null
            ];
            AppendTo[                
                history,
                Row@
                    {                        
                        Length[history]+1,
                        " | ",
                        randomFigure[[1,1]]/.figureNamesShortForm,
                        ": ",
                        chessPositionNotation[randomFigure[[1,3]]],
                        If[getQ,":","-"],
                        chessPositionNotation[randomFigure[[2]]]
                    }
            ];
            getQ=False;            
            With[
            {
                pos=
                    Position[black,{Sequence@@randomFigure[[1]],_}][
                        [1,1]
                    ]
            },
                black[[pos,3]]=randomFigure[[2]]
            ];
            whoMoves=White;
        ]
    ]
In[18]:=
randomChessGame[steps_,pause_]:=
    Module[{},        
        ReleaseHold[initialization];
        Table[randomStep[whoMoves];Pause[pause];,{steps}]
    ]

Функции, которые нужны для записи истории ходов

Для записи истории нам потребуются краткие обозначения фигур:
In[19]:=

figureNamesShortForm=
    {pawn->"п",knight->"К",bishop->"С",rook->"Л",queen->"Ф",king->"Кр"};
А для записи текущего положения фигуры потребуется функция, переводящая наши координаты на доске к их стандартному обозначению в шахматах (буква по горизонтали и цифра по вертикали):
In[20]:=
chessPositionNotation[{i_,j_}]:=
    StringJoin[
        {            
            i/.{1->"a",2->"b",3->"c",4->"d",5->"e",6->"f",7->"g",8->"h"},
            ToString[j]
        }
    ]

Готовый манипулятор для игры в шахматы

Суммируя все что сказано и сделано выше, создадим единый манипулятор для игры в шахматы:
In[21]:=

Manipulate[  
  Dynamic[    
    If[
      timeConstraint&&(currentTimeValue>timeMax),      
      whoMoves=(whoMoves/.{White->Black,Black->White});
      buttons={};
      Table[        
        colorWhite[j]=Transparent;colorBlack[j]=Transparent;,
        {j,1,16}
      ];
      AppendTo[gameTime,AbsoluteTime[]];
      gameTimes=Differences[gameTime];
      aT=AbsoluteTime[];,
      (* else *)
      Null
    ];
    Grid[      
      {        
        {
          chessClock[            
            {              
              Round[Total[gameTimes[[1;;;;2]]]],
              Quiet@
                Check[                  
                  Round[Total[gameTimes[[2;;;;2]]]],
                  0
                ]
            }
            +            
            (
              currentTimeValue=
                Refresh[                  
                  Round[AbsoluteTime[]-aT],
                  UpdateInterval->1
                ]
            )
            *
            If[whoMoves===White,{1,0},{0,1}]
          ]
        },
        {
          Row@
            Table[              
              Magnify[                
                chessFigureShow[
                  white[[i,1]],White,{0,0},True
                ][
                  [1]
                ],
                0.4
              ],
              {i,Pick[Range[16],white[[;;,4]],False]}
            ]
        },
        List@
          Deploy@
            ArrayPlot[              
              Table[
                If[OddQ[i+j],Gray,0],{i,1,8},{j,1,8}
              ],
              Mesh->All,
              MeshStyle->Black,
              Epilog->
                {                  
                  Table[                    
                    With[{j=i},
                      Button[                                                
                        chessFigureShow[                          
                          Sequence@@#,
                          colorWhite[j]
                        ]&@
                          white[[j,1;;3]],
                        If[
                          whoMoves===White,
                          If[                            
                            Mod[                              
                              counterWhite[
                                j
                              ],
                              2
                            ]
                            ==
                            1,                            
                            buttons=                              
                              (                                
                                (
                                  Inset[                                    
                                    Button[                                      
                                      Graphics[
                                        {                                          
                                          Dynamic@
                                            If[
                                              showPossibleStepsWhite,
                                              colorSelectedWhite,
                                              (* else *)
                                              Transparent
                                            ],
                                          Disk[
                                          ],
                                          White,
                                          Disk[                                            
                                            {                                              
                                              0,
                                              0
                                            },
                                            0.5
                                          ]
                                        }
                                      ],                                      
                                      If[
                                        MemberQ[                                          
                                          black[                                            
                                            [                                            
                                            ;;,
                                            3
                                            ]
                                          ],
                                          #
                                        ],                                        
                                        black[                                          
                                          [                                          
                                          Position[                                            
                                            black[                                              
                                              [                                              
                                              ;;,
                                              3
                                              ]
                                            ],
                                            #
                                          ][                                            
                                            [
                                            1
                                            ]
                                          ],
                                          4
                                          ]
                                        ]=
                                          False;
                                        getQ=
                                          True;,
                                        (* else *)
                                        Null
                                      ];
                                      AppendTo[                                        
                                        history,
                                        Row@
                                          {                                                                                        
                                            Length[
                                              history
                                            ]
                                            +
                                            1,
                                            " | ",                                            
                                            white[                                              
                                              [                                              
                                              j,
                                              1
                                              ]
                                            ]
                                            /.
                                            figureNamesShortForm,
                                            ": ",
                                            chessPositionNotation[
                                              white[                                                
                                                [                                                
                                                j,
                                                3
                                                ]
                                              ]
                                            ],
                                            If[
                                              getQ,
                                              ":",
                                              (* else *)
                                              "-"
                                            ],
                                            chessPositionNotation[
                                              #
                                            ]
                                          }
                                      ];
                                      getQ=
                                        False;
                                      white[                                        
                                        [                                        
                                        j,
                                        3
                                        ]
                                      ]=
                                        #;
                                      buttons=
                                        {
                                        };
                                      whoMoves=
                                        Black;
                                      colorWhite[
                                        j
                                      ]=
                                        Transparent;                                      
                                      counterWhite[
                                        j
                                      ]
                                      ++;
                                      AppendTo[                                        
                                        gameTime,
                                        AbsoluteTime[
                                        ]
                                      ];
                                      gameTimes=
                                        Differences[
                                          gameTime
                                        ];
                                      aT=
                                        AbsoluteTime[
                                        ];,
                                      Appearance->
                                        None,
                                      Method->
                                        "Queued"
                                    ],                                    
                                    #
                                    -
                                    {                                                                            
                                      1
                                      /
                                      2,                                      
                                      1
                                      /
                                      2
                                    },
                                    Scaled[
                                      {                                                                                
                                        1
                                        /
                                        2,                                        
                                        1
                                        /
                                        2
                                      }
                                    ],
                                    0.4
                                  ]
                                )&/@
                                  #
                              )&/@
                                (
                                  (
                                    white[                                      
                                      [                                      
                                      j,
                                      1
                                      ]
                                    ][                                      
                                      white[                                        
                                        [                                        
                                        j,
                                        3
                                        ]
                                      ],
                                      Pick[                                        
                                        white[                                          
                                          [                                          
                                          ;;,
                                          3
                                          ]
                                        ],
                                        white[                                          
                                          [                                          
                                          ;;,
                                          4
                                          ]
                                        ],
                                        True
                                      ],
                                      Pick[                                        
                                        black[                                          
                                          [                                          
                                          ;;,
                                          3
                                          ]
                                        ],
                                        black[                                          
                                          [                                          
                                          ;;,
                                          4
                                          ]
                                        ],
                                        True
                                      ],
                                      white[                                        
                                        [                                        
                                        j,
                                        2
                                        ]
                                      ]
                                    ]
                                  )
                                );
                            colorWhite[j]=
                              Opacity[                                
                                0.5,
                                Dynamic@
                                  colorSelectedWhite
                              ];
                            Table[                              
                              colorWhite[
                                n
                              ]=
                                Transparent,
                              {                                
                                n,
                                Delete[                                  
                                  Range[
                                    16
                                  ],
                                  j
                                ]
                              }
                            ];                            
                            counterWhite[
                              j
                            ]
                            ++;
                            Table[                              
                              If[                                
                                Mod[                                  
                                  counterWhite[
                                    n
                                  ],
                                  2
                                ]
                                ==
                                0,                                
                                --
                                counterWhite[
                                  n
                                ],
                                (* else *)
                                Null
                              ],
                              {                                
                                n,
                                Delete[                                  
                                  Range[
                                    16
                                  ],
                                  j
                                ]
                              }
                            ],
                            (* else *)                            
                            buttons={};
                            colorWhite[j]=
                              Transparent;                            
                            counterWhite[
                              j
                            ]
                            ++;
                          ],
                          (* else *)
                          Null
                        ],
                        Appearance->None,
                        Method->"Queued"
                      ]
                    ],
                    {                      
                      i,
                      Pick[                        
                        Range[16],
                        white[[;;,4]],
                        True
                      ]
                    }
                  ],
                  Table[                    
                    With[{j=i},
                      Button[                                                
                        chessFigureShow[                          
                          Sequence@@#,
                          colorBlack[j]
                        ]&@
                          black[[j,1;;3]],
                        If[
                          whoMoves===Black,
                          If[                            
                            Mod[                              
                              counterBlack[
                                j
                              ],
                              2
                            ]
                            ==
                            1,                            
                            buttons=                              
                              (                                
                                (
                                  Inset[                                    
                                    Button[                                      
                                      Graphics[
                                        {                                          
                                          Dynamic@
                                            If[
                                              showPossibleStepsBlack,
                                              colorSelectedBlack,
                                              (* else *)
                                              Transparent
                                            ],
                                          Disk[
                                          ],
                                          White,
                                          Disk[                                            
                                            {                                              
                                              0,
                                              0
                                            },
                                            0.5
                                          ]
                                        }
                                      ],                                      
                                      If[
                                        MemberQ[                                          
                                          white[                                            
                                            [                                            
                                            ;;,
                                            3
                                            ]
                                          ],
                                          #
                                        ],                                        
                                        white[                                          
                                          [                                          
                                          Position[                                            
                                            white[                                              
                                              [                                              
                                              ;;,
                                              3
                                              ]
                                            ],
                                            #
                                          ][                                            
                                            [
                                            1
                                            ]
                                          ],
                                          4
                                          ]
                                        ]=
                                          False;
                                        getQ=
                                          True;,
                                        (* else *)
                                        Null
                                      ];
                                      AppendTo[                                        
                                        history,
                                        Row@
                                          {                                                                                        
                                            Length[
                                              history
                                            ]
                                            +
                                            1,
                                            " | ",                                            
                                            black[                                              
                                              [                                              
                                              j,
                                              1
                                              ]
                                            ]
                                            /.
                                            figureNamesShortForm,
                                            ": ",
                                            chessPositionNotation[
                                              black[                                                
                                                [                                                
                                                j,
                                                3
                                                ]
                                              ]
                                            ],
                                            If[
                                              getQ,
                                              ":",
                                              (* else *)
                                              "-"
                                            ],
                                            chessPositionNotation[
                                              #
                                            ]
                                          }
                                      ];
                                      getQ=
                                        False;
                                      black[                                        
                                        [                                        
                                        j,
                                        3
                                        ]
                                      ]=
                                        #;
                                      buttons=
                                        {
                                        };
                                      whoMoves=
                                        White;
                                      colorBlack[
                                        j
                                      ]=
                                        Transparent;                                      
                                      counterBlack[
                                        j
                                      ]
                                      ++;
                                      AppendTo[                                        
                                        gameTime,
                                        AbsoluteTime[
                                        ]
                                      ];
                                      gameTimes=
                                        Differences[
                                          gameTime
                                        ];
                                      aT=
                                        AbsoluteTime[
                                        ];,
                                      Appearance->
                                        None,
                                      Method->
                                        "Queued"
                                    ],                                    
                                    #
                                    -
                                    {                                                                            
                                      1
                                      /
                                      2,                                      
                                      1
                                      /
                                      2
                                    },
                                    Scaled[
                                      {                                                                                
                                        1
                                        /
                                        2,                                        
                                        1
                                        /
                                        2
                                      }
                                    ],
                                    0.4
                                  ]
                                )&/@
                                  #
                              )&/@
                                (
                                  (
                                    black[                                      
                                      [                                      
                                      j,
                                      1
                                      ]
                                    ][                                      
                                      black[                                        
                                        [                                        
                                        j,
                                        3
                                        ]
                                      ],
                                      Pick[                                        
                                        black[                                          
                                          [                                          
                                          ;;,
                                          3
                                          ]
                                        ],
                                        black[                                          
                                          [                                          
                                          ;;,
                                          4
                                          ]
                                        ],
                                        True
                                      ],
                                      Pick[                                        
                                        white[                                          
                                          [                                          
                                          ;;,
                                          3
                                          ]
                                        ],
                                        white[                                          
                                          [                                          
                                          ;;,
                                          4
                                          ]
                                        ],
                                        True
                                      ],
                                      black[                                        
                                        [                                        
                                        j,
                                        2
                                        ]
                                      ]
                                    ]
                                  )
                                );
                            colorBlack[j]=
                              Opacity[                                
                                0.5,
                                Dynamic@
                                  colorSelectedBlack
                              ];
                            Table[                              
                              colorBlack[
                                n
                              ]=
                                Transparent,
                              {                                
                                n,
                                Delete[                                  
                                  Range[
                                    16
                                  ],
                                  j
                                ]
                              }
                            ];                            
                            counterBlack[
                              j
                            ]
                            ++;
                            Table[                              
                              If[                                
                                Mod[                                  
                                  counterBlack[
                                    n
                                  ],
                                  2
                                ]
                                ==
                                0,                                
                                --
                                counterBlack[
                                  n
                                ],
                                (* else *)
                                Null
                              ],
                              {                                
                                n,
                                Delete[                                  
                                  Range[
                                    16
                                  ],
                                  j
                                ]
                              }
                            ],
                            (* else *)                            
                            buttons={};
                            colorBlack[j]=
                              Transparent;                            
                            counterBlack[
                              j
                            ]
                            ++;
                          ],
                          (* else *)
                          Null
                        ],
                        Appearance->None,
                        Method->"Queued"
                      ]
                    ],
                    {                      
                      i,
                      Pick[                        
                        Range[16],
                        black[[;;,4]],
                        True
                      ]
                    }
                  ],
                  buttons
                },
              Ticks->
                {                  
                  MapThread[                    
                    {#1-1/2,#2,{0,0}}&,
                    {                      
                      Range[1,8],
                      CharacterRange["a","h"]
                    }
                  ],
                  {#-1/2,#,0}&/@Range[1,8]
                },
              TicksStyle->
                Directive[                  
                  Bold,
                  FontFamily->"Myriad Pro Cond",
                  25,
                  Gray
                ],
              Axes->True,
              PlotRangePadding->0,
              AxesStyle->Black,
              ImageSize->580
            ],
        {
          Row@
            Table[              
              Magnify[                
                chessFigureShow[
                  black[[i,1]],Black,{0,0},True
                ][
                  [1]
                ],
                0.4
              ],
              {i,Pick[Range[16],black[[;;,4]],False]}
            ]
        },
        {
          Pane[            
            Grid[              
              Partition[history,6,6,1,""],
              Alignment->{Center,Center}
            ],
            {580,80},
            Scrollbars->{False,True}
          ]
        }
      },
      ItemSize->{Automatic,{4,4,Automatic,4,5}},
      Alignment->{Center,Center}
    ]
  ],
  Item[
    Row@
      {        
        Button[          
          Dynamic@
            Style[              
              "Сейчас ходят",
              If[whoMoves===White,Black,White]
            ],
          Background->Dynamic@whoMoves,
          ImageSize->{120,30},
          Enabled->False
        ]        
        (*        
        ,
        Button["Белые",whoMoves=White,ImageSize->{60,30}]
        ,
        Button["Черные",whoMoves=Black,ImageSize->{60,30}]
        ,
        *)
        ,
        Button[          
          "Сброс партии",
          ReleaseHold[initialization];buttons={};,
          ImageSize->{120,30}
        ]
        ,
        "  "
        ,
        Dynamic@
          Row@
            Pick[              
              {                
                Style[                  
                  " Шах белым ",
                  20,
                  Bold,
                  colorSelectedBlack
                ],
                Style[                  
                  " Мат белым ",
                  20,
                  Bold,
                  colorSelectedBlack
                ]
              },
              checkMateDetection[                
                Cases[white,{king,___}][[1,3]],
                white,
                black
              ],
              True
            ]
        ,
        Dynamic@
          Row@
            Pick[              
              {                
                Style[                  
                  " Шах черным ",
                  20,
                  Bold,
                  colorSelectedWhite
                ],
                Style[                  
                  " Мат черным ",
                  20,
                  Bold,
                  colorSelectedWhite
                ]
              },
              checkMateDetection[                
                Cases[black,{king,___}][[1,3]],
                black,
                white
              ],
              True
            ]
      }
  ],
  Item[
    Row@
      {        
        Button[          
          Style["Случайное начало:"],
          randomChessGame[randomSteps,pause],
          ImageSize->{120,30},
          Method->"Queued"
        ],
        "   ",
        Control[
          {            
            {randomSteps,20,"Количество шагов:"},
            1,
            100,
            1,
            ImageSize->Small,
            AppearanceElements->None,
            Appearance->"Labeled"
          }
        ],
        "   ",
        Control[
          {            
            {pause,0.2,"Пауза:"},
            0,
            3,
            ImageSize->Small,
            AppearanceElements->None,
            Appearance->"Labeled"
          }
        ]
      }
  ],
  Item[
    Row[
      {        
        Control[
          {            
            {              
              timeConstraint,
              False,
              "Включить ограничение по времени?"
            },
            {True,False}
          }
        ],
        "  ",
        Control[
          {            
            {timeMax,560,"Количество времени (с):"},
            10,
            3060,
            1,
            Appearance->"Labeled",
            ImageSize->Small
          }
        ]
      }
    ]
  ],
  OpenerView[
    {      
      "Настройки",
      TableForm@
        {          
          "Показывать возможные ходы для:",
          Item[
            Row[
              {                
                Control[
                  {                    
                    {                      
                      showPossibleStepsWhite,
                      True,
                      "белых:"
                    },
                    {True,False}
                  }
                ],
                "  ",
                Control[
                  {                    
                    {                      
                      showPossibleStepsBlack,
                      True,
                      "черных:"
                    },
                    {True,False}
                  }
                ]
              }
            ]
          ],
          "Подсветка для:",
          Item[
            Row[
              {                
                Control[
                  {                    
                    {                      
                      colorSelectedWhite,
                      Darker@Red,
                      "белых:"
                    },
                    Darker@Red
                  }
                ],
                "  ",
                Control[
                  {                    
                    {                      
                      colorSelectedBlack,
                      Darker@Blue,
                      "черных:"
                    },
                    Darker@Blue
                  }
                ]
              }
            ]
          ]
        }
    }
  ],
  Initialization:>
    {      
      buttons={};
      timeConstraint=False;
      timeMax=5*60;
      initialization=
        Hold[          
          whiteOriginalPositions=
            {              
              {pawn,White,{1,2},True},
              {pawn,White,{2,2},True},
              {pawn,White,{3,2},True},
              {pawn,White,{4,2},True},
              {pawn,White,{5,2},True},
              {pawn,White,{6,2},True},
              {pawn,White,{7,2},True},
              {pawn,White,{8,2},True},
              {knight,White,{2,1},True},
              {knight,White,{7,1},True},
              {bishop,White,{3,1},True},
              {bishop,White,{6,1},True},
              {rook,White,{1,1},True},
              {rook,White,{8,1},True},
              {queen,White,{4,1},True},
              {king,White,{5,1},True}
            };
          white=whiteOriginalPositions;
          blackOriginalPositions=
            {              
              {pawn,Black,{1,7},True},
              {pawn,Black,{2,7},True},
              {pawn,Black,{3,7},True},
              {pawn,Black,{4,7},True},
              {pawn,Black,{5,7},True},
              {pawn,Black,{6,7},True},
              {pawn,Black,{7,7},True},
              {pawn,Black,{8,7},True},
              {knight,Black,{2,8},True},
              {knight,Black,{7,8},True},
              {bishop,Black,{3,8},True},
              {bishop,Black,{6,8},True},
              {rook,Black,{1,8},True},
              {rook,Black,{8,8},True},
              {queen,Black,{4,8},True},
              {king,Black,{5,8},True}
            };
          black=blackOriginalPositions;
          Table[            
            counterWhite[j]=1;colorWhite[j]=Transparent;,
            {j,1,16}
          ];
          Table[            
            counterBlack[j]=1;colorBlack[j]=Transparent;,
            {j,1,16}
          ];
          colorSelectedWhite=Darker@Red;
          colorSelectedBlack=Darker@Blue;
          whoMoves=White;
          history={};
          timeStart=AbsoluteTime[];
          gameTime={timeStart};
          gameTimes=Differences[gameTime];
          aT=AbsoluteTime[];
        ];
      ReleaseHold[initialization];
    },
  ControlPlacement->{Top,Top,Bottom},
  AppearanceElements->None,
  Paneled->False,
  SaveDefinitions->True
]
//
Panel
Список имен используемых встроенных функций и символов в порядке их появления в коде:
CompoundExpression (;), Set (=), Map (/@), Function (&), ImageResize, Slot (#), Times (*, *), Power (^), ImagePartition, Part ([[\[Ellipsis]]]), ImageDimensions, SetDelayed (:=), Pattern (:), Blank (_), List ({...}), Optional (:), Transparent, Inset, If, SameQ (===), White, ReplaceAll (/.), Rule (->, ->), Plus (+), Scaled, Background, Panel, Manipulate, Deploy, ArrayPlot, Table, OddQ, Gray, Mesh, All, MeshStyle, Black, Epilog, Ticks, MapThread, Range, CharacterRange, TicksStyle, Directive, Bold, FontFamily, Axes, True, PlotRangePadding, AxesStyle, ImageSize, Appearance, SetterBar, AppearanceElements, None, Paneled, False, SaveDefinitions, Module, Select, And (&&, \[And]), LessEqual (<=, <=), Complement, Join, Intersection (\[Intersection]), While, FreeQ, Apply (@@), Thread, AppendTo, Flatten, Transpose, Equal (==), Cases, Condition (/;), Reverse, ReplacePart, Lighter, Orange, Red, Button, RandomInteger, DeleteCases, Alternatives (|), Method, Automatic, RuleDelayed (:>, :>), Initialization, SeedRandom, Labeled, Style, Identity, Graphics, EdgeForm, Thick, Rectangle, Text, AspectRatio, ContentSize, Span (;;), DeleteDuplicates, Pick, RandomChoice, MemberQ, Position, Row, Length, With, Sequence, ReleaseHold, Pause, StringJoin (<>), ToString, $Failed, Dynamic, Greater (>), AbsoluteTime, Differences, Grid, Round, Total, Quiet, Check, Refresh, UpdateInterval, Magnify, Mod, Disk, Increment (++), Opacity, Delete, PreDecrement (--), Pane, Partition, Alignment, Center, Scrollbars, ItemSize, Item, Enabled, BlankNullSequence (___), Control, Small, OpenerView, TableForm, Darker, Blue, Hold, ControlPlacement, Top, Bottom
Вебинары о технологиях Wolfram | СКОРО
Каждую неделю мы будем проводить вебинар о применении технологий Wolfram.

Мы будем собираться с вами на удобной онлайн-площадке и обсуждать самые разные вопросы программирования на языке Wolfram Language. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.