Source file: /~heha/hs/dos/rsd.zip/RSD.PAS

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.