VPF::Судоку на делфи - Форум программистов

Killerkod

Дата 18.4.2010, 08:21 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 27
Регистрация: 23.1.2008

Репутация: нет
Всего: нет

В общем суть такова, получил задание, написать программу, которая будет решать судоку. Просто тупо программу с 81 клеткой, и при нажатии кнопки чтоб все клетки правильно заполнялись.
Вроде написал...
Исходник приложил.
Вроде заполняет, все правильно.. но остаются нули, которые она заполнить не может, т.к. уже будет неверно... Т.е. расположение цифр идет неверное... Гланьте сорс, помогите решить... Желательно с пояснениями)))
П.С. прошу не предлагать чужие сорсы, мне самому охото написать... чтоб полностью понять это...

Код


unit Unit1;

interface

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

type  
  TSudoku = array[1..9,1..9] of 0..9;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;


var
  CEdits:array[1..9,1..9] of TEdit;
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);  
var  
  i1,i2:integer;
begin
  for i2:=1 to 9 do
    for i1:=1 to 9 do begin
      CEdits[i1,i2]:=TEdit.Create(self);
      with CEdits[i1,i2] do begin
        Parent:=self;  
        Left:= (i1 - 1) * 25 + 5;
        Top:= (i2 - 1) * 25 + 5;
        Width:= 20;
        Text:='0';
      end;
    end;
end;

function sudInSq(x,y,ch:integer):boolean;
var  
  ix,iy:0..8;  
  lx,ly:0..8;
begin  
  lx:=0; ly:=0;  
  if x in [1,2,3] then lx:=1;
  if x in [4,5,6] then lx:=4;
  if x in [7,8,9] then lx:=7;
  lx:=lx-1;  
  if y in [1,2,3] then ly:=1;
  if y in [4,5,6] then ly:=4;
  if y in [7,8,9] then ly:=7;
  ly:=ly-1;  
  Result:=True;  
  for ix:=1 to 3 do  
    for iy:=1 to 3 do  
      if (x<>lx+ix) and (y<>ly+iy) then
        if Cedits[lx+ix,ly+iy].text=IntToStr(ch) then Exit;
  Result:=False;  
end;


function prov_lin(x, ch:integer):boolean;
var
  i:integer;
begin
for i:=1 to 9 do     //1
begin
  if Cedits[x,i].text= IntToStr(ch) then  //2
  begin
  Result:=true;
  Exit;
  end;   //2
end;//1
Result:=false;
end;

function prov_st(ch, y:integer):boolean;
var
  i:integer;
begin
for i:=1 to 9 do     //1
begin
  if Cedits[i,y].text= IntToStr(ch) then  //2
  begin
  Result:=true;
  Exit;
  end;   //2
end;//1
Result:=false;
end;

function prov_all(ch,x,y:integer):boolean;
begin
result:= prov_lin(x,ch) or  prov_st(ch, y) or sudInSq(x,y,ch);
end;

procedure zapis(x,y:integer);
var
i:integer;
begin
       for i:=1 to 9 do begin
       if not prov_all(i,x,y) then
       Cedits[x,y].Text:=IntToStr(i);
       end;
end;

procedure poisk;
var
 x,y,i:integer;
begin
for x:=1 to 9 do
  for y:=1 to 9 do
    if cedits[x,y].Text='0' then
    zapis(x,y);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
poisk;
end;

end.

Присоединённый файл ( Кол-во скачиваний: 15 )

Unit1.pas 2,34 Kb

kuzyara

Дата 25.4.2010, 11:49 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 215
Регистрация: 13.11.2006

Репутация: нет
Всего: 1

в чем проблема то?
не можешь определится с логикой программы, или ошибку в коде найти?

если с первым, то брутфорсь клетки и проверяй на горизонталь, вертикаль и квадрат. если вариантов несколько - обрабатывай след. клетку. и так по кругу. если клеток с единственным вариантом не осталось - вставляй первую подходящую цифру, создавай "копию-таблицу-потомок" и опять обрабатывай.
В результате этой рекурсии у тебя останется один или несколько вариантов... м?

Это сообщение отредактировал(а) kuzyara - 25.4.2010, 11:52

--------------------

подпись

aragnophy

Дата 11.6.2010, 20:16 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 3
Регистрация: 15.5.2008

Репутация: нет
Всего: нет

Выкладываю сюда, может кому пригодится релизацию решения судоку с помощью генетических алгоритмов. Писалась в спешке, но задачу решает... В комплекте отчёт с описанием.

Присоединённый файл ( Кол-во скачиваний: 47 )

Sudoku_Genetic_032.zip 987,00 Kb

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Для новичков \| Следующая тема »