program rsd; {Relations-Sûdoku}
{Gegeben sind hier Relationszeichen zwischen (leeren) Feldern, #09/06
Als Eingabe dient eine Textdatei aus 17 Zeilen und 17 Spalten,
}
type
TZeile=array[0..8] of Char;
var
Arr: array[0..8] of TZeile; {Repräsentation des Zahlenfeldes}
RelR: array[0..8] of TZeile; {Relationszeichen nach rechts}
RelU: array[0..8] of TZeile; {Relationszeichen nach unten}
Loes: Integer; {Nummer der Lösung}
Tick: Word absolute $40:$6C; {BIOS-Uhr}
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>8;
x:=0;
Inc(y);
until y>8;
FreiesFeld:=false;
end;
procedure Probiere(x,y:Integer; z:Char); forward;
procedure Huebsch;
var
x,y: Integer;
procedure ZwischenZeile(z1,z2,z3,z4,z5:Char);
var
x: Integer;
begin
Write(z1);
for x:=0 to 8 do begin
if (y<8) and (RelU[y,x] in ['^','v']) then Write(RelU[y,x])
else Write(z2);
if x<>8 then begin
if x mod 3 = 2 then Write(z4)
else Write(z3);
end;
end;
WriteLn(z5);
end;
begin
y:=8;
ZwischenZeile('╔','═','╤','╦','╗');
for y:=0 to 8 do begin
Write('║');
for x:=0 to 8 do begin
Write(Arr[y,x]);
if (x<8) and (RelR[y,x] in ['<','>']) then Write(RelR[y,x])
else if x mod 3 = 2 then Write('║')
else Write('│');
end;
WriteLn;
if y = 8 then ZwischenZeile('╚','═','╧','╩','╝')
else if y mod 3 = 2 then ZwischenZeile('╠','═','╪','╬','╣')
else ZwischenZeile('╟','─','┼','╫','╢');
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
{Relation nach links prüfen (sofern gegeben)}
if x<>0 then case RelR[y,x-1] of
'>': if Arr[y,x-1]<=z then exit;
'<': if Arr[y,x-1]>=z then exit;
end;
{Relation nach oben prüfen}
if y<>0 then case RelU[y-1,x] of
'v': if Arr[y-1,x]<=z then exit;
'^': if Arr[y-1,x]>=z then exit;
end;
{Relationen nach rechts und unten müssen nur bei vorgegebenen Zahlen
abgeprüft werden; dieser Fall sei nicht vorkommend angenommen!}
{Zeile auf Dubletten prüfen}
for i:=0 to 8 do if Arr[y][i]=z then exit;
{Spalte auf Dubletten prüfen}
for i:=0 to 8 do if Arr[i][x]=z then exit;
{Kasten (3x3) prüfen}
xx:=x div 3 *3;
yy:=y div 3 *3;
for i:=0 to 2 do for j:=0 to 2 do if Arr[yy+j][xx+i]=z then exit;
{Zahl einsetzen}
Arr[y][x]:=z;
{Rekursion}
Suche(x,y);
Arr[y,x]:=' ';
end;
var
f: Text;
i,j: Integer;
s: array[0..32] of Char;
StartTick: Word;
begin
Assign(f,ParamStr(1)); Reset(f);
for i:=0 to 8 do begin
ReadLn(f,s); {Zeile mit (Zahlen und) horizontalen Relationszeichen}
for j:=0 to 8 do begin
Arr[i,j]:=s[j*2]; {Zahlzeichen übernehmen}
if not (Arr[i,j] in ['1'..'9']) then Arr[i,j]:=' ';
if j<8 then RelR[i,j]:=s[j*2+1]; {Relationszeichen übernehmen}
end;
if i<8 then begin
ReadLn(f,s); {Zeile mit vertikalen Relationszeichen}
for j:=0 to 8 do begin
RelU[i,j]:=s[j*2]; {Relationszeichen übernehmen}
end;
end;
end;
Close(f);
for i:=0 to 7 do begin
for j:=0 to 7 do begin
{Vorgabezahlen und Relationen prüfen}
if (Arr[i,j]<>' ') and (Arr[i,j+1]<>' ') then case RelR[i,j] of
'<': if Arr[i,j]>=Arr[i,j+1] then WriteLn('Fehler1(',j,',',i,')');
'>': if Arr[i,j]<=Arr[i,j+1] then WriteLn('Fehler2(',j,',',i,')');
end;
if (Arr[i,j]<>' ') and (Arr[i+1,j]<>' ') then case RelU[i,j] of
'^': if Arr[i,j]>=Arr[i+1,j] then WriteLn('Fehler3(',j,',',i,')');
'v': if Arr[i,j]<=Arr[i+1,j] then WriteLn('Fehler4(',j,',',i,')');
end;
end;
end;
{DEBUG}
{ for i:=0 to 8 do for j:=0 to 8 do Arr[i,j]:=' ';}
WriteLn('Kontrollausgabe der Eingabedaten:');
Huebsch;
StartTick:=Tick;
Suche(0,0);
WriteLn(Loes,' Lösungen in ca. ',(Tick-StartTick+9) div 18,' Sekunden');
end.
Vorgefundene Kodierung: OEM (CP437) | 1
|
|