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.
Vorgefundene Kodierung: OEM (CP437) | 1
|
|