Math Is Fun Forum

program Sudoku_solver;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes
  { you can add units after this };

{$IFDEF WINDOWS}{$R Sudoku.rc}{$ENDIF}

const
  max=9;

type
  niz=array[1..max] of integer;
  matrica=array[1..max] of niz;

var
  a:matrica;
  i,j,k:integer;
  ok:boolean;

function red(a:matrica;i1,j1:integer):boolean;
var
  j:integer;
  b:boolean;
begin
  b:=true;
  j:=1;
  while (j<=max) and (b=true) do
  begin
    if j<>j1 then
      if a[i1][j]=a[i1][j1] then
        b:=false;
    j:=j+1;
  end;
  red:=b;
end;

function kolona(a:matrica;i1,j1:integer):boolean;
var
  i:integer;
  b:boolean;
begin
  b:=true;
  i:=1;
  while (i<=max) and (b=true) do
  begin
    if i<>i1 then
      if a[i][j1]=a[i1][j1] then
        b:=false;
    i:=i+1;
  end;
  kolona:=b;
end;

function kvadrat(a:matrica;i1,j1:integer):boolean;
var
  i,j,k,l:integer;
  b:boolean;
begin
  b:=true;
  case i1 of
    1,2,3: begin
             k:=1;
             i:=3;
           end;
    4,5,6: begin
             k:=4;
             i:=6;
           end;
    7,8,9: begin
             k:=7;
             i:=9;
           end;
  end;
  while (k<=i) and (b=true) do
  begin
    case j1 of
    1,2,3: begin
             l:=1;
             j:=3;
           end;
    4,5,6: begin
             l:=4;
             j:=6;
           end;
    7,8,9: begin
             l:=7;
             j:=9;
           end;
    end;
    while (l<=j) and (b=true) do
    begin
      if (k<>i1) or (l<>j1) then
        if a[k][l]=a[i1][j1] then
          b:=false;
      l:=l+1;
    end;
    k:=k+1;
  end;
  kvadrat:=b;
end;

function poz(a:matrica;i,j:integer):boolean;
begin
  poz:=red(a,i,j) and kolona(a,i,j) and kvadrat(a,i,j);
end;

procedure sudoku(var a:matrica;n,i1,j1:integer;var ok:boolean);
var
  i,j,k:integer;
  b:boolean;
begin
  i:=i1;
  j:=j1;
  a[i][j]:=n;
  ok:=false;
  if poz(a,i,j) then
  begin
    ok:=true;
    i:=1;
    b:=true;
    while (b=true) and (i<=max) do
    begin
      j:=1;
      while (b=true) and (j<=max) do
      begin
        writeln(i);
        writeln(j);
        if a[i][j]=0 then
          b:=false
        else j:=j+1;
      end;
      if b=true then
        i:=i+1;
    end;
    if b=false then
    begin
      k:=1;
      ok:=false;
      while (k<=max) and not ok do
      begin
        sudoku(a,k,i,j,ok);
        k:=k+1;
      end;
    end;
  end;
end;

begin
  writeln('Unesite sudoku: ');
  for i:=1 to 9 do
  begin
    for j:=1 to 9 do
      read(a[i][j]);
    readln;
  end;
  for i:=1 to 9 do
  begin
    for j:=1 to 9 do
      write(a[i][j],' ');
    writeln;
  end;
  k:=0;
  ok:=false;
  while (k<=9) and not ok do
  begin
    k:=k+1;
    sudoku(a,k,1,1,ok);
  end;
  if ok then
  begin
    writeln('Resenje je: ');
    for i:=1 to 9 do
    begin
      for j:=1 to 9 do
        write(a[i][j],' ');
      writeln;
    end;
  end
  else writeln('Sudoku se ne moze resiti!!!');
  readln;
end.