Конференция "Игры" » Игра пятнашки
 
  • aka © (19.06.17 13:21) [0]
    В начале игры случайно расставили числа, а есть ли алгоритм проверки собираймый  вариант выпал или нет? Т.е. не собирать до варианты, где 15 стоит первее 14, а сразу по исходному массиву узнать на предмет собираймости?
  • Sha © (19.06.17 14:13) [1]
    Четность перестановки сохраняется при перемещении дырки по горизонтали
    и инвертируется при перемещении дырки по вертикали.

    Поэтому все собираемые перестановки должны иметь ту же четность,
    что у исходной перестановки (при условии, что дырка в том же ряду).
  • SergP © (19.06.17 14:55) [2]
  • aka © (19.06.17 15:42) [3]
    Ну вроде работает правильно, если я все правильно понял из видео. Проверка в процедуре ParityTest

    unit Main;

    interface

    uses
     Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
     Dialogs, ExtCtrls, StdCtrls, Menus;

    type
     TMainForm = class(TForm)
       MainPanel: TPanel;
       InfoLabel: TLabel;
       MainMenu: TMainMenu;
       MItemGame: TMenuItem;
       ChItemNew: TMenuItem;
       procedure FormCanResize(Sender: TObject; var NewWidth,
         NewHeight: Integer; var Resize: Boolean);
       procedure FormCreate(Sender: TObject);
       procedure ChItemNewClick(Sender: TObject);
     private
       { Private declarations }
     public
       BOARDSIZE: Integer;
       EmptyNo: Integer;
       Dg: array[1..15] of TPanel;
       procedure FillBoard;
       procedure Mixed;
       procedure ParityTest;
       procedure GameOver;
       procedure DgClick(Sender: TObject);
     end;

    var
     MainForm: TMainForm;
     
    implementation

    uses Math;

    {$R *.dfm}

    procedure TMainForm.FormCreate(Sender: TObject);
    begin
     BOARDSIZE := 320;
     EmptyNo := 16;
     FillBoard;
     Mixed;
     ParityTest;
     GameOver;
    end;

    procedure TMainForm.DgClick(Sender: TObject);
    var
     buf, tg: Integer;
    begin
     tg := TPanel(Sender).Tag;

     if (EmptyNo = tg + 1) and (tg mod 4 <> 0) then begin
       buf := EmptyNo;
       EmptyNo := TPanel(Sender).Tag;
       TPanel(Sender).Tag := buf;
       TPanel(Sender).Left := TPanel(Sender).Left + BOARDSIZE div 4;
     end
     else
     if (EmptyNo = tg - 1) and (tg mod 4 <> 1) then begin
       buf := EmptyNo;
       EmptyNo := TPanel(Sender).Tag;
       TPanel(Sender).Tag := buf;
       TPanel(Sender).Left := TPanel(Sender).Left - BOARDSIZE div 4;
     end
     else
     if EmptyNo = TPanel(Sender).Tag + 4 then begin
       buf := EmptyNo;
       EmptyNo := TPanel(Sender).Tag;
       TPanel(Sender).Tag := buf;
       TPanel(Sender).Top := TPanel(Sender).Top + BOARDSIZE div 4;
     end
     else
     if EmptyNo = TPanel(Sender).Tag - 4 then begin
       buf := EmptyNo;
       EmptyNo := TPanel(Sender).Tag;
       TPanel(Sender).Tag := buf;
       TPanel(Sender).Top := TPanel(Sender).Top - BOARDSIZE div 4;
     end;

     GameOver;
    end;

    procedure TMainForm.FillBoard;
    var
     i,L,T: Integer;
    begin
     for i := 1 to 15 do begin
       Dg[i] := TPanel.Create(MainPanel);
       Dg[i].Parent := MainPanel;
       L := ((i-1) mod 4) * (BOARDSIZE div 4);
       T := ((i-1) div 4) * (BOARDSIZE div 4);
       Dg[i].SetBounds(L,T,BOARDSIZE div 4, BOARDSIZE div 4);
       Dg[i].Caption := IntToStr(i);
       Dg[i].Tag := i;
       Dg[i].OnClick := DgClick;
     end;
    end;

    procedure TMainForm.Mixed;
    var
     i,j,n,R: Integer;
     B: array[1..15] of Boolean;
     fillflag: Boolean;
    begin
     Randomize;

     for i := 1 to 15 do
       B[i] := False;

     n := 1;  
     while True do begin
       R := Random(15) + 1;
       if not B[R] then begin
         B[R] := True;
         Dg[n].Caption := IntToStr(R);
         Inc(n);
       end;

       fillflag := True;
       for i := 1 to 15 do begin
         if B[i] = False then fillflag := False;
       end;

       if fillflag then Break;
     end;

    end;

    procedure TMainForm.FormCanResize(Sender: TObject; var NewWidth,
     NewHeight: Integer; var Resize: Boolean);
    begin
     MainPanel.Width := BOARDSIZE;
     MainPanel.Height := BOARDSIZE;
     MainPanel.Left := (MainForm.ClientWidth div 2) - (MainPanel.Width div 2);
     MainPanel.Top := (MainForm.ClientHeight div 2) - (MainPanel.Height div 2);
    end;

    procedure TMainForm.ParityTest;
    var
     parCounter,i,j: Integer;
    begin
     parCounter := 0;

     for i := 1 to 15 do begin
       for j := 1 to 15 do begin
         if (Dg[i].Tag > Dg[j].Tag) and (StrToInt(Dg[i].Caption) < StrToInt(Dg[j].Caption))
         then begin
           Inc(parCounter);
         end;
       end;
     end;

     if parCounter mod 2 = 0 then
       InfoLabel.Caption := 'Cобираймый вариант'
     else
       InfoLabel.Caption := 'Этот вариант вы не собирете';

    end;

    procedure TMainForm.GameOver;
    var
     i: Integer;
     flag: Boolean;
    begin
     flag := True;
     for i := 1 to 15 do begin
       if Dg[i].Tag <> StrToInt(Dg[i].Caption) then flag := False;
     end;

     if flag then ShowMessage('Game Over');
    end;

    procedure TMainForm.ChItemNewClick(Sender: TObject);
    var
     i: Integer;
    begin
     for i := 1 to 15 do
       Dg[i].Free;

     EmptyNo := 16;
     FillBoard;
     Mixed;
     ParityTest;
     GameOver;
    end;

    end.
  • xayam © (19.06.17 15:49) [4]
    delphi: 5-
    русский: 2-
    :)
  • aka © (19.06.17 16:05) [5]

    > xayam ©   (19.06.17 15:49) [4]

    Согласен, сложное слово нужно было заменить синонимом.
  • dmk © (19.06.17 18:08) [6]
    Что значит "этот вариант вы не соберете"?
    Насколько я помню, собираются все варианты. Она всегда решаема :)
  • SergP © (19.06.17 19:00) [7]

    > dmk ©   (19.06.17 18:08) [6]
    >
    > Что значит "этот вариант вы не соберете"?
    > Насколько я помню, собираются все варианты.


    Не все. Только половина...
  • SergP © (19.06.17 19:10) [8]

    > 'Cобираймый вариант'


    > 'Этот вариант вы не собирете'


    А ошибки лучше исправить, а то глаза режет...
  • Sha © (19.06.17 19:51) [9]
    Cобираймый -> собираемый
  • aka © (19.06.17 20:15) [10]

    > dmk ©   (19.06.17 18:08) [6]

    Видео со второго поста посмотрите, очень интересно
  • Sha © (19.06.17 20:57) [11]
    > aka ©   (19.06.17 20:15) [10]
    > Видео со второго поста посмотрите, очень интересно

    На самом деле в [1] доказательство проще, т.к.:
    1. в начальных условиях при правильном расположении имеем 0 транспозиций, при неправильном - 1
    2. в процессе игры любое движение дырки по вертикали меняет ровно 3 пары, и не надо рассматривать кучу вариантов
  • SergP © (20.06.17 14:25) [12]
    если дырка находится в крайнем правом углу вроде как вычислить разрешимость варианта можно и так (если конечно, я ничего не напутал):
    function check(a:array of integer):boolean;
    var
    i,m:integer;
    begin
    result:=true;
    for i:=0 to 14  do while a[i]<>i+1 do
      begin
        m:=a[a[i]-1];
        a[a[i]-1]:=a[i];
        a[i]:=m;
        result:=not result;
      end;
    end;


    В таком случае количество итераций этого "двойного" цикла не будет превышать 14
  • Sha © (20.06.17 16:25) [13]
    Вот это, наверно, должно работать (не проверял):
    function check(a: PIntegerArray): boolean;
    var
     i, j, k: integer;
    begin
     k:=0;
     for i:=0 to 13 do for j:=i+1 to 14 do k:=k xor (a[j]-a[i]);
     Result:=k>=0;
    end;
  • Slider007 © (21.06.17 11:02) [14]
    В Википедии есть ответ на поставленный в первом сообщении вопрос.
  • Sha © (21.06.17 12:13) [15]
    человечество решило эту и многие другие задачи
  • Rouse_ © (21.06.17 15:55) [16]

    > SergP ©   (19.06.17 14:55) [2]
    > https://www.youtube.com/watch?v=rQJMT9nbFhk&t=1905s

    Шикарно, нам в МИРЭА в свое время как-то через чур усложненно это давали, я с первого раза даже и не въехал, а тут парень достаточно легко все по полкам разложил. Вот это правильный преподаватель :)
 
Конференция "Игры" » Игра пятнашки
Есть новые Нет новых   [85496   +14][b:0.001][p:0.002]