Игра Реверси с рекурсией (FPC)

* Оптимизированный вариант реверси
* Отсутствуют тяжелые двумерные циклы
* Есть небольшая аналитика позиции
* Просмотр ходов "вперед" отсутствует
* Компьютер играет с компьютером в консоли

program reverse;

{ Copyright (C) Igor Salnikov }

const
    SX=8; SY=8;
type
    TPos = record
        x,y:integer;
    end;
    TCell = record
       fig: integer;
       mark: integer;
    end;
    TField = array[1..SX*SY] of TCell;
var
    FIELD: TField;

procedure invert(fig,n:integer); forward;

function n2pos(n:integer):TPos;
var p:TPos;
begin
    p.x:=(n-1) mod SX + 1;
    p.y:=(n-1) div SX + 1;
    n2pos:=p;
end;

function pos2n(x,y:integer):integer;
begin
    if (x<1) or (x>SX) or (y<1) or (y>SX) then
        pos2n:=-1
    else
        pos2n:=(y-1)*SX+x;
end;

function plus(n,dx,dy:integer):integer;
var p:TPos;
begin
    p:=n2pos(n); p.x:=p.x+dx; p.y:=p.y+dy;
    plus:=pos2n(p.x, p.y);
end;

procedure set_f(n:integer;fig,mark:integer;inv:boolean);
begin
    FIELD[n].fig:=fig; FIELD[n].mark:=mark;
    if inv then invert(fig,n);
end;

function get_f(n:integer):TCell;
begin
    get_f:=FIELD[n];
end;

function on_field(n:integer):boolean;
begin
    on_field:=(n>=1) and (n<=SX*SY);
end;

function walk_invert(fig,n,dx,dy:integer):boolean;
begin
    if not on_field(n) then
        walk_invert:=false
    else if get_f(n).fig=0 then
        walk_invert:=false
    else if get_f(n).fig=fig then
        walk_invert:=true
    else if walk_invert(fig,plus(n,dx,dy),dx,dy) then
    begin
        set_f(n, get_f(n).fig, 1, false);
        walk_invert:=true;
    end;
end;

procedure invert(fig,n:integer);
var p:integer;
begin
    walk_invert(fig,plus(n,-1,-1),-1,-1);
    walk_invert(fig,plus(n,-1,0),-1,0);
    walk_invert(fig,plus(n,-1,1),-1,1);
    walk_invert(fig,plus(n,0,-1),0,-1);
    walk_invert(fig,plus(n,0,1),0,1);
    walk_invert(fig,plus(n,1,-1),1,-1);
    walk_invert(fig,plus(n,1,0),1,0);
    walk_invert(fig,plus(n,1,1),1,1);
    for p:=1 to SX*SY do
        if get_f(p).mark=1 then
            set_f(p,fig,0,false);
end;

function figure(fig:integer):string;
begin
    figure:='.';
    if fig=1 then figure:='B'
        else if fig=-1 then figure:='r';
end;

procedure setup;
var n:integer;
begin
    for n:=1 to 64 do set_f(n,0,0,false);
    set_f(pos2n(4,4),1,0,false);
    set_f(pos2n(5,5),1,0,false);
    set_f(pos2n(4,5),-1,0,false);
    set_f(pos2n(5,4),-1,0,false);
end;

procedure print;
var n,b,r:integer;
begin
    b:=0; r:=0;
    for n:=1 to SX*SY do
        if get_f(n).fig=1 then inc(b)
            else if get_f(n).fig=-1 then inc(r);
    writeln('B=',b,', R=',r);
end;

procedure show();
var n:integer;
begin
    for n:=1 to SX*SY do
    begin
        write(figure(get_f(n).fig));
        if (n mod SX) = 0 then writeln;
    end;
    print;
    writeln;
end;

function walk(fig,n,dx,dy:integer):integer;
begin
    walk:=0;
    while true do
    begin
        if not on_field(n) then
        begin
            walk:=0; break;
        end;
        if get_f(n).fig=0 then
        begin
            walk:=0; break;
        end;
        if get_f(n).fig=fig then break;
        walk:=walk+1;
        n:=plus(n,dx,dy);
    end;
end;

function pos_power(fig,n:integer):integer;
begin
    pos_power:=
        walk(fig,plus(n,-1,-1),-1,-1)+
        walk(fig,plus(n,-1,0),-1,0)+
        walk(fig,plus(n,-1,1),-1,1)+
        walk(fig,plus(n,0,-1),0,-1)+
        walk(fig,plus(n,0,1),0,1)+
        walk(fig,plus(n,1,-1),1,-1)+
        walk(fig,plus(n,1,0),1,0)+
        walk(fig,plus(n,1,1),1,1);
end;

function has_pos(fig:integer):boolean;
var n:integer;
begin
    has_pos:=false;
    for n:=1 to SX*SY do
        if (get_f(n).fig=0) and (pos_power(fig,n)>0) then
        begin
            has_pos:=true; break;
        end;
end;

function field_power(n:integer):integer;
var p:TPos;
begin
    field_power:=1; p:=n2pos(n);
    if (p.x=1) or (p.x=SX) or (p.y=1) or (p.y=SY) then
        field_power:=2;
end;

function get_new_pos(fig: integer):integer;
var 
    p, fp, max_p, n: integer;
    max_save: array[1..SX*SY] of integer;
    max_count: integer;
begin
    max_p:=0;
    max_count:=0;
    for n:=1 to SX*SY do
        if get_f(n).fig=0 then
        begin
            p:=pos_power(fig,n);
            fp:=0; if (p>0) then fp:=field_power(n);
            if (p>0) and ((p+fp)>max_p) then
            begin
                max_p := p+fp;
                inc(max_count);
                max_save[max_count]:=n;
            end;
        end;
    for n:=1 to SX*SY do
        if get_f(n).fig=0 then
        begin
            p:=pos_power(fig,n);
            fp:=0; if (p>0) then fp:=field_power(n);
            if (p>0) and ((p+fp)=max_p) then
            begin
                inc(max_count);
                max_save[max_count]:=n;
            end;
        end;
    get_new_pos:=max_save[random(max_count)+1];
end;

procedure OnClick(n:integer);
var wait:boolean;
begin
    if pos_power(1,n)>0 then
    begin
        set_f(n,1,0,true);
        show;
        //Pause;
        //SetLock(true);
        //CopyField;
        wait:=false;
        while has_pos(-1) do
        begin
            n:=get_new_pos(-1);
            set_f(n,-1,0,true);
            if has_pos(1) then
            begin
                wait:=true;
                break;
            end;
            writeln('ONE MORE');
        end;
        //SetLock(false);
        //if not wait then TheEnd;
    end;
end;

procedure OnStart();
begin
    //ClearField;
    randomize;
    setup;
end;

var n:integer;
begin
    OnStart;
    show; n:=1;
    while has_pos(1) do
    begin
        writeln('CYCLE=',n);
        OnClick(get_new_pos(1));
        show; inc(n);
    end;
end.