Форум «Всё о Паскале» > Нелогичная работа программы (в среде Дельфи)

Помощь - Поиск - Пользователи - Календарь

Полная версия: Нелогичная работа программы (в среде Дельфи)

Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи

Sozialist

10.08.2010 9:44

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

Модуль soSol (Показать/Скрыть)


unit soSol;

interface
uses
SysUtils;

type
  TBlock=array [1..3,1..3] of 0..9;       //Массив, содержащий один блок
  TMBlock=array [1..3,1..3] of TBlock;    //Массив блоков (может содержать судоку целиком)
  TSet=set of 1..9;                       //Множество известных цифр в блоке
  TBSet=array [1..3,1..3] of TSet;        //Блок множеств возможный цифр в ячейке
  TMBSet=array [1..3,1..3] of TBSet;      //Массив блоков множеств возможных цифр в ячейках
var
  Block:TBlock;                           //Блок-экземпляр
  MBlock:TMBlock;                         //Массив-экземпляр блоков
  FSolved:boolean=false;                  //Флаг выставляется, когда судоку решалось
  _Set:TSet;                              //Множество, используемое для проверки корректности
  MBSet:TMBSet;                           //Массив, хранящий возможные значения для каждой ячейки в виде множества
implementation

end.

Основная часть (Показать/Скрыть)


program soSudoku;

{$APPTYPE CONSOLE}

uses
  SysUtils, soSol;

var
  choice:0..6;

procedure SInsert;                        //Процедура ввода судоку с клавиатуры
  var
    i,j,k,p:1..3;
  begin
    for k:=1 to 3 do
      for p:=1 to 3 do
      begin
        for i:=1 to 3 do
          for j:=1 to 3 do
            begin
              readln(Block[i,j]);
            end;
        MBlock[k,p]:=Block;
      end;
    FSolved:=false;
  end;                                    //Конец процедуры ввода судоку с клавиатуры


function SCheck(SMas:TMBlock; Flag:boolean):boolean;        //Функция проверки корректности задачи или решения (правильности расположения цифр)
  var
    i,j,k,p:1..3;
    FRo, FSt, FBl:boolean;                //Флаги корректности судоку после проверки соответственно рядов, столбцов, блоков
  begin
    //Начало проверки корректности рядов
    FRo:=true;
    for k:=1 to 3 do
        for i:=1 to 3 do
          begin
            //MSet[(k-1)*3+i]:=[];
            _Set:=[];
            if FRo then
              for p:=1 to 3 do
                begin
                  for j:=1 to 3 do
                    //if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*MSet[(k-1)*3+i]=[])) then MSet[(k-1)*3+i]:=[SMas[k,p][i,j]]+MSet[(k-1)*3+i]
                    //else if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*MSet[(k-1)*3+i]<>[])) then FRo:=false;
                    if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set=[])) then _Set:=[SMas[k,p][i,j]]+_Set
                    else if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set<>[])) then FRo:=false;
                end
            else  begin
                    Result:=false;
                    if Flag then writeln('Error in the ',(k-1)*3+i-1,' line.');
                    Exit;
                  end;
          end;
    //Конец проверки корректноси рядов


    //Начало проверки корректноси столбцов
    FSt:=true;
    for p:=1 to 3 do
        for j:=1 to 3 do
          begin
            //MSet[(p-1)*3+j]:=[];
            _Set:=[];
            if FSt then
              for k:=1 to 3 do
                begin
                  for i:=1 to 3 do
                    //if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*MSet[(p-1)*3+j]=[])) then MSet[(p-1)*3+j]:=[SMas[k,p][i,j]]+MSet[(p-1)*3+j]
                    //else if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*MSet[(p-1)*3+j]<>[])) then FSt:=false;
                    if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set=[])) then _Set:=[SMas[k,p][i,j]]+_Set
                    else if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set<>[])) then FSt:=false;
                end
            else  begin
                    Result:=false;
                    if Flag then writeln('Error in the ',(p-1)*3+j-1,' stable.');
                    Exit;
                  end;
          end;
    //Конец проверки корректности столбцов


    //Начало проверки корректности блоков
    FBl:=true;
    for k:=1 to 3 do
      for p:=1 to 3 do
        begin
          _Set:=[];
          if FBl then
            for i:=1 to 3 do
              begin
                for j:=1 to 3 do
                  if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set=[])) then _Set:=[SMas[k,p][i,j]]+_Set
                  else if ((SMas[k,p][i,j]<>0) and ([SMas[k,p][i,j]]*_Set<>[])) then FBl:=false;
              end
          else  begin
                    Result:=false;
                    if Flag then writeln('Error in the ',(k-1)*3+p-1,' block.');
                    Exit;
                  end;
            end;
    //Конец проверки корректноси блоков


    if (FRo and FSt and FBl) then Result:=true
    else Result:=false;
  end;                                    //Конец функции проверки корректности


procedure SPrint(Mass:TMBlock);                         //Процедура печати судоку на экран
  var
    i,j,k,p:1..3;
  begin
    writeln;
    for k:=1 to 3 do
      begin
        for i:=1 to 3 do
          begin
            for p:=1 to 3 do
              begin
                write('   ');
                for j:=1 to 3 do
                  if Mass[k,p][i,j]<>0 then write(' ',Mass[k,p][i,j])
                  else write('  ');
              end;
              writeln; writeln;
          end;
        writeln;
      end;
    if SCheck(MBlock, true) then writeln ('Current sudoku is CORRECT!')
    else writeln ('Current sudoku is INCORRECT! Check out the the loading task.');
  end;                                    //Конец процедуры печати судоку на экран

procedure SLoad;                          //Процедура загрузки судоку из файла
  var
    i,j,k,p:1..3;
    F:textfile;
    FName:string;
  begin
    writeln('Enter full <*.txt> file path ("Return" to load the default one):');
    readln(FName);
    if FName='' then FName:='default';
    assignfile(F,FName+'.txt');
   TRY
    reset(F);
    FSolved:=false;
    while not eof(F) do
      begin
        for k:=1 to 3 do
          for p:=1 to 3 do
            begin
              for i:=1 to 3 do
                for j:=1 to 3 do
                  begin
                    read(F,Block[i,j]);
                  end;
              MBlock[k,p]:=Block;
            end;
      end;
    closefile(F);
   EXCEPT
    on EInOutError do writeln('File does NOT exist!');
   END;
  end;                                    //Конец процедуры загрузки судоку из файла

procedure SSearPossNums(var SMas:TMBlock);    //Процедура поиска возможных значений ячеек
  var
  i,j,k,p:1..3;
  n:1..9;
  begin
  REPEAT
  //ПОИСК ВОЗМОЖНЫХ ЗНАЧЕНИЙ ДЛЯ КАЖДОЙ ЯЧЕЙКИ МЕТОДОМ ПЕРЕСЕЧЕНИЯ 3-Х МНОЖЕСТВ \
  //ПО ПРИНАДЛЕЖНОСТИ ЯЧЕЙКИ СТРОКЕ, СТОБЦУ И БЛОКУ

  //Поиск по строкам
    for k:=1 to 3 do
      for i:=1 to 3 do
        begin
          _Set:=[];
          for p:=1 to 3 do
            for j:=1 to 3 do
              if SMas[k,p][i,j]<>0 then _Set:=[SMas[k,p][i,j]]+_Set;

          for p:=1 to 3 do
            for j:=1 to 3 do
              if SMas[k,p][i,j]=0 then MBSet[k,p][i,j]:=[1..9]-_Set
              else MBSet[k,p][i,j]:=[];
        end;
  //Конец поиска по строкам

  //Поиск по стобцам с учетом поиска по строкам
    for p:=1 to 3 do
      for j:=1 to 3 do
        begin
          _Set:=[];
          for k:=1 to 3 do
            for i:=1 to 3 do
              if SMas[k,p][i,j]<>0 then _Set:=[SMas[k,p][i,j]]+_Set;

          for k:=1 to 3 do
            for i:=1 to 3 do
              if SMas[k,p][i,j]=0 then MBSet[k,p][i,j]:=MBSet[k,p][i,j]*([1..9]-_Set);
        end;
  //Конец поиска

  //Поиск по блокам с учетом поиска по строкам и столбцам
    for k:=1 to 3 do
      for p:=1 to 3 do
        begin
          _Set:=[];
          for i:=1 to 3 do
            for j:=1 to 3 do
              if SMas[k,p][i,j]<>0 then _Set:=[SMas[k,p][i,j]]+_Set;

          for i:=1 to 3 do
            for j:=1 to 3 do
              if SMas[k,p][i,j]=0 then MBSet[k,p][i,j]:=MBSet[k,p][i,j]*([1..9]-_Set);
        end;
  //Конец поиска по блокам

  //МОДИФИКАЦИЯ ЗАДАННОГО СУДОКУ (РЕШЕНИЕ)
    FSolved:=true;
    for k:=1 to 3 do
      for p:=1 to 3 do
        for i:=1 to 3 do
          for j:=1 to 3 do
            begin
              for n:=1 to 9 do
                if MBSet[k,p][i,j]=[n] then begin
                                              SMas[k,p][i,j]:=n;
                                              FSolved:=false;
                                            end;
            end;

  UNTIL FSolved {and SCheck(SMas,false)};
  end;                                    //Конец процедуры поиска возможных значений ячеек


procedure STransMSets(var SMas:TMBlock);
  var
  i,j,k,p,ex1,ex2:1..3;
  n:1..9;
  FRo, FSt, FBl, Fl:boolean;
  begin
  //REPEAT
  //АНАЛИЗ ПОЛУЧЕННЫХ МНОЖЕСТВ, РЕАЛИЗИЦИЯ РЕШЕНИЯ МЕТОДОМ ЕДИНСТВЕННОГО ВХОЖДЕНИЯ  \
  //ЧИСЛА В МНОЖЕСТВА СООТВЕТСТВУЮЩИХ ЯЧЕЙКЕ СТРОК, СТОЛБЦОВ И БЛОКОВ

//  REPEAT
  //Модификация массива мн-ств по строкам
    FRo:=true;
    for k:=1 to 3 do
      for i:=1 to 3 do
          for p:=1 to 3 do
            for j:=1 to 3 do
              if MBSet[k,p][i,j]<>[] then
                begin
                  _Set:=MBSet[k,p][i,j];
//                  for n:=1 to 9 do
//                    if [n]=_Set then Fl:=false else Fl:=true;
                  for ex1:=1 to 3 do
                    for ex2:=1 to 3 do
                      if (ex1<>p) and (ex2<>j) then _Set:=_Set-MBSet[k,ex1][i,ex2];
                  for n:=1 to 9 do
                    if [n]=_Set then  begin
                                        MBSet[k,p][i,j]:=_Set;
//                                        if Fl then FRo:=false;
                                      end;
                end;
  //Конец

  //Модификация массива мн-ств по стобцам
    FSt:=true;
    for p:=1 to 3 do
      for j:=1 to 3 do
          for k:=1 to 3 do
            for i:=1 to 3 do
              if MBSet[k,p][i,j]<>[] then
                begin
                  _Set:=MBSet[k,p][i,j];
//                  for n:=1 to 9 do
//                    if [n]=_Set then Fl:=false else Fl:=true;
                  for ex1:=1 to 3 do
                    for ex2:=1 to 3 do
                      if (ex1<>k) and (ex2<>i) then _Set:=_Set-MBSet[ex1,p][ex2,j];
                  for n:=1 to 9 do
                    if [n]=_Set then  begin
                                        MBSet[k,p][i,j]:=[n];
//                                        if Fl then FSt:=false;
                                      end;
                end;
  //Конец

  //Модификация массива мн-ств по блокам
    FBl:=true;
    for k:=1 to 3 do
      for p:=1 to 3 do
          for i:=1 to 3 do
            for j:=1 to 3 do
              if MBSet[k,p][i,j]<>[] then
                begin
                  _Set:=MBSet[k,p][i,j];
//                  for n:=1 to 9 do
//                    if [n]=_Set then Fl:=false else Fl:=true;
                  for ex1:=1 to 3 do
                    for ex2:=1 to 3 do
                      if (ex1<>i) and (ex2<>j) then _Set:=_Set-MBSet[k,p][ex1,ex2];
                  for n:=1 to 9 do
                    if [n]=_Set then  begin
                                        MBSet[k,p][i,j]:=[n];
//                                        if Fl then FBl:=false;
                                      end;
                end;
  //Конец
//  UNTIL (FRo and FSt and FBl);

  //МОДИФИКАЦИЯ ЗАДАННОГО СУДОКУ (РЕШЕНИЕ)
    FSolved:=true;
    for k:=1 to 3 do
      for p:=1 to 3 do
        for i:=1 to 3 do
          for j:=1 to 3 do
            begin
              for n:=1 to 9 do
                if MBSet[k,p][i,j]=[n] then begin
                                              SMas[k,p][i,j]:=n;
                                              FSolved:=false;
                                            end;
            end;

  //UNTIL FSolved;// and SCheck(SMas,false);
  end;



procedure SPrintMSets;                    //                                              (Печать судоку посторочкая)
  var
  k,p,i,j:1..3;
  n:1..9;
  begin
    writeln;
    if FSolved then
    for k:=1 to 3 do
      begin
        for i:=1 to 3 do
          begin
            for p:=1 to 3 do
              begin
                for j:=1 to 3 do
                  begin
                    for n:=1 to 9 do
                    if n in MBSet[k,p][i,j] then write(n,' ');
                    if MBSet[k,p][i,j]<>[] then writeln;
                  end;
                for j:=1 to 3 do
                if MBSet[k,p][i,j]<>[] then begin
                                              writeln;
                                              break;
                                            end;
              end;
          end;
      end;
  end;

begin
  repeat
    writeln('Choose:');
    writeln('1-Keyboard insert');
    writeln('2-Load from file');
    writeln('3-Print sudoku');
    writeln('4-Quick solution');
    writeln('5-Deep solution');
    writeln('6-Print massive of pissible solutions');
    writeln('0-Quit');
    write('Choice: ');
    TRY
    readln(choice);
    EXCEPT
    END;
    case choice of
      1:  SInsert;
      2:  SLoad;
      3:  SPrint(MBlock);
      4:  SSearPossNums(MBlock);
      5:  STransMSets(MBlock);
      6:  SPrintMSets;
    end;
    writeln;
  until choice=0;
end.

Файл с входными данными прилагаю.
Программа сырая, но я помощи прошу не с алгоритмом, а с логикой работы написанного выше.
Программа работает следующим образом.
1. Выбираем пункт меню "2", пишем имя файла "e2"
2. Выбираем пункт меню "4".
3. Выбираем пунтк меню "5".
Проблема с переменными процедуры STransMSets(var SMas:TMBlock).
Перед запуском ставим брейкпоинт на первой строке исполнительного блока процедуры.
Пошаговая отладка показала, что в блоке


FRo:=true;
    for k:=1 to 3 do
      for i:=1 to 3 do
          for p:=1 to 3 do
            for j:=1 to 3 do
              if MBSet[k,p][i,j]<>[] then
                begin
                  _Set:=MBSet[k,p][i,j];
//                  for n:=1 to 9 do
//                    if [n]=_Set then Fl:=false else Fl:=true;
                  for ex1:=1 to 3 do
                    for ex2:=1 to 3 do
                      if (ex1<>p) and (ex2<>j) then _Set:=_Set-MBSet[k,ex1][i,ex2];
                  for n:=1 to 9 do
                    if [n]=_Set then  begin
                                        MBSet[k,p][i,j]:=_Set;
//                                        if Fl then FRo:=false;
                                      end;
                end;

первое значение переменных i, k=3, MBSet[k,p][i,j]=[], но после строки _Set:=MBSet[k,p][i,j] множество _Set не равно [].

Компилировал под Delphi 7, Delphi 7.3, Delphi 2009. Проблема остается. Думал уже переписать код под FreePascal. Очевидно, что это не приведет к решению проблемы.
Думается мне, что проблемы с памятью. Но почему так происходит? И как можно узнать, что на самом деле происходит? С языком ассемблера не дружу.

volvo

10.08.2010 10:04

Добавь перед началом процедуры STransMSets директиву
{$OPTIMIZATION OFF} и попробуй прогнать программу еще раз.

P.S. Тебе не показалось странным то, о чем ты говоришь вообще? Строка

Цитата

_Set:=MBSet[k,p][i,j];

должна выполняться только в том случае, если MBSet[k,p][i,j] <> [], а ты утверждаешь, что оно у тебя как раз пустое перед присвоением в _Set... Отсюда и вывод - либо оптимизатор что-то там переоптимизировал со множествами (были такие случаи еще в D2006), либо Watch просто показывает неправильные значения переменных. Сначала действуем по варианту №1 - отключаем оптимизатор.

sheka

10.08.2010 10:37

Точно говорить не могу, но, по моему, не всегда существует ситуация, когда есть клетка, в которую можно однозначно вставить какую-то цифру. Например, такая ситуация: на одной горизонтали в одну клетку можно поставить 1 и 2, и в другую 1 и 2. и только когда ты подставишь один из вариантов и пойдешь решать дальше, можно понять правильность твоего выбора. Решать не далеко, на несколько ходов вперед.
Еще раз повторяю, что это всего лишь мои догадки, т.к. возникали иногда такие ситуации при ручном решении.

Цитата

я помощи прошу не с алгоритмом

Офф:

Мой вариант решения (Показать/Скрыть)

type
  TMatr = array [1..9,1..9] of integer; //сама матрица
  TBool = array [1..9,1..9] of boolean; //заполнена ли клетка по условию

procedure obmen(var m : TMatr; mn : TBool);
var
  i, j : byte;
  b : boolean;
  di, dj : byte;
begin
  i := 0;
  while i<9 do
    begin
      inc(i);
      j := 0;
      while j<9 do
        begin
          inc(j);
          if not mn[i,j] then
            begin
              repeat
                b := false;
                if not b then
                  for dj := 1 to 9 do
                    if (dj<>j) and (not b) and (m[i,j] = m[i,dj]) then
                      b := true;
                if not b then
                  for di := 1 to 9 do
                    if (di<>i) and (not b) and (m[i,j] = m[di,j]) then
                      b := true;
                if not b then
                  for di := 3*((i-1)div 3)+1 to 3*((i-1)div 3)+3 do
                    for dj := 3*((j-1)div 3)+1 to 3*((j-1)div 3)+3 do
                      if (not ((dj=j)and(di=i))) and (not b) and (m[i,j] = m[di,dj]) then
                        b := true;
                if (m[i,j]=0) then
                  b := true;
                if b then
                  inc(m[i,j]);
              until (not b) or (m[i,j]=10);
              if m[i,j] = 10 then
                begin
                  repeat
                    m[i,j]:=0;
                    repeat
                      dec(j);
                      if j = 0 then
                        begin
                          j := 9;
                          dec(i);
                        end;
                    until not mn[i,j];
                    inc(m[i,j]);
                  until m[i,j]<10;
                  dec(j);
                  if j = 0 then
                    begin
                      j := 9;
                      dec(i);
                    end;
                end;
            end;
        end;
    end;
end;

Sozialist

10.08.2010 13:29

volvo
Премного благодарен. Оптимизатор действительно слажал

Жирный плюс к репутации. Тему пока не закрывай.

sheka
Не совсем понял, к чему твой пост. Оффтоп, конечно.

По алгоритму вопросов у меня нет.

Да, несомненно, существуют циклические перестановки в решении судоку. Это случай множественного решения задачи судоку. Но это никак не пойдет в разрез с моим алгоритмом. В остальном же все решается последовательно, без предположений с последующим оправданием решения или его опровержением. Работа еще не доделана. Тем не менее, спасибо.

Sozialist

15.08.2010 21:43

Тему можно закрыть. Откликнувшимся спасибо.

Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.