Возможно ли написать программу для решения Судоку?

uses
  CRT;
 
const
  N=9;
  M=3;
 
type
  tCell=0..N;
  tBoard=array[1..N,1..N] of tCell;
  tList=set of tCell;
 
var
  Board:tBoard;
 
const
  Lev:integer=0;
  t:LongInt=0;
  Stop:boolean=true;
 
procedure ShowBoard(Brd:tBoard; k,l:tCell; t:LongInt);
var
  i,j,Bac:integer;
begin
  for i:=0 to N+1 do begin
    for j:=0 to N+1 do begin
      if i*j*(i-N-1)*(j-N-1)=0 then begin
        TextBackGround(7);Write('  ');
        if (t<>0)and(i=0)and(j=N+1) then begin
          TextColor(7); TextBackGround(0);
          Write(' Solution ',t);
        end
      end
      else begin
        if Odd(Pred(i) div M+Pred(j) div M) then Bac:=0 else Bac:=1;
        TextColor(7);TextBackGround(Bac);
        if Brd[i,j]=0 then Write('  ') else begin
          Write(' ');
          if (i=k)and(j=l) then begin
            TextColor(15);TextBackGround(5);Write(Brd[i,j]);
          end
          else Write(Brd[i,j])
        end
      end
    end;
    TextBackGround(0);
    WriteLn
  end;
  WriteLn;
  if KeyPressed or Stop then case ReadKey of
    #27:Halt;
    ' ':Stop:=not Stop
  end
end;
 
procedure ReadBoard(FNam:string);
var
  i,j:integer;
  s:string;
  f:text;
begin
  Assign(f,FNam);ReSet(f);
  for i:=1 to N do begin
    ReadLn(f,s);
    for j:=1 to N do if j<=Length(s) then case s[j] of
      '0'..'9':Board[i,j]:=Byte(s[j])-48;
      else Board[i,j]:=0
    end
    else Board[i,j]:=0
  end;
  Close(f)
end;
 
function Solve(Brd:tBoard):boolean;
var
  a,b,c, i,j, Mi,Mj, Total,TotalMax:integer;
  Sol,NoWay,Done,Mult:boolean;
  List,MList:tList;
 
  procedure Cross(i,j:integer);
  var
    k,l:integer;
 
    procedure FillList(Cell:tCell);
    begin
      if not (Cell in List) then begin
        List:=List+[Cell];
        Inc(Total);
        NoWay:=NoWay or(Total=9);
      end
    end;
 
  begin
    for k:=1 to N do begin
      FillList(Brd[k,j]);
      FillList(Brd[i,k]);
    end;
    for k:=Succ(a) to a+M do for l:=Succ(b) to b+M do FillList(Brd[k,l]);
  end;
 
begin
  Inc(Lev);
  Sol:=false;
  NoWay:=false;
  repeat
    Mult:=true;
    Done:=true;
    TotalMax:=0;
    for i:=1 to N do for j:=1 to N do if Brd[i,j]=0 then begin
      Done:=false;
      a:=Pred(i) div M*M;
      b:=Pred(j) div M*M;
      Total:=0;
      List:=[0];
      Cross(i,j);
      if Total=8 then begin
        c:=1;
        while c in List do c:=c+1;
        Brd[i,j]:=c;
        Mult:=false;
{        ShowBoard(Brd,i,j,0)}
      end
      else if Total>TotalMax then begin
        TotalMax:=Total;
        Mi:=i;Mj:=j;
        MList:=List
      end
    end;
  until Mult or Done or NoWay;
  if NoWay then Solve:=false
  else if Done then begin
    Solve:=true;
    Inc(t);
    ShowBoard(Brd,0,0,t)
  end
  else for i:=1 to N do if not(i in MList) then begin
    Brd[Mi,Mj]:=i;
    Sol:=Solve(Brd) or Sol;
    Solve:=Sol
  end;
  Dec(Lev)
end;
 
begin
  ReadBoard('sudoku.dat');
  ShowBoard(Board,0,0,0);
  if Solve(Board) then WriteLn('Done.') else WriteLn('No Way!');
  ReadLn
end.