Source file: /~heha/hs/sd.zip/SD.PAS

program sd;	{Sûdoku - Zahlengift}
{Simples Programm zur Lösung von neumodischen Zahlenrätseln
 namentlich japanischen Ursprungs, #04/06
 Als Eingabe dient eine Textdatei aus 9 Zeilen und 9 Spalten,
 Ziffern '1' bis '9' - sowie beliebige Zeichen für Leerfelder.
 Eine Laufzeitoptimierung scheint für meinen '266er nicht
 notwendig zu sein -
 im Gegensatz zum ähnlichen Zahlenrätselprogramm ZR.PAS.}

uses WinDos,Strings;

var
 Arr: array[1..9] of String[9];	{Repräsentation des Zahlenfeldes}
 Loes: Integer;			{Nummer der Lösung}
 Diag: Boolean;			{Diagonal-Sudoku}

function FreiesFeld(var x,y: Integer):Boolean;
{Sucht ausgehend von <x,y> das nächste Leerzeichen, FALSE wenn keins vorh.}
 begin
  FreiesFeld:=true;
  repeat
   repeat
    if Arr[y,x]=' ' then exit;
    Inc(x);
   until x>9;
   x:=1;
   Inc(y);
  until y>9;
  FreiesFeld:=false;
 end;

procedure Probiere(x,y:Integer; z:Char); forward;

procedure Huebsch;
 var
  x,y: Integer;
 begin
  WriteLn('╔═╤═╤═╦═╤═╤═╦═╤═╤═╗');
  for y:=1 to 9 do begin
   Write('║');
   for x:=1 to 9 do begin
    Write(Arr[y,x]);
    if x mod 3 = 0 then Write('║')
    else Write('│');
   end;
   WriteLn;
   if y = 9 then Write('╚═╧═╧═╩═╧═╧═╩═╧═╧═╝')
   else if y mod 3 = 0 then Write('╠═╪═╪═╬═╪═╪═╬═╪═╪═╣')
   else Write('╟─┼─┼─╫─┼─┼─╫─┼─┼─╢');
   WriteLn;
  end;
 end;

procedure Ausgabe;
 begin
  Inc(Loes);
  WriteLn(Loes, '. gefundene Lösung:');
  Huebsch;
 end;

procedure Suche(x,y:Integer);
 var
  z: Char;
 begin
  if FreiesFeld(x,y) then begin
   for z:='1' to '9' do Probiere(x,y,z);
  end else begin
   Ausgabe;
  end;
 end;

procedure Probiere(x,y:Integer; z:Char);
 var
  i,j,xx,yy: Integer;
 begin
{Zeile auf Dubletten prüfen}
  for i:=1 to 9 do if Arr[y][i]=z then exit;
{Spalte auf Dubletten prüfen}
  for i:=1 to 9 do if Arr[i][x]=z then exit;
{Kasten (3x3) prüfen}
  xx:=(x-1) div 3 *3;
  yy:=(y-1) div 3 *3;
  for i:=1 to 3 do for j:=1 to 3 do if Arr[yy+j][xx+i]=z then exit;
  if Diag then begin
{Hauptdiagonale prüfen}
   if x=y then begin
    for i:=1 to 9 do if Arr[i][i]=z then exit;
   end;
{Nebendiagonale prüfen}
   if x=10-y then begin
    for i:=1 to 9 do if Arr[i][10-i]=z then exit;
   end;
  end;
{Zahl einsetzen}
  Arr[y][x]:=z;
{Rekursion}
  Suche(x,y);
  Arr[y,x]:=' ';
 end;

var
 f: Text;
 i,j: Integer;

 Path: array[0..fsPathName] of Char;
 E: array[0..fsExtension] of Char;
begin
 GetArgStr(Path,1,fsPathName);
 FileSplit(Path,nil,nil,E);
 Diag:=StrIComp(E,'.dsd')=0;
 Assign(f,Path); Reset(f);
 for i:=1 to 9 do begin
  ReadLn(f,Arr[i]);
  Arr[i][0]:=#9;
  for j:=1 to 9 do if not (Arr[i,j] in ['1'..'9']) then Arr[i,j]:=' ';
 end;
 Close(f);
 WriteLn('Kontrollausgabe der Eingabedaten:');
 Huebsch;
 Suche(1,1);
end.