Судоку-Жирандоль

[Armageddets]

Всем доброго времени суток, уважаемые эксперты. Передо мной стоит задача создать игру "Судоку-Жирандоль". Как и в обычном судоку здесь нужно расставить цифры так, чтобы в столбцах не было повторяющихся цифр и в строках тоже. Но данныая игра отличается тем, что на поле есть дополнительные 9 клеток (их координаты всегда одинаковы и они выделяются другим цветом) - там тоже не должно быть повторений.

В обычном судоку я просто по порядку расставляю все цифры в каждой строке, а потом перемешиваю строки, меняя их местами и столбцы. Получается случайное поле якобы. А как мне тут реализовать еще и проверки на эти 9 клеток. Если я добавлю проверки на дублирования и буду перезапускать заново создание - вылетать будут ошибки, так как программа может зациклится. Найти цифры в этих клетках не проблема, найти повторяющиеся там цифры тоже не проблема. Проблема в том как реализовать перестановку строк или столбцов между собой так, чтобы подставить нужные цифры в итоге, не затронув уже нормально расставленные в эти "желтые клетки" цифры...

Или может может существуют какие-то более подходящие алгоритмы? Посоветуйте как лучше всего это сделать или в какую сторону мне копать информацию. Заранее спасибо всем откликнувшимся.

[newerow1989]

Вот, готовый код - я им пользуюсь

unit Unit2;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Label1: TLabel;
    Button1: TButton;
    CheckBox1: TCheckBox;
    Label2: TLabel;
    Edit1: TEdit;
    UpDown1: TUpDown;
    Timer1: TTimer;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Button2: TButton;
    procedure CheckBox1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure RadioButton2Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const
  dl=3;
  dlina=dl*dl;

var
  Form1: TForm1;
  nomer,hod,pos_x,pos_y,x,y,kn,pusto,pusto_tek:integer;
     { nomer - выставляемая цифра
       hod - количество ходов/циклов
       pos_x, pos_y - выделение блоков
       x,y -  фиксирование строки или столбца
       kn - количество nomer в строке/столбце
       pusto - количество пустых клеток }
  status:string;
  vertical:boolean;
     { vertical - ориентация: перевернут ли массив по часовой стрелке на 90°? }
  p:array[0..dlina-1,0..dlina-1] of byte;
  pb:array[0..dlina-1,0..dlina-1] of boolean;
  pris:array[0..dlina-1,0..dlina-1] of byte;
  pnom:array[1..dlina] of boolean;

implementation

{$R *.dfm}
{ 4445псс5рв }

procedure rasst;
const dx=20;
      dy=25;
      dx9=14;
var i,j:integer;

   procedure xxyy(var xx,yy:integer);
   begin
      xx:=i;
      yy:=j;
      If vertical then
      begin
         xx:=dlina-1-j;
         yy:=i;
      end;
   end;

   function xx:integer;
   var yy:integer;
   begin
      xxyy(Result,yy);
   end;

   function yy:integer;
   var xx:integer;
   begin
      xxyy(xx,Result);
   end;

begin
   With Form1 do
   begin
      If not CheckBox1.Checked and (status<>'') then
         Exit;
      With Label1.Canvas do
         For i:=0 to dlina-1 do
            For j:=0 to dlina-1 do
            begin
               Case pris[xx,yy] of
               1: Pen.Color:=clYellow;
               2: Pen.Color:=clFuchsia;
               3: Pen.Color:=clLime;
               4: Pen.Color:=clAqua;
               else
                  Pen.Color:=Form1.Label1.Color;
               end;
               Brush.Color:=Pen.Color;
               Rectangle(i*dx,j*dy,(i+1)*dx-1,(j+1)*dy-1);
               TextOut(i*dx+3,j*dy,IntToStr(p[xx,yy]));
            end;
      Label6.Visible:=true;
      Label7.Visible:=true;
      Label7.Caption:=IntToStr(hod);
      Label11.Visible:=true;
      If status='' then
         Exit;
      Label4.Visible:=true;
      Label5.Visible:=true;
      If nomer>0 then
         Label5.Caption:=IntToStr(nomer);
      Label8.Visible:=true;
      Label9.Visible:=true;
      With Label9.Canvas do
         For i:=1 to dlina do
         begin
            TextOut((i-1)*dx9+3,0,IntToStr(i));
            If pnom[i] then
            begin
               Pen.Color:=clRed;
               Pen.Width:=2;
               MoveTo(i*dx9,0);
               LineTo((i-1)*dx9,Label9.Height-1);
            end;
         end;
      Label10.Visible:=true;
      Label11.Caption:=IntToStr(pusto_tek);
   end;
end;

function final:boolean;
var i,j,k,n:integer;
begin
   Result:=true;
   pusto_tek:=0;
   { Проверить, что все цифры расставлены по всем клеткам }
   For i:=0 to dlina-1 do
      For j:=0 to dlina-1 do
         If p[i,j]=0 then
         begin
            Result:=false;
            pusto_tek:=pusto_tek+1;
         end;
   { Сосчитать количество оставшихся цифр }
   For n:=1 to dlina do
   begin
      k:=0;
      For i:=0 to dlina-1 do
         For j:=0 to dlina-1 do
            If p[i,j]=n then
               k:=k+1;
      If k=dlina then
         pnom[n]:=true else
         pnom[n]:=false;
   end;
   If Result then
   begin
      Form1.Label4.Visible:=false;
      Form1.Label5.Visible:=false;
   end;
end;

function start:boolean;
var i,j:integer;
begin
   Result:=true;
   For j:=0 to dlina-1 do
      For i:=0 to dlina-1 do
      begin
         If Length(Form1.Memo1.Lines[j])<dlina then
         begin
            Result:=false;
            MessageBox(0,'Расставьте цифры!','Нет цифр!',0);
            Exit;
         end;
         p[i,j]:=StrToInt(Form1.Memo1.Lines[j][i+1]);
         pris[i,j]:=0;
      end;
end;

[newerow1989]

procedure TForm1.Timer1Timer(Sender: TObject);
label l0,l1,l2_1,l2_2,l3_1,l3_11,l3_2,l4_1,l4_2,l5_1,l5_2,l6,l1_ex,l21,l22_1,
      l22_2,l23_1,l23_11,l23_2,l24_1,l24_2,l25,l21_ex,lexit,lfinal;
var i,j,i1,j1:integer;

   function nomeri:byte;
   begin
      Result:=nomer+1;
      While (Result<=dlina) and pnom[Result] do
         Result:=Result+1;
      If Result>dlina then
         Result:=0;
   end;

   procedure Vertical90;
   label lv;
   var i,j:integer;
       pp:array[0..dlina-1,0..dlina-1] of byte;
   begin
      If vertical then
         goto lv;
      For i:=0 to dlina-1 do
         For j:=0 to dlina-1 do
            pp[i,j]:=p[j,dlina-1-i];
      For i:=0 to dlina-1 do
         For j:=0 to dlina-1 do
            p[i,j]:=pp[i,j];
      vertical:=true;
      Exit;
      lv:
      For i:=0 to dlina-1 do
         For j:=0 to dlina-1 do
            pp[i,j]:=p[dlina-1-j,i];
      For i:=0 to dlina-1 do
         For j:=0 to dlina-1 do
            p[i,j]:=pp[i,j];
      vertical:=false;
   end;

begin
   l0:
   If status='2_1' then
      goto l2_1;
   If status='2_2' then
      goto l2_2;
   If status='3_1' then
      goto l3_1;
   If status='3_2' then
      goto l3_2;
   If status='4_1' then
      goto l4_1;
   If status='4_2' then
      goto l4_2;
   If status='5_1' then
      goto l5_1;
   If status='5_2' then
      goto l5_2;
   If status='6' then
      goto l6;
   If status='22_1' then
      goto l22_1;
   If status='22_2' then
      goto l22_2;
   If status='23_1' then
      goto l23_1;
   If status='23_2' then
      goto l23_2;
   If status='24_1' then
      goto l24_1;
   If status='24_2' then
      goto l24_2;
   If status='25' then
      goto l25;
   hod:=hod+1;
   nomer:=0;
   vertical:=false;
   If final then
      goto lfinal;
   If pusto_tek<pusto then
      pusto:=pusto_tek else
      goto lfinal;
   l1:
   { Расчеты по горизонтали }
   pos_y:=-dl;
   nomer:=nomeri;
   If nomer=0 then
      goto l1_ex;
   l2_1:
   pos_y:=pos_y+dl;
   For i:=0 to dlina-1 do
      For j:=0 to dlina-1 do
         pb[i,j]:=true;
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
         pris[i,j]:=1;
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
         { Если nomer нашелся, то в блоке 3*3, строкe j его не ставим }
         If p[i,j]=nomer then
         begin
            pos_x:=(i div dl)*dl;
            For i1:=pos_x to pos_x+dl-1 do
               For j1:=pos_y to pos_y+dl-1 do
               begin
                  pb[i1,j1]:=false;
                  pris[i1,j1]:=4;
               end;
            For i1:=0 to dlina-1 do
            begin
               pb[i1,j]:=false;
               pris[i1,j]:=4;
            end;
            pris[i,j]:=2;
         end;
   status:='2_2';
   goto lexit;
   l2_2:
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
      begin
         If pb[i,j] and (p[i,j]<>0) then
            pris[i,j]:=0;
         If pb[i,j] and (p[i,j]=0) then
            p[i,j]:=nomer;
      end;
   x:=-1;
   status:='3_1';
   goto lexit;
   l3_1:
   { Определение столбца x, где находится(-ятся) nomer }
   pos_x:=-dl;
   While x<dlina do
   begin
      x:=x+1;
      If x>=dlina then
         goto l4_1;
      For j:=pos_y to pos_y+dl-1 do
         If pb[x,j] and (p[x,j]=nomer) then
            goto l3_11;
   end;
   l3_11:
   { Подсчет nomer в столбце x, кроме текущего блока }
   kn:=0;
   For j:=0 to dlina-1 do
   begin
      If p[x,j]<>nomer then
         pris[x,j]:=4;
      If (p[x,j]=nomer) and ((j<pos_y) or (j>=pos_y+dl)) then
      begin
         kn:=kn+1;
         pris[x,j]:=2;
      end;
   end;
   status:='3_2';
   goto lexit;
   l3_2:
   For j:=0 to dlina-1 do
      If pb[x,j] then
         pris[x,j]:=0;
   { Если в столбце x есть 2 и более nomer, то удаляем их, в противном случае
     оставляем одну }
   For j:=pos_y to pos_y+dl-1 do
      If kn>0 then
         If p[x,j]=nomer then
            p[x,j]:=0 else
         else
         If p[x,j]=nomer then
            pris[x,j]:=3;
   status:='3_1';
   If x>=dlina-1 then
      status:='4_1';
   goto lexit;
   l4_1:
   { Подсчет в блоке 3*3 количество nomer }
   pos_x:=pos_x+dl;
   kn:=0;
   y:=pos_y-1;
   For i:=pos_x to pos_x+dl-1 do
      For j:=pos_y to pos_y+dl-1 do
      begin  
         pris[i,j]:=4;
         If p[i,j]=nomer then
         begin
            pris[i,j]:=2;
            If pb[i,j] then
               kn:=kn+1;
         end;
      end;
   { Если в блоке 3*3 количество nomer = 0, то переходим к следующему блоку }
   If kn=0 then
   begin
      For i:=pos_x to pos_x+dl-1 do
         For j:=pos_y to pos_y+dl-1 do
            If pb[i,j] then
               pris[i,j]:=0;
      If pos_x>=dlina-dl then
         goto l5_1 else
         goto l4_1;
   end;
   status:='4_2';
   goto lexit;
   l4_2:
   For i:=pos_x to pos_x+dl-1 do
      For j:=pos_y to pos_y+dl-1 do
         If pb[i,j] then
            pris[i,j]:=0;
   { Если в этом блоке есть более 2-х nomer, то их удаляем }
   For i:=pos_x to pos_x+dl-1 do
      For j:=pos_y to pos_y+dl-1 do
         If kn>1 then
            If p[i,j]=nomer then
               p[i,j]:=0 else
               else
            If p[i,j]=nomer then
               pris[i,j]:=3;
   status:='4_1';
   If pos_x>=dlina-dl then
      status:='5_1';
   goto lexit;
   l5_1:
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
         pris[i,j]:=0;
   y:=y+1;
   { Подсчет в строчке y количество nomer }
   kn:=0;
   For i:=0 to dlina-1 do
   begin
      pris[i,y]:=4;
      If p[i,y]=nomer then
      begin
         pris[i,y]:=2;
         kn:=kn+1;
      end;
   end;
   If kn<=1 then
   begin
      If final then
         goto lfinal;
      For i:=0 to dlina-1 do
         pris[i,y]:=0;
      If y>=pos_y+dl-1 then
         goto l6 else
         goto l5_1;
   end;
   status:='5_2';
   goto lexit;
   l5_2:
   For i:=0 to dlina-1 do
      pris[i,y]:=0;
   For i:=0 to dlina-1 do
      If kn>1 then
         If p[i,y]=nomer then
            p[i,y]:=0 else
            else
         If p[i,y]=nomer then
            pris[i,y]:=3;
   status:='5_1';
   If y>=pos_y+dl-1 then
      status:='6';
   goto lexit;
   l6:
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
         pris[i,j]:=0;
   If pos_y<dlina-dl then
      goto l2_1;
   If nomer<dlina then
      goto l1;
   l1_ex:
   nomer:=0;
   Vertical90;
   If vertical then
      goto l1;
   l21:
   { Расчеты по горизонтали }
   nomer:=nomeri;
   If nomer=0 then
      goto l21_ex;
   y:=-1;
   l22_1:
   { Расставляем в строке y числа nomer }
   y:=y+1;
   For i:=0 to dlina-1 do
      For j:=0 to dlina-1 do
         pb[i,j]:=true;
   kn:=0;
   { Подсчет количество nomer в строке y }
   For i:=0 to dlina-1 do
   begin
      pris[i,y]:=4;
      If p[i,y]=nomer then
      begin
         kn:=kn+1;
         pris[i,y]:=2;
      end;
   end;
   status:='22_2';
   goto lexit;

[newerow1989]

  l22_2:
   For i:=0 to dlina-1 do
      pris[i,y]:=0;
   If kn>=1 then
      goto l25;
   { Если в блоке 3*3 есть nomer, то здесь nomer не ставится }
   pos_y:=(y div dl)*dl;
   For i1:=0 to dl-1 do
   begin
      pos_x:=i1*dl;
      kn:=0;
      For i:=pos_x to pos_x+dl-1 do
         For j:=pos_y to pos_y+dl-1 do
            If p[i,j]=nomer then
               kn:=kn+1;
      If kn>=1 then
         For i:=pos_x to pos_x+dl-1 do
            For j:=pos_y to pos_y+dl-1 do
            begin
               pb[i,j]:=false;
               pris[i,j]:=4;
               If p[i,j]=nomer then
                  pris[i,j]:=2;
            end;
   end;
   For i:=0 to dlina-1 do
      If pb[i,y] and (p[i,y]=0) then
      begin
         p[i,y]:=nomer;
         pris[i,y]:=1;
      end;
   x:=-1;
   status:='23_1';
   goto lexit;
   l23_1:
   While x<dlina do
   begin
      x:=x+1;
      If x>=dlina then
         goto l24_1;
      If pb[x,y] and (p[x,y]=nomer) then
            goto l23_11;
   end;
   l23_11:
   { Подсчет nomer в столбце x, кроме текущей строки y }
   kn:=0;
   For j:=0 to dlina-1 do
   begin
      If p[x,j]<>nomer then
         pris[x,j]:=4;
      If (p[x,j]=nomer) and (j<>y) then
      begin
         kn:=kn+1;
         pris[x,j]:=2;
      end;
   end;
   status:='23_2';
   goto lexit;
   l23_2:
   For j:=0 to dlina-1 do
      pris[x,j]:=0;
   { Если в столбце x есть nomer, то в строке y удаляем его, в противном случае
     оставляем одну }
   If kn>0 then
      If p[x,y]=nomer then
         p[x,y]:=0 else
      else
      If p[x,y]=nomer then
         pris[x,y]:=3;
   status:='23_1';
   If x>=dlina-1 then
      status:='24_1';
   goto lexit;
   l24_1:
   { Подсчет в строке y количество выставленных nomer }
   kn:=0;
   For i:=0 to dlina-1 do
   begin
      pris[i,y]:=4;
      If pb[i,y] and (p[i,y]=nomer) then
      begin
         kn:=kn+1;
         pris[i,y]:=2;
      end;
   end;
   status:='24_2';
   goto lexit;
   l24_2:
   { Если в строке y количество nomer более 1, то удаляем все nomer }
   For i:=0 to dlina-1 do
   begin
      If pb[i,y] then
         pris[i,y]:=0;
      If p[i,y]=nomer then
         If kn>1 then
            p[i,y]:=0 else
            pris[i,y]:=3;
   end;
   status:='25';
   If final then
      goto lfinal;
   goto lexit;
   l25:
   pos_y:=(y div dl)*dl;
   For i:=0 to dlina-1 do
      For j:=pos_y to pos_y+dl-1 do
         pris[i,j]:=0;
   If y<dlina-1 then
      goto l22_1;
   If nomer<dlina then
      goto l21;
   l21_ex:
   nomer:=0;
   Vertical90;
   If vertical then
      goto l21;
   status:='0';
   goto lexit;
   lfinal:
   For i:=0 to dlina-1 do
      For j:=0 to dlina-1 do
      begin
         pb[i,j]:=true;
         pris[i,j]:=0;
      end;
   Label4.Visible:=false;
   Label5.Visible:=false;
   Label8.Visible:=false;
   Label9.Visible:=false;
   Label10.Visible:=false;
   Timer1.Enabled:=false;
   status:='';
   If pusto_tek>0 then
      Label11.Caption:='Невозможно решить!' else
      Label11.Caption:='Решено!';
   lexit:
   rasst;
   Timer1.Interval:=UpDown1.Position;
   If not CheckBox1.Checked and (status<>'') then
      goto l0;
end;

procedure TForm1.Button1Click(Sender: TObject);
label lab;
var i,j,i1,j1,kn:integer;
    dalee:boolean;
begin
   If not start then
      Exit;
   hod:=0;
   status:='0';
   pusto:=dlina*dlina;
   RadioButton1Click(nil);
   If CheckBox1.Checked and RadioButton2.Checked then
      Button2Click(nil);
   Exit;
   lab:
   { Расчеты по горизонтали }
   Repeat
      pos_y:=-3;
      nomer:=nomer+1;
      rasst;
      Repeat
         pos_y:=pos_y+3;
         For i:=0 to 8 do
            For j:=0 to 8 do
               pb[i,j]:=true;
         For i:=0 to 8 do
            For j:=pos_y to pos_y+2 do
               { Если nomer нашелся, то в блоке 3*3, строкe j его не ставим }
               If p[i,j]=nomer then
               begin
                  pos_x:=(i div 3)*3;
                  For i1:=pos_x to pos_x+2 do
                     For j1:=pos_y to pos_y+2 do
                        pb[i1,j1]:=false;
                  For i1:=0 to 8 do
                     pb[i1,j]:=false;
               end;
         { Расстановка nomer в блоке 3*9 }
         For i:=0 to 8 do
            For j:=pos_y to pos_y+2 do
               If pb[i,j] and (p[i,j]=0) then
               begin
                  kn:=0;
                  p[i,j]:=nomer;
                  rasst;
                  { Подсчет nomer в столбце i, кроме текущего блока }
                  For j1:=0 to pos_y-1 do
                     If p[i,j1]=nomer then
                        kn:=kn+1;
                  For j1:=pos_y+3 to 8 do
                     If p[i,j1]=nomer then
                        kn:=kn+1;
                  { Если в столбце j есть nomer, то удаляем поставленный nomer }
                  If kn>=1 then
                     p[i,j]:=0;
                  rasst;
               end;
         { Подсчет в блоке 3*3 количество nomer }
         pos_x:=-3;
         Repeat
            pos_x:=pos_x+3;
            kn:=0;
            For i:=pos_x to pos_x+2 do
               For j:=pos_y to pos_y+2 do
                  If p[i,j]=nomer then
                     kn:=kn+1;
            { Если в этом блоке есть более 2-х nomer, то их удаляем }
            If kn>=2 then
               For i:=pos_x to pos_x+2 do
                  For j:=pos_y to pos_y+2 do
                     If p[i,j]=nomer then
                        p[i,j]:=0;
         Until pos_x>=6;
         rasst;
      Until pos_y>=6;
   Until nomer>=9;
   rasst;
   { Расчеты по вертикали (аналогично расчетам по горизонтали) }
   nomer:=0;
   Repeat
      pos_x:=-3;
      nomer:=nomer+1;
      rasst;
      Repeat
         pos_x:=pos_x+3;
         For i:=0 to 8 do
            For j:=0 to 8 do
               pb[i,j]:=true;
         For j:=0 to 8 do
            For i:=pos_x to pos_x+2 do
               If p[i,j]=nomer then
               begin
                  pos_y:=(j div 3)*3;
                  For i1:=pos_x to pos_x+2 do
                     For j1:=pos_y to pos_y+2 do
                        pb[i1,j1]:=false;
                  For j1:=0 to 8 do
                     pb[i,j1]:=false;
               end;
         For j:=0 to 8 do
            For i:=pos_x to pos_x+2 do
               If pb[i,j] and (p[i,j]=0) then
               begin
                  kn:=0;
                  p[i,j]:=nomer;
                  rasst;
                  For i1:=0 to pos_x-1 do
                     If p[i1,j]=nomer then
                        kn:=kn+1;
                  For i1:=pos_x+3 to 8 do
                     If p[i1,j]=nomer then
                        kn:=kn+1;
                  If kn>=1 then
                     p[i,j]:=0;
                  rasst;
               end;
         pos_y:=-3;
         Repeat
            pos_y:=pos_y+3;
            kn:=0;
            For i:=pos_x to pos_x+2 do
               For j:=pos_y to pos_y+2 do
                  If p[i,j]=nomer then
                     kn:=kn+1;
            If kn>=2 then
               For i:=pos_x to pos_x+2 do
                  For j:=pos_y to pos_y+2 do
                     If p[i,j]=nomer then
                        p[i,j]:=0;
         Until pos_y>=6;
         rasst;
      Until pos_x>=6;
   Until nomer=9;
   rasst;

[newerow1989]

   { Расчеты по горизонтали }
   nomer:=0;
   Repeat
      nomer:=nomer+1;
      For j:=0 to 8 do
      begin
         { Можно ли поставить в строке j nomer }
         dalee:=true;
         For i:=0 to 8 do
            If p[i,j]=nomer then
               dalee:=false;
         If dalee then
         begin
            For i:=0 to 8 do
               If p[i,j]=0 then
               begin
                  kn:=0;
                  p[i,j]:=nomer;
                  rasst;
                  { Подсчет в столбце i количество nomer }
                  For j1:=0 to 8 do
                     If p[i,j1]=nomer then
                        kn:=kn+1;
                  If kn=2 then
                     p[i,j]:=0;
                  kn:=0;
                  { Подсчет в текущем блоке 3*3 количество nomer, не считая
                    текущую строку j }
                  pos_x:=(i div 3)*3;
                  pos_y:=(j div 3)*3;
                  For i1:=pos_x to pos_x+2 do
                     For j1:=pos_y to pos_y+2 do
                        If (p[i1,j1]=nomer) and (j<>j1) then
                           kn:=kn+1;
                  If kn=1 then
                     p[i,j]:=0;
                  rasst;
               end;
            kn:=0;
            { Подсчет в строке j количество nomer }
            For i:=0 to 8 do
               If p[i,j]=nomer then
                  kn:=kn+1;
            If kn>=2 then
               For i:=0 to 8 do
                  If p[i,j]=nomer then
                     p[i,j]:=0;
            rasst;
         end;
      end;
   Until nomer>=9;
   rasst;
   { Расчеты по вертикали (аналогично расчетам по горизонтали) }
   nomer:=0;
   Repeat
      nomer:=nomer+1;
      For i:=0 to 8 do
      begin
         dalee:=true;
         For j:=0 to 8 do
            If p[i,j]=nomer then
               dalee:=false;
         If dalee then
         begin
            For j:=0 to 8 do
               If p[i,j]=0 then
               begin
                  kn:=0;
                  p[i,j]:=nomer;
                  rasst;
                  For i1:=0 to 8 do
                     If p[i1,j]=nomer then
                        kn:=kn+1;
                  If kn=2 then
                     p[i,j]:=0;
                  kn:=0;
                  pos_x:=(i div 3)*3;
                  pos_y:=(j div 3)*3;
                  For i1:=pos_x to pos_x+2 do
                     For j1:=pos_y to pos_y+2 do
                        If (p[i1,j1]=nomer) and (i<>i1) then
                           kn:=kn+1;
                  If kn=1 then
                     p[i,j]:=0;
                  rasst;
               end;
            kn:=0;
            For j:=0 to 8 do
               If p[i,j]=nomer then
                  kn:=kn+1;
            If kn>=2 then
               For j:=0 to 8 do
                  If p[i,j]=nomer then
                     p[i,j]:=0;
            rasst;
         end;
      end;
   Until nomer>=9;
   rasst;
   If not final then
      goto lab;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   If status<>'' then
      Timer1Timer(nil);
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
   RadioButton1.Visible:=CheckBox1.Checked;
   RadioButton2.Visible:=CheckBox1.Checked;
   RadioButton1Click(nil);
end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
   Label2.Visible:=RadioButton1.Checked and CheckBox1.Checked;
   Edit1.Visible:=RadioButton1.Checked and CheckBox1.Checked;
   UpDown1.Visible:=RadioButton1.Checked and CheckBox1.Checked;
   Button2.Visible:=RadioButton2.Checked and CheckBox1.Checked;
   If status<>'' then
      Timer1.Enabled:=not CheckBox1.Checked or RadioButton1.Checked;
end;

procedure TForm1.RadioButton2Click(Sender: TObject);
begin
   RadioButton1Click(nil);
end;

end.

В принципе модераторы могут удалить мои посты с огромным кодом и оставить только вложение. Ограничение в 8000 символов - все-равно оказалось мало!

[Serge_Bliznykov]

newerow1989, запустил я ваш код.

думаю, что в данной теме он не подходит:

во-первых, он же для решения судоку, а не для изначальной расстановки цифр (создание задания).

а во-вторых, он явно не "Судоку-Жирандоль" (он при решении не обеспечивает разные цифры в указанных желтым полях).

[evg_m]

Из разряда "мысли вслух".
1. расставляем случайно цифры в выделенные клетки.
2. ДОзаполняем строки.

В обычном судоку я просто по порядку расставляю все цифры в каждой строке,

3. перемешиваем строки(столбцы)

, а потом перемешиваю строки, меняя их местами и столбцы

НО с оглядкой, а именно
мы должны принять некоторые меры, чтобы на выделенных(особых) местах все осталось по прежнему.
Для этого если перемещаемые строки содержат особые ячейки, то в дополнение к этому перемещению, делается и перемещение столбцов ТАКИМ образом, чтобы в выделенные и "испорченные" клетки "вернулось" правильное значение.
Конечно, перемещение столбцов в свою очередь может затронуть новые "особые" ячейки и теперь мы должны будем еще переместить теперь уже строки для восстановления "порядка".
Не уверен, что мы сможем таким образом когда-либо остановиться (в этом-то и вся трудность).

P.S. как вариант
1. делаем обычный СУДОКУ. (заполняем перемешиваем) без внимания к тому что получается в "особых" точках.
2. дополнительная перестановка строк/столбцов ДЛЯ УСТАНОВКИ "правильных" значений в особых ячейках (по описанному выше в п.3) правилу.
для выбора предпочтительного "донора" использовать строку(столбец) без особых точек. кажется(вовсе в этом не уверен) это можно сделать всегда.

[Serge_Bliznykov]

evg_m, согласен, думаю аналогично.

пост выше я написал просто в рамках по борьбе с заблуждениями - чтобы тот, кто пришёл в тему по поиску не решил,
что предложенный код имеет отношение именно к варианту "Судоку-Жирандоль".


Автор этой темы Armageddets уже, похоже, утратил к ней интерес.

А по поводу данной задачи, то тут, ИМХО, есть ещё один "нюанс".
Можно заполнить полностью поле цифрами согласно правилам "Судоку-Жирандоль".
Но если требуется опубликовать вариант с пустыми клеточками (ну, как в газетах/журналах, где нужно заполнить пропуски - т.е. решить судоку), то нужно скрыть ячейка так, чтобы осталось только одно единственное решение.
Если я не ошибаюсь, конечно.

p.s. исходную задачу вполне можно решить перебором.
И тут даже рекурсивное решение допустимо - глубина вызовов не более 80.

[Аватар]

Интересно стало)) Рекурсивно случайным подбором вполне хорошо. Вот прикидка. В принципе так и решать можно, задав значения в нужные клетки вместо тех девяти фиксированных. Для решения случайность и не обязательна, просто перебором можно из допустимых значений. Можно и приспособить для проверки - единственное решение или нет. Для составителей это должно быть актуально.

var Sudoku: array[0..8,0..8] of Integer;

function Recursive(pRow,pCol: Integer): Boolean;
var i,j,i1,j1,xCount: Integer;
    xUsed,xFor: array[1..9] of Integer;
begin
  Result:=False;
  for i:=1 to 9 do xUsed[i]:=i;
  for i:=(pRow div 3)*3 to (pRow div 3)*3+2 do
    for j:=(pCol div 3)*3 to (pCol div 3)*3+2 do if Sudoku[i,j]>0 then xUsed[Sudoku[i,j]]:=0;
  for i:=0 to 8 do if Sudoku[i,pCol]>0 then xUsed[Sudoku[i,pCol]]:=0;
  for j:=0 to 8 do if Sudoku[pRow,j]>0 then xUsed[Sudoku[pRow,j]]:=0;
  while True do begin
    xCount:=0;
    for i:=1 to 9 do if xUsed[i]>0 then begin Inc(xCount); xFor[xCount]:=i; end;
    if xCount=0 then Exit;
    Sudoku[pRow,pCol]:=xFor[Random(xCount)+1];
    i1:=-1; j1:=-1;
    for i:=0 to 8 do begin
      for j:=0 to 8 do if Sudoku[i,j]=0 then begin i1:=i; j1:=j; Break; end;
      if i1<>-1 then Break;
    end;
    Result:=(i1=-1) or Recursive(i1,j1);
    if Result then Exit;
    xUsed[Sudoku[pRow,pCol]]:=0;
    Sudoku[pRow,pCol]:=0;
  end;
end;

procedure TForm1.Button5Click(Sender: TObject);
var i,j: Integer;
    s: String;
function FixNumber(Count: Integer; Casually: Boolean = True): Integer;
begin
  if Casually then begin
    Result:=StrToInt(s[Random(Count)+1]);
    s:=StringReplace(s,IntToStr(Result),'',[]);
  end  
  else Result:=10-Count;
end;
begin
  Randomize;
  s:='123456789';
  for i:=0 to 8 do
    for j:=0 to 8 do begin
      if      (i=0) and (j=0) then Sudoku[i,j]:=FixNumber(9)
      else if (i=0) and (j=8) then Sudoku[i,j]:=FixNumber(8)
      else if (i=1) and (j=4) then Sudoku[i,j]:=FixNumber(7)
      else if (i=4) and (j=1) then Sudoku[i,j]:=FixNumber(6)
      else if (i=4) and (j=4) then Sudoku[i,j]:=FixNumber(5)
      else if (i=4) and (j=7) then Sudoku[i,j]:=FixNumber(4)
      else if (i=7) and (j=4) then Sudoku[i,j]:=FixNumber(3)
      else if (i=8) and (j=0) then Sudoku[i,j]:=FixNumber(2)
      else if (i=8) and (j=8) then Sudoku[i,j]:=FixNumber(1)
                              else Sudoku[i,j]:=0;
    end;
  Recursive(0,1);
  for i:=0 to 8 do
    for j:=0 to 8 do StringGrid1.Cells[j,i]:=IntToStr(Sudoku[i,j]);
end;

[Serge_Bliznykov]

Аватар, круто! Респект!