diff options
Diffstat (limited to 'SlitherlinkUnit.pas')
| -rw-r--r-- | SlitherlinkUnit.pas | 1548 |
1 files changed, 1548 insertions, 0 deletions
diff --git a/SlitherlinkUnit.pas b/SlitherlinkUnit.pas new file mode 100644 index 0000000..6395e36 --- /dev/null +++ b/SlitherlinkUnit.pas @@ -0,0 +1,1548 @@ +unit SlitherlinkUnit;
+
+{ $DEFINE norandomize}
+{$DEFINE preSchleifenTest}
+{$DEFINE vorLoesen}
+{$DEFINE SchleifenFrueherkennung}
+
+interface
+
+uses
+{$IFDEF debug}
+Dialogs,
+{$ENDIF}
+ExtCtrls, Controls, Sysutils, Math, Graphics, Classes, ComCtrls, Types,
+RaetselFileUnit;
+
+type
+ TPerm = array of Integer;
+ TOptionen = class
+ private
+ function rA: integer;
+ function rKantenfarbe(Kante: integer; SKante,lokOK,OK: boolean): TColor;
+ public
+ Schriftgroesse: integer;
+ errFarbe,OKFarbe,
+ sFarbe: array[boolean] of TColor;
+ KFarbe: array[-1..1] of TColor;
+ property A: integer read rA;
+ property Kantenfarbe[Kante: integer; SKante,lokOK,OK: boolean]: TColor read rKantenfarbe;
+ constructor create;
+ destructor destroy; override;
+ end;
+ TFeld = class
+ private
+ {$IFDEF debug}
+ zaehler,tiefe: Integer;
+ ErzeugungsVersuche: Integer;
+ t0,t1,t2,t3,t4: extended;
+ {$IFDEF vorLoesen}
+ tvorloesen,tnachloesen: extended;
+ {$ENDIF}
+ {$ENDIF}
+ _Schleife: Boolean;
+ Wohin: TImage;
+ _oben,_links: integer;
+ lmx,lmy: integer;
+ _Breite,_Hoehe: integer; // in Feldern
+ _Parent: TWinControl;
+ _rlSchritt, // Knoten->Knoten
+ _rlKante, // Knoten->Kante
+ _rlFeld, // Knoten->Feld
+ _rlFKante: array[0..3] of Integer; // Feld->Kante (für rekursivLoesen)
+ _KantenPerm,
+ _FelderPerm: TPerm;
+ Geschichte: array of TPoint;
+ {$IFDEF preSchleifenTest}
+ Zusammenhang: array of integer; // Zusammenhangskomponentenzugehörigkeit der Kanten (für rekursivLoesen)
+ {$ENDIF}
+ {$IFDEF vorLoesen}
+ _vlKanten: array of integer; // Kantenmerker für vorLoesen (und nachLoesen)
+ {$ENDIF}
+ procedure wOben(O: integer);
+ procedure wLinks(L: integer);
+ procedure wBreite(B: integer);
+ procedure wHoehe(H: integer);
+ function zBreite: integer;
+ function zHoehe: integer;
+ procedure FKinitialisieren;
+ procedure WohinMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure WohinMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
+ procedure FelderErzeugen;
+ function ersteFreieKante: integer;
+ procedure LoesungInitialisieren;
+ {$IFDEF preSchleifenTest}
+ procedure ZusammenhangInitialisieren;
+ {$ENDIF}
+ function rekursivLoesen(Knoten: integer; LoesungBehalten,EndeBeiEins,warKante: boolean): integer;
+ function allesOkay: boolean;
+ function FelderOkay: boolean;
+ function FeldOkay(i: integer): boolean;
+ function KanteOkay(i: integer): boolean;
+ procedure PermErzeugen(n: integer; var Perm: TPerm);
+ procedure kantenPermErzeugen;
+ procedure felderPermErzeugen; // verwendet Magie
+ function rKannRueckGaengig: boolean;
+ function Schlaufe: Integer; // 0 = nein, 1 = ja, 2 = schön
+ {$IFDEF preSchleifenTest}
+ function inZusammenhangKomp(Knoten: Integer): integer; // In welcher Zshg.-Komponente liegt der Knoten?
+ {$ENDIF}
+ {$IFDEF vorLoesen}
+ procedure vorLoesen(var sKn,SRtg: integer);
+ procedure nachLoesen;
+ {$ENDIF}
+ procedure wSchleife(S: boolean);
+ function FesteKante(I: Integer): integer; // 0=nein; 1=fest weg; 2=fest da
+ function FestesFeld(I: Integer): boolean;
+ procedure inDieserSituationTutMan(I: Integer);
+ public
+ Felder: array of Integer; // -1 = leer
+ Kanten: array of Integer; // -1 = leer, 0 = weg, 1 = da
+ SKanten: array of Boolean;
+ Lerndatei: String;
+ Optionen: TOptionen;
+ property Breite: Integer read _Breite
+ write wBreite;
+ property Hoehe: Integer read _Hoehe
+ write wHoehe;
+ property oben: Integer read _oben
+ write wOben;
+ property links: Integer read _links
+ write wLinks;
+ property Schleife: Boolean read _Schleife
+ write wSchleife;
+ property kannRueckGaengig: boolean read rKannRueckGaengig;
+ constructor create(Parent: TWinControl);
+ destructor destroy; override;
+ procedure Loesen;
+ procedure Leeren(PB: TProgressbar);
+ procedure Erzeugen(PB: TProgressbar); overload;
+ procedure Erzeugen(PB: TProgressbar; vorheriges_lassen: boolean); overload;
+ procedure Zeichnen(hacked: boolean); overload;
+ procedure Zeichnen; overload;
+ function printto(C: TCanvas): TPoint; overload;
+ function printto(C: TCanvas; hacked: boolean): TPoint; overload;
+ procedure SaveToFile(Filename: String);
+ function LoadFromFile(Filename: String): boolean;
+ procedure LoadFromFeld(F: TFeld);
+ procedure RueckGaengig;
+ procedure HackIt;
+ procedure OnKeyPress(Sender: TObject; var Key: Char);
+ end;
+ TGenerierungsthread = class(TThread)
+ private
+ public
+ Fertig: Integer;
+ Feld: TFeld;
+ Starttime: extended;
+ PB: TProgressbar;
+ constructor create(breite, hoehe: integer; Progressbar: TProgressbar; Parent: TWinControl; Schleife: boolean);
+ destructor destroy; override;
+ procedure execute; override;
+ end;
+
+implementation
+
+constructor TOptionen.create;
+begin
+ inherited create;
+ Schriftgroesse:=15;
+ OKFarbe[false]:=$FFFFFF;
+ OKFarbe[true]:=$008000;
+ errFarbe[false]:=$DFDFFF;
+ errFarbe[true]:=$000080;
+ sFarbe[false]:=$FFD0D0;
+ sFarbe[true]:=$800000;
+ KFarbe[-1]:=$D0D0D0;
+ KFarbe[0]:=$FFFFFF;
+ KFarbe[1]:=$000000;
+end;
+
+destructor TOptionen.destroy;
+begin
+ inherited destroy;
+end;
+
+function TOptionen.rKantenfarbe(Kante: integer; SKante,lokOK,OK: boolean): TColor;
+begin
+ if Kante=-1 then
+ begin
+ Result:=KFarbe[Max(Min(1,Kante),-1)];
+ exit;
+ end;
+ if OK then
+ begin
+ result:=OKFarbe[Kante=1];
+ exit;
+ end;
+ if not lokOK then
+ begin
+ result:=errFarbe[Kante=1];
+ exit;
+ end;
+ if SKante then
+ begin
+ result:=sFarbe[Kante=1];
+ exit;
+ end;
+ Result:=KFarbe[Max(Min(1,Kante),-1)];
+end;
+
+function TOptionen.rA: Integer;
+begin
+ result:=round(2.5*schriftgroesse);
+end;
+
+// ****************************************************************************
+
+constructor TFeld.create(Parent: TWinControl);
+begin
+ inherited create;
+ Lerndatei:='';
+ Wohin:=TImage.create(Parent);
+ Wohin.Parent:=Parent;
+ Wohin.OnMouseUp:=@WohinMouseUp;
+ Wohin.OnMouseMove:=@WohinMouseMove;
+ _Parent:=Parent;
+ Optionen:=TOptionen.create;
+ Setlength(Geschichte,0);
+ Links:=0;
+ Oben:=0;
+ Breite:=5;
+ Hoehe:=5;
+end;
+
+destructor TFeld.destroy;
+begin
+ Optionen.destroy;
+ inherited destroy;
+end;
+
+procedure TFeld.wOben(O: integer);
+begin
+ _oben:=O;
+ Wohin.Top:=O;
+end;
+
+procedure TFeld.wLinks(L: integer);
+begin
+ _links:=L;
+ Wohin.Left:=L;
+end;
+
+procedure TFeld.wBreite(B: integer);
+begin
+ if _Breite=B+byte(not _Schleife) then exit;
+ _Breite:=B+byte(not _Schleife);
+ FKinitialisieren;
+end;
+
+procedure TFeld.wHoehe(H: integer);
+begin
+ if _Hoehe=H+byte(not _Schleife) then exit;
+ _Hoehe:=H+byte(not _Schleife);
+ FKinitialisieren;
+end;
+
+function TFeld.zBreite: integer;
+begin
+ result:=Breite-byte(not Schleife);
+end;
+
+function TFeld.zHoehe: integer;
+begin
+ result:=Hoehe-byte(not Schleife);
+end;
+
+procedure TFeld.FKinitialisieren;
+var I: Integer;
+begin
+ Setlength(Felder,max(0,Hoehe*(Breite+1)-1));
+ Setlength(Kanten,2*(length(Felder)-1)+2*Breite+4);
+ Setlength(SKanten,length(Kanten));
+ For I:=0 to length(Felder)-1 do
+ if (I+1) mod (Breite+1) <> 0 then Felder[I]:=-1
+ else Felder[I]:=-2;
+ For I:=0 to length(Kanten)-1 do
+ begin
+ if (odd(I+1) and (I<2*Hoehe*(Breite+1))) or
+ (odd(I) and ((I+1) mod (2*(Breite+1))<>0)) then
+ Kanten[I]:=-1
+ else
+ Kanten[I]:=-2;
+ SKanten[I]:=festeKante(I)>=0;
+ if SKanten[I] then
+ Kanten[I]:=festeKante(I);
+ end;
+ Setlength(Geschichte,0);
+end;
+
+procedure TFeld.Zeichnen;
+begin
+ Zeichnen(false);
+end;
+
+function TFeld.printto(C: TCanvas): TPoint;
+begin
+ Result:=printto(C,false);
+end;
+
+function TFeld.printto(C: TCanvas; hacked: boolean): TPoint;
+var I: Integer;
+begin
+ Result.X:=(zBreite+2)*Optionen.A+1;
+ Result.Y:=(zHoehe+2)*Optionen.A+1;
+ C.Font.Size:=Optionen.Schriftgroesse;
+ For I:=0 to length(Felder)-1 do
+ if (Felder[I]>=0) and not festesFeld(I) then
+ begin
+ C.Font.Color:=Optionen.KantenFarbe[1,false,FeldOkay(I),AllesOkay];
+ C.TextOut(
+ round((I mod (Breite+1) + 1.5)*Optionen.A - 0.5*C.TextWidth(inttostr(Felder[I]))),
+ round((I div (Breite+1) - byte(not Schleife) + 1.5)*Optionen.A - 0.5*C.TextHeight(inttostr(Felder[I]))),
+ inttostr(Felder[I]));
+ end;
+ C.Pen.Width:=3;
+ For I:=0 to length(Kanten)-1 do
+ if (Kanten[I]<>-2) and (festeKante(I)<0) then
+ begin
+ C.Pen.Color:= Optionen.KantenFarbe[Kanten[I],SKanten[I],KanteOkay(I),AllesOkay];
+ if odd(I) then
+ begin
+ C.MoveTo(
+ ((I div 2) mod (Breite+1) +1)*Optionen.A,
+ ((I div 2) div (Breite+1) - byte(not Schleife) +1)*Optionen.A);
+ C.LineTo(
+ ((I div 2) mod (Breite+1) +2)*Optionen.A,
+ ((I div 2) div (Breite+1) - byte(not Schleife) +1)*Optionen.A);
+{$IFDEF PreSchleifenTest}
+ if Hacked then
+ C.TextOut(
+ round(((I div 2) mod (Breite+1) +1.5)*Optionen.A),
+ ((I div 2) div (Breite+1) - byte(not Schleife) +1)*Optionen.A,
+ inttostr(Zusammenhang[I]));
+{$ENDIF}
+ end
+ else
+ begin
+ C.MoveTo(
+ ((I div 2) mod (Breite+1) +1)*Optionen.A,
+ ((I div 2) div (Breite+1) - byte(not Schleife) +1)*Optionen.A);
+ C.LineTo(
+ ((I div 2) mod (Breite+1) +1)*Optionen.A,
+ ((I div 2) div (Breite+1) - byte(not Schleife) +2)*Optionen.A);
+{$IFDEF PreSchleifenTest}
+ if Hacked then
+ C.TextOut(
+ ((I div 2) mod (Breite+1) +1)*Optionen.A,
+ round(((I div 2) div (Breite+1) - byte(not Schleife) +1.5)*Optionen.A),
+ inttostr(Zusammenhang[I]));
+{$ENDIF}
+ end;
+ end;
+ if not schleife then
+ begin
+ C.Pen.Color:=$000000;
+ C.Ellipse(Optionen.A-3,Optionen.A-3,Optionen.A+4,Optionen.A+4);
+ C.Ellipse(Breite*Optionen.A-3,Hoehe*Optionen.A-3,Breite*Optionen.A+4,Hoehe*Optionen.A+4);
+ end;
+end;
+
+procedure TFeld.Zeichnen(hacked: boolean);
+begin
+ Wohin.Destroy;
+ Wohin:=TImage.Create(_Parent);
+ Wohin.Parent:=_Parent;
+ Wohin.OnMouseUp:=@WohinMouseUp;
+ Wohin.OnMouseMove:=@WohinMouseMove;
+ Wohin.Left:=_Links;
+ Wohin.Top:=_Oben;
+ Wohin.Width:=(zBreite+2)*Optionen.A+1;
+ Wohin.Height:=(zHoehe+2)*Optionen.A+1;
+ Wohin.Canvas.Rectangle(-10,-10,Wohin.Width+10,Wohin.Height+10);
+ printto(Wohin.Canvas,hacked);
+end;
+
+procedure TFeld.WohinMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+var I: Integer;
+const neuWert: array[-1..1,boolean] of integer = ((0,1),(0,-1),(-1,1));
+begin
+ Y:=Y+Optionen.A*Byte(not Schleife);
+ if (2*X<Optionen.A) or
+ (2*Y<Optionen.A) or
+ (2*X>(2*Breite+3)*Optionen.A) or
+ (2*Y>(2*Hoehe+3)*Optionen.A) then
+ exit;
+ I:=2*((X div Optionen.A-1)+(Y div Optionen.A-1)*(Breite+1));
+ X:=X mod Optionen.A;
+ Y:=Y mod Optionen.A;
+ case 2*Byte(X+Y<Optionen.A) + Byte(X-Y<0) of
+ 0: I:=I+2;
+ 1: I:=I+2*Breite+3;
+ 2: I:=I+1;
+ 3: ;
+ end{of Case};
+ if ((I+1) mod (2*(Breite+1))=0) or
+ ((not odd(I)) and (I>=2*Hoehe*(Breite+1))) then
+ exit;
+ if (I>=0) and (I<length(Kanten)) and (not SKanten[I]) and (neuWert[Kanten[I],Button=mbLeft]<>Kanten[I]) then
+ begin
+ setlength(Geschichte,length(Geschichte)+1);
+ Geschichte[length(Geschichte)-1].x:=I;
+ Geschichte[length(Geschichte)-1].y:=Kanten[I];
+ if neuWert[Kanten[I],Button=mbLeft]>=0 then
+ inDieserSituationTutMan(I);
+ Kanten[I]:=neuWert[Kanten[I],Button=mbLeft];
+ end;
+ Zeichnen;
+end;
+
+procedure TFeld.FelderErzeugen;
+var I: Integer;
+begin
+ For I:=0 to length(Felder)-1 do
+ if Felder[I]<>-2 then
+ Felder[I]:=byte(Kanten[2*I]=1)+
+ byte(Kanten[2*I+1]=1)+
+ byte(Kanten[2*I+2]=1)+
+ byte(Kanten[2*I+2*Breite+3]=1);
+end;
+
+function TFeld.Schlaufe: Integer;
+var I,J,N: Integer;
+ Rtg: Integer; // *pi/2
+begin
+ N:=0;
+ For I:=0 to length(Kanten)-1 do
+ if ((I+1) mod (2*(Breite+1))<>0) and
+ ((odd(I)) or (I<2*Hoehe*(Breite+1))) and
+ (Kanten[I]=1) then
+ inc(N);
+ if N=0 then
+ begin
+ Result:=1;
+ exit;
+ end;
+ For I:=0 to length(Kanten) div 2 do
+ begin
+ J:=0;
+ if 2*I-2*Breite-2>=0 then J:=J + Byte(1=Kanten[2*I-2*Breite-2]);
+ if 2*I-1>=0 then J:=J + Byte(1=Kanten[2*I-1]);
+ if 2*I<length(Kanten) then J:=J + Byte(1=Kanten[2*I]);
+ if 2*I+1<length(Kanten) then J:=J + Byte(1=Kanten[2*I+1]);
+ if not (J in [0,2]) then
+ begin
+ Result:=0;
+ exit;
+ end;
+ end;
+ J:=-1;
+ Rtg:=0;
+ For I:=0 to length(Kanten)-1 do
+ if ((I+1) mod (2*(Breite+1))<>0) and
+ ((odd(I)) or (I<2*Hoehe*(Breite+1))) and
+ (Kanten[I]=1) then
+ begin
+ Rtg:=(I+1) mod 2 + 2;
+ J:=I div 2;
+ break;
+ end;
+ I:=J;
+ repeat
+ dec(N);
+ case Rtg of
+ 0: J:=J+1;
+ 1: J:=J-Breite-1;
+ 2: J:=J-1;
+ 3: J:=J+Breite+1;
+ end{of Case};
+ if (2*J+1<length(Kanten)) and
+ (Kanten[2*J+1]=1) and
+ (Rtg <> 2) then
+ begin
+ Rtg:=0;
+ Continue;
+ end;
+ if (2*J-2*Breite-2>=0) and
+ (Kanten[2*J-2*Breite-2]=1) and
+ (Rtg <> 3) then
+ begin
+ Rtg:=1;
+ Continue;
+ end;
+ if (2*J-1>=0) and
+ (Kanten[2*J-1]=1) and
+ (Rtg <> 0) then
+ begin
+ Rtg:=2;
+ Continue;
+ end;
+ if (2*J<length(Kanten)) and
+ (Kanten[2*J]=1) and
+ (Rtg <> 1) then
+ begin
+ Rtg:=3;
+ Continue;
+ end;
+ Result:=-1;
+ exit;
+ until I=J;
+ Result:=Byte(N=0)*2;
+ if Result=2 then
+ begin
+ J:=1;
+ For I:=0 to Breite-1 do
+ if Kanten[2*I+1]=1 then J:=2;
+ Result:=(Result+J) div 2;
+ J:=1;
+ For I:=0 to Breite-1 do
+ if Kanten[2*I+1+2*Hoehe*(Breite+1)]=1 then J:=2;
+ Result:=(Result+J) div 2;
+ J:=1;
+ For I:=0 to Hoehe-1 do
+ if Kanten[2*I*(Breite+1)]=1 then J:=2;
+ Result:=(Result+J) div 2;
+ J:=1;
+ For I:=0 to Hoehe-1 do
+ if Kanten[2*I*(Breite+1)+2*Breite]=1 then J:=2;
+ Result:=(Result+J) div 2;
+ end;
+end;
+
+function TFeld.ersteFreieKante: integer;
+var I: Integer;
+begin
+ Result:=-1;
+ For I:=0 to length(Kanten)-1 do
+ if ((_KantenPerm[I]+1) mod (2*(Breite+1))<>0) and
+ ((odd(_KantenPerm[I])) or (_KantenPerm[I]<2*Hoehe*(Breite+1))) and
+ (Kanten[_KantenPerm[I]]=-1) then
+ begin
+ Result:=_KantenPerm[I];
+ exit;
+ end;
+end;
+
+{$IFDEF preSchleifenTest}
+procedure TFeld.ZusammenhangInitialisieren;
+var I,J,K,M,Rtg,V: Integer;
+ Ks: array[0..1] of Integer;
+begin
+ setlength(Zusammenhang,length(Kanten));
+ M:=-1;
+ For I:=0 to length(Kanten)-1 do
+ case Kanten[I] of
+ -2,-1,0: Zusammenhang[I]:=-1;
+ else
+ begin
+ inc(M);
+ Zusammenhang[I]:=M;
+ end;
+ end{of Case};
+ For I:=0 to length(Zusammenhang)-1 do
+ if Zusammenhang[I]<>-1 then
+ begin
+ Ks[0]:=I div 2;
+ Ks[1]:=Ks[0] + _rlSchritt[3*((I+1) mod 2)];
+ For K:=0 to 1 do
+ For Rtg:=0 to 3 do
+ if (2*Ks[K]+_rlKante[Rtg] >= 0) and
+ (2*Ks[K]+_rlKante[Rtg] < length(Kanten)) and // nicht ins leere
+ (Zusammenhang[2*Ks[K]+_rlKante[Rtg]] >= 0) and // wenn Kante vorhanden
+ (Zusammenhang[2*Ks[K]+_rlKante[Rtg]] <> Zusammenhang[I]) then // und etwas zu tun
+ begin
+ V:=Zusammenhang[2*Ks[K]+_rlKante[Rtg]];
+ For J:=0 to length(Zusammenhang)-1 do
+ begin
+ if Zusammenhang[J]=V then Zusammenhang[J]:=Zusammenhang[I];
+ if Zusammenhang[J]=M then Zusammenhang[J]:=V;
+ end;
+ dec(M);
+ end;
+ end;
+end;
+{$ENDIF}
+
+procedure TFeld.LoesungInitialisieren;
+begin
+ _rlSchritt[0]:=1;
+ _rlSchritt[1]:=-Breite-1;
+ _rlSchritt[2]:=-1;
+ _rlSchritt[3]:=Breite+1;
+ _rlKante[0]:=1;
+ _rlKante[1]:=-2*Breite-2;
+ _rlKante[2]:=-1;
+ _rlKante[3]:=0;
+ _rlFeld[0]:=-Breite-1;
+ _rlFeld[1]:=-Breite-2;
+ _rlFeld[2]:=-1;
+ _rlFeld[3]:=0;
+ _rlFKante[0]:=2;
+ _rlFKante[1]:=1;
+ _rlFKante[2]:=0;
+ _rlFKante[3]:=2*Breite+3;
+ {$IFDEF debug}
+ Zaehler:=0;
+ Tiefe:=0;
+ {$ENDIF}
+end;
+
+procedure TFeld.Loesen;
+begin
+ kantenPermErzeugen;
+ {$IFDEF preSchleifenTest}
+ ZusammenhangInitialisieren;
+ {$ENDIF}
+ LoesungInitialisieren;
+ if ersteFreieKante=-1 then exit;
+ rekursivLoesen(ersteFreieKante div 2,true,true,false);
+ // (ersteFreieKante+1) mod 2 + 2,
+end;
+
+function TFeld.rekursivLoesen(Knoten: integer; LoesungBehalten,EndeBeiEins,warKante: boolean): integer;
+var I,J,K,L,Ma,Mi: integer;
+{$IFDEF preSchleifenTest}
+ Zsave: array of integer;
+ ZusHlok: Integer;
+{$ENDIF}
+ Perm,save: array[0..3] of Integer;
+begin
+ {$IFDEF debug}
+ inc(Zaehler);
+ inc(Tiefe);
+ {$ENDIF}
+ Result:=0;
+
+ For I:=0 to 3 do // Test der umliegenden Felder auf Korrektheit
+ if (Knoten+_rlFeld[I]>=0) and
+ (Knoten+_rlFeld[I]<length(Felder)) and
+ (Felder[Knoten+_rlFeld[I]]>=0) then
+ begin
+ Mi:=0;
+ Ma:=0;
+ For J:=0 to 3 do
+ if (2*(Knoten+_rlFeld[I])+_rlFKante[J]>=0) and
+ (2*(Knoten+_rlFeld[I])+_rlFKante[J]<length(Kanten)) then
+ case Kanten[2*(Knoten+_rlFeld[I])+_rlFKante[J]] of
+ -1: inc(Ma);
+ 1:
+ begin
+ inc(Ma);
+ inc(Mi);
+ end;
+ end{of Case};
+ if (Mi>Felder[Knoten+_rlFeld[I]]) or
+ (Ma<Felder[Knoten+_rlFeld[I]]) then
+ exit;
+ end;
+
+ Mi:=0;
+ Ma:=0;
+ For I:=0 to 3 do
+ if (2*Knoten + _rlKante[I] >= 0) and
+ (2*Knoten + _rlKante[I] < length(Kanten)) then
+ case Kanten[2*Knoten + _rlKante[I]] of
+ -1: inc(Ma);
+ 1:
+ begin
+ inc(Mi);
+ inc(Ma);
+ end;
+ end{of Case};
+ if (Mi>2) or
+ ((Ma=Mi) and odd(Ma)) then
+ begin
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit; // so geht's nicht!
+ end;
+ {$IFDEF preSchleifenTest}
+ if (Mi=2) and warKante then // evtl. Schleife geschlossen
+ begin
+ K:=-1;
+ L:=-1;
+ For I:=0 to 3 do
+ if (2*Knoten+_rlKante[I]>=0) and
+ (2*Knoten+_rlKante[I]<length(Kanten)) and
+ (Kanten[2*Knoten+_rlKante[I]]=1) then
+ begin
+ K:=L;
+ L:=Zusammenhang[2*Knoten+_rlKante[I]];
+ end;
+ if (K<>-1) then
+ begin
+ if K=L then Result:=Byte(FelderOkay) // Schlaufe gebildet
+ else
+ begin // oder eben noch nicht
+ if L>K then
+ begin
+ I:=L;
+ L:=K;
+ K:=I;
+ end;
+ For I:=0 to 3 do // vorheriges in save speichern
+ if (2*Knoten + _rlKante[I]>=0) and (2*Knoten + _rlKante[I]<length(Kanten)) then
+ save[I]:=Kanten[2*Knoten + _rlKante[I]]
+ else
+ save[I]:=-2;
+ setlength(Zsave,length(Zusammenhang));
+ For I:=0 to length(Zusammenhang)-1 do // bzw. in Zsave
+ begin
+ Zsave[I]:=Zusammenhang[I];
+ if Zusammenhang[I]=K then Zusammenhang[I]:=L;
+ if Zusammenhang[I]>K then dec(Zusammenhang[I]);
+ end;
+ For I:=0 to 3 do // 2+x sind x zu viel
+ if (save[I]<>-2) and
+ (Kanten[2*Knoten+_rlKante[I]]=-1) then
+ Kanten[2*Knoten+_rlKante[I]]:=0;
+ if ersteFreieKante=-1 then
+ Result:=Byte(FelderOkay) // sollte eigentlich nicht gelöst sein
+ else
+ Result:=rekursivLoesen(ersteFreieKante div 2,LoesungBehalten,EndeBeiEins,false);
+ //(ersteFreieKante+1) mod 2 + 2,
+ if (not LoesungBehalten) or (Result=0) then
+ begin
+ For I:=0 to length(Zsave)-1 do
+ Zusammenhang[I]:=Zsave[I];
+ For I:=0 to 3 do
+ if save[I]<>-2 then
+ Kanten[2*Knoten+_rlKante[I]]:=save[I];
+ end;
+ end;
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ end;
+ {$ENDIF}
+ if Ma=Mi then // hier bereits alles geklärt
+ begin
+ if ersteFreieKante=-1 then
+ Result:=Byte(FelderOkay)
+ else
+ Result:=rekursivLoesen(ersteFreieKante div 2,LoesungBehalten,EndeBeiEins,false);
+ //(ersteFreieKante+1) mod 2 + 2,
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ For I:=0 to 3 do // vorheriges in save speichern
+ if (2*Knoten + _rlKante[I]>=0) and (2*Knoten + _rlKante[I]<length(Kanten)) then
+ save[I]:=Kanten[2*Knoten + _rlKante[I]]
+ else
+ save[I]:=-2;
+ if (Ma<2) or (Mi=2) then // keine neuen Kanten
+ begin
+ For I:=0 to 3 do
+ if (save[I]<>-2) and
+ (Kanten[2*Knoten+_rlKante[I]]=-1) then
+ Kanten[2*Knoten+_rlKante[I]]:=0;
+ if ersteFreieKante=-1 then
+ Result:=Byte(FelderOkay)
+ else
+ Result:=rekursivLoesen(ersteFreieKante div 2,LoesungBehalten,EndeBeiEins,false);
+ //(ersteFreieKante+1) mod 2 + 2,
+ if (not LoesungBehalten) or (Result=0) then
+ For I:=0 to 3 do
+ if save[I]<>-2 then
+ Kanten[2*Knoten+_rlKante[I]]:=save[I];
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ Perm[0]:=random(4);
+ Perm[1]:=random(3);
+ Perm[1]:=Perm[1]+Byte(Perm[1]>=Perm[0]);
+ Perm[2]:=random(2);
+ Perm[2]:=Perm[2]+Byte(Perm[2]>=Min(Perm[0],Perm[1]));
+ Perm[2]:=Perm[2]+Byte(Perm[2]>=Max(Perm[0],Perm[1]));
+ Perm[3]:=0;
+ For I:=1 to 3 do
+ if (Perm[0]<>I) and (Perm[1]<>I) and (Perm[2]<>I) then Perm[3]:=I;
+ if Mi=0 then
+ begin // keine oder zwei neue Kanten
+ L:=Byte(Random>0.5);
+ repeat
+ if L in [1,2] then // vielleicht zwei?
+ For I:=0 to 3 do
+ if (save[Perm[I]] <> -2) and
+ (Kanten[2*Knoten + _rlKante[Perm[I]]]=-1) then
+ For J:=I+1 to 3 do
+ if (save[Perm[J]]<>-2) and
+ (Kanten[2*Knoten + _rlKante[Perm[J]]]=-1) then
+ begin
+ {$IFDEF preSchleifenTest}
+ Setlength(Zsave,length(Zusammenhang));
+ For K:=0 to length(ZSave)-1 do
+ ZSave[K]:=Zusammenhang[K];
+ ZusHlok:=inZusammenhangKomp(Knoten + _rlSchritt[Perm[J]]);
+ if ZusHlok=-1 then // der "Start" ist frei
+ For K:=0 to length(Zusammenhang)-1 do
+ ZusHlok:=max(ZusHlok,Zusammenhang[K]+1);
+ Zusammenhang[2*Knoten + _rlKante[Perm[I]]]:=ZusHlok;
+ Zusammenhang[2*Knoten + _rlKante[Perm[J]]]:=ZusHlok;
+ {$ENDIF}
+ For K:=0 to 3 do
+ if Save[K]<>-2 then
+ Kanten[2*Knoten + _rlKante[K]]:=0;
+ Kanten[2*Knoten + _rlKante[Perm[I]]]:=1;
+ Kanten[2*Knoten + _rlKante[Perm[J]]]:=1;
+ Result:=Result+rekursivLoesen(Knoten + _rlSchritt[Perm[I]],LoesungBehalten,EndeBeiEins,true);
+ // Perm[I],
+ if (Result>1) or ((Result>0) and EndeBeiEins) then
+ begin
+ if not LoesungBehalten then
+ begin
+ For K:=0 to 3 do
+ if Save[K]<>-2 then
+ Kanten[2*Knoten + _rlKante[K]]:=save[K];
+ {$IFDEF preSchleifenTest}
+ For K:=0 to length(ZSave)-1 do
+ Zusammenhang[K]:=ZSave[K];
+ {$ENDIF}
+ end;
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ For K:=0 to 3 do
+ if Save[K]<>-2 then
+ Kanten[2*Knoten + _rlKante[K]]:=save[K];
+ {$IFDEF preSchleifenTest}
+ For K:=0 to length(ZSave)-1 do
+ Zusammenhang[K]:=ZSave[K];
+ {$ENDIF}
+ end;
+ if L in [0,3] then // vielleicht keine?
+ begin
+ For I:=0 to 3 do
+ if (save[Perm[I]] <> -2) then
+ Kanten[2*Knoten + _rlKante[Perm[I]]]:=0;
+ if ersteFreieKante=-1 then
+ Result:=Result+Byte(FelderOkay)
+ else
+ Result:=Result+rekursivLoesen(ersteFreieKante div 2,LoesungBehalten,EndeBeiEins,false);
+ //(ersteFreieKante+1) mod 2 + 2,
+ if (Result>1) or ((Result>0) and EndeBeiEins) then
+ begin
+ if not LoesungBehalten then
+ For K:=0 to 3 do
+ if Save[K]<>-2 then
+ Kanten[2*Knoten + _rlKante[K]]:=save[K];
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ For I:=0 to 3 do
+ if save[I]<>-2 then
+ Kanten[2*Knoten+_rlKante[I]]:=save[I];
+ end;
+ inc(L,2);
+ until L>3;
+ end
+ else
+ begin // genau eine neue Kante
+ {$IFDEF preSchleifenTest}
+ ZusHlok:=inZusammenhangKomp(Knoten);
+ if ZusHlok=-1 then // "Start" ist frei
+ For I:=0 to length(Zusammenhang)-1 do
+ ZusHlok:=max(ZusHlok,Zusammenhang[I]+1);
+ {$ENDIF}
+ For I:=0 to 3 do
+ if (save[Perm[I]]<>-2) and
+ (Kanten[2*Knoten + _rlKante[Perm[I]]]=-1) then
+ begin
+ For K:=0 to 3 do
+ if (save[K]<>-2) and
+ (Kanten[2*Knoten + _rlKante[K]]=-1) then
+ Kanten[2*Knoten + _rlKante[K]]:=0;
+ {$IFDEF preSchleifenTest}
+ Zusammenhang[2*Knoten + _rlKante[Perm[I]]]:=ZusHlok;
+ {$ENDIF}
+ Kanten[2*Knoten + _rlKante[Perm[I]]]:=1;
+ result:=result+rekursivLoesen(Knoten + _rlSchritt[Perm[I]],LoesungBehalten,EndeBeiEins,true);
+ //Perm[I],
+ if (Result>1) or ((Result>0) and EndeBeiEins) then
+ begin
+ if not LoesungBehalten then
+ begin
+ For K:=0 to 3 do
+ if Save[K]<>-2 then
+ Kanten[2*Knoten + _rlKante[K]]:=save[K];
+ {$IFDEF preSchleifenTest}
+ Zusammenhang[2*Knoten + _rlKante[Perm[I]]]:=-1;
+ {$ENDIF}
+ end;
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+ exit;
+ end;
+ For K:=0 to 3 do
+ if (save[K]<>-2) then
+ Kanten[2*Knoten + _rlKante[K]]:=save[K];
+ {$IFDEF preSchleifenTest}
+ Zusammenhang[2*Knoten + _rlKante[Perm[I]]]:=-1;
+ {$ENDIF}
+ end;
+ end;
+ {$IFDEF debug}
+ dec(Tiefe);
+ {$ENDIF}
+end;
+
+procedure TFeld.Leeren(PB: TProgressbar);
+var I,J: Integer;
+ save: Integer;
+ geht: boolean;
+ {$IFDEF vorLoesen}
+ Startknoten,
+ Startrichtung: integer;
+ {$IFDEF debug}
+ tstart: extended;
+ {$ENDIF}
+ {$ENDIF}
+begin
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tvorloesen:=0;
+ tnachloesen:=0;
+ {$ENDIF}
+ {$ENDIF}
+ kantenPermErzeugen;
+ felderPermErzeugen;
+ if not Schleife then // feste Felder entfernen
+ begin
+ For I:=0 to length(Felder)-1 do
+ if festesFeld(I) then
+ Felder[I]:=-1;
+ end;
+ if Assigned(PB) then
+ begin
+ PB.Visible:=true;
+ PB.Min:=0;
+ PB.Position:=0;
+ PB.Step:=1;
+ PB.Max:=length(Kanten);
+ end;
+ For I:=0 to length(Kanten)-1 do // zuerst Kanten entfernen
+ begin
+ if Assigned(PB) then PB.StepIt;
+ if (Kanten[_KantenPerm[I]]<>-2) and
+ (Schleife or (festeKante(_KantenPerm[I])<0)) then
+ begin
+ save:=Kanten[_KantenPerm[I]];
+ Kanten[_KantenPerm[I]]:=-1;
+ LoesungInitialisieren;
+ Startknoten:=-1;
+ Startrichtung:=0;
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tstart:=now;
+ {$ENDIF}
+ vorLoesen(Startknoten,Startrichtung);
+ {$IFDEF debug}
+ tvorloesen:=tvorloesen+now-tstart;
+ {$ENDIF}
+ {$ENDIF}
+ if Startknoten=-1 then
+ begin
+ Startknoten:=ersteFreieKante;
+ Startrichtung:=(Startknoten + 1) mod 2 + 2;
+ Startknoten:=Startknoten div 2;
+ end;
+ {$IFDEF preSchleifenTest}
+ ZusammenhangInitialisieren;
+ {$ENDIF}
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tstart:=now;
+ {$ENDIF}
+ {$ENDIF}
+ geht:=rekursivLoesen(Startknoten,false,false,false)=1;
+ //Startrichtung,
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tnachloesen:=tnachloesen+now-tstart;
+ tstart:=now;
+ {$ENDIF}
+ nachLoesen;
+ {$IFDEF debug}
+ tvorloesen:=tvorloesen+now-tstart;
+ {$ENDIF}
+ {$ENDIF}
+ if not geht then
+ Kanten[_KantenPerm[I]]:=save;
+ end;
+ end;
+ {$IFDEF debug}
+ t3:=now;
+ {$ENDIF}
+ if Assigned(PB) then
+ begin
+ PB.Position:=0;
+ PB.Max:=length(_FelderPerm);
+ end;
+ For J:=0 to 1 do
+ For I:=0 to length(_FelderPerm)-1 do
+ if (Felder[_FelderPerm[I]]=0) xor (J=1) then
+ begin
+ if Assigned(PB) then PB.StepIt;
+ save:=Felder[_FelderPerm[I]];
+ Felder[_FelderPerm[I]]:=-1;
+ LoesungInitialisieren;
+ Startknoten:=-1;
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tstart:=now;
+ {$ENDIF}
+ vorLoesen(Startknoten,Startrichtung);
+ {$IFDEF debug}
+ tvorloesen:=tvorloesen+now-tstart;
+ {$ENDIF}
+ {$ENDIF}
+ if Startknoten=-1 then
+ begin
+ Startknoten:=ersteFreieKante;
+ Startrichtung:=(Startknoten + 1) mod 2 + 2;
+ Startknoten:=Startknoten div 2;
+ end;
+ {$IFDEF preSchleifenTest}
+ ZusammenhangInitialisieren;
+ {$ENDIF}
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tstart:=now;
+ {$ENDIF}
+ {$ENDIF}
+ geht:=rekursivLoesen(Startknoten,false,false,false)=1;
+ //Startrichtung,
+ {$IFDEF vorLoesen}
+ {$IFDEF debug}
+ tnachloesen:=tnachloesen+now-tstart;
+ tstart:=now;
+ {$ENDIF}
+ nachLoesen;
+ {$IFDEF debug}
+ tvorloesen:=tvorloesen+now-tstart;
+ {$ENDIF}
+ {$ENDIF}
+ if not geht then
+ Felder[_FelderPerm[I]]:=save;
+ end;
+ if Assigned(PB) then PB.Visible:=false;
+end;
+
+procedure TFeld.Erzeugen(PB: TProgressbar);
+begin
+ Erzeugen(PB,false);
+end;
+
+procedure TFeld.Erzeugen(PB: TProgressbar; vorheriges_lassen: boolean);
+var I: Integer;
+begin
+ {$IFDEF debug}
+ erzeugungsVersuche:=0;
+ t0:=now;
+ {$ENDIF}
+ if (not vorheriges_lassen) or (Schlaufe<>2) then
+ Repeat
+ FKinitialisieren;
+ Loesen;
+ {$IFDEF debug}
+ inc(erzeugungsVersuche);
+ {$ENDIF}
+ until Schlaufe=2;
+ {$IFDEF debug}
+ t1:=now;
+ {$ENDIF}
+ FelderErzeugen;
+ {$IFDEF debug}
+ t2:=now;
+ {$ENDIF}
+ Leeren(PB);
+ For I:=0 to length(Kanten)-1 do
+ SKanten[I]:=Kanten[I] in [0,1];
+ Setlength(Geschichte,0);
+ {$IFDEF debug}
+ t4:=now;
+ Messagedlg(inttostr(erzeugungsversuche)+' Versuche -> '+floattostr((t1-t0)*24*60*60)+' sec'#13#10+
+ 'Felder erzeugen: '+floattostr((t2-t1)*24*60*60)+' sec'#13#10+
+ 'Leeren, insgesamt: '+floattostr((t4-t2)*24*60*60)+' sec'#13#10+
+ ' - davon Kanten: '+floattostr((t3-t2)*24*60*60)+' sec'#13#10+
+ ' und Felder: '+floattostr((t4-t3)*24*60*60)+' sec'
+ {$IFDEF vorLoesen}
+ +#13#10' - davon Vorlösen: '+floattostr(tvorloesen*24*60*60)+' sec'#13#10+
+ ' und Lösen: '+floattostr(tnachloesen*24*60*60)+' sec'
+ {$ENDIF}
+ ,mtinformation,[mbOK],0);
+ {$ENDIF}
+end;
+
+function TFeld.allesOkay: boolean;
+var I: Integer;
+begin
+ Result:=FelderOkay;
+ For I:=0 to length(Kanten)-1 do
+// Result:=Result and (Kanten[I]<>-1);
+end;
+
+function TFeld.FelderOkay: boolean;
+var I: Integer;
+begin
+ Result:=Schlaufe>=1;
+ For I:=0 to length(Felder)-1 do
+ if Felder[I]>=0 then
+ Result:=Result and (Felder[I]=byte(Kanten[2*I]=1)+
+ byte(Kanten[2*I+1]=1)+
+ byte(Kanten[2*I+2]=1)+
+ byte(Kanten[2*I+2*Breite+3]=1));
+end;
+
+procedure TFeld.PermErzeugen(n: integer; var Perm: TPerm);
+var I,J,K,L,R: integer;
+begin
+ Setlength(Perm,n);
+ For I:=0 to n-1 do
+ begin
+ R:=random(n-I);
+ K:=0;
+ L:=0;
+ repeat
+ K:=max(K,L);
+ L:=0;
+ For J:=0 to I-1 do
+ if Perm[J]<=R+K then
+ inc(L);
+ until K=L;
+ Perm[I]:=R+K;
+ end;
+end;
+
+procedure TFeld.kantenPermErzeugen;
+begin
+ PermErzeugen(length(Kanten),_KantenPerm);
+end;
+
+procedure TFeld.felderPermErzeugen;
+var I,J: integer;
+begin
+ PermErzeugen(length(Felder),_FelderPerm);
+ I:=length(Felder);
+ while I>0 do
+ begin
+ dec(I);
+ if Felder[_FelderPerm[I]]=-2 then
+ begin
+ For J:=I+1 to length(_FelderPerm)-1 do
+ _FelderPerm[J-1]:=_FelderPerm[J];
+ Setlength(_FelderPerm,length(_FelderPerm)-1);
+ end;
+ end;
+end;
+
+function TFeld.FeldOkay(i: integer): boolean;
+var J,Mi,Ma: integer;
+begin
+ LoesungInitialisieren;
+ Mi:=0;
+ Ma:=0;
+ For J:=0 to 3 do
+ case Kanten[2*i + _rlFKante[J]] of
+ -1: inc(Ma);
+ 1:
+ begin
+ inc(Ma);
+ inc(Mi);
+ end;
+ end{of Case};
+ Result:=(Felder[i]<0) or ((Ma>=Felder[i]) and (Mi<=Felder[i]));
+end;
+
+function TFeld.KanteOkay(i: integer): boolean;
+var J,K,Mi,Ma: integer;
+begin
+ LoesungInitialisieren;
+ Ma:=0;
+ Mi:=0;
+ K:=i div 2;
+ For J:=0 to 3 do
+ if (2*K+_rlKante[J] >= 0) and
+ (2*K+_rlKante[J] < length(Kanten)) then
+ case Kanten[2*K+_rlKante[J]] of
+ -1: inc(Ma);
+ 1:
+ begin
+ inc(Ma);
+ inc(Mi);
+ end;
+ end{of Case};
+ Result:=(Mi<=2) and ((Mi<>Ma) or not odd(Ma));
+ Ma:=0;
+ Mi:=0;
+ K:=K + _rlSchritt[3*Byte(not odd(i))];
+ For J:=0 to 3 do
+ if (2*K+_rlKante[J] >= 0) and
+ (2*K+_rlKante[J] < length(Kanten)) then
+ case Kanten[2*K+_rlKante[J]] of
+ -1: inc(Ma);
+ 1:
+ begin
+ inc(Ma);
+ inc(Mi);
+ end;
+ end{of Case};
+ Result:=Result and (Mi<=2) and ((Mi<>Ma) or not odd(Ma));
+end;
+
+function TFeld.rKannRueckGaengig: boolean;
+begin
+ Result:=length(Geschichte)>0;
+end;
+
+procedure TFeld.RueckGaengig;
+begin
+ if not kannRueckGaengig then exit;
+ Kanten[Geschichte[length(Geschichte)-1].x]:=Geschichte[length(Geschichte)-1].y;
+ setlength(Geschichte,length(Geschichte)-1);
+end;
+
+procedure TFeld.HackIt;
+begin
+ {$IFDEF preSchleifenTest}
+// ZusammenhangInitialisieren;
+ {$ENDIF}
+ Zeichnen(true);
+end;
+
+{$IFDEF preSchleifenTest}
+function TFeld.inZusammenhangKomp(Knoten: Integer): integer; // In welcher Zshg.-Komponente liegt der Knoten?
+var I: Integer;
+begin
+ Result:=-1;
+ For I:=0 to 3 do
+ if (2*Knoten+_rlKante[I]>=0) and
+ (2*Knoten+_rlKante[I]<length(Kanten)) and
+ (Zusammenhang[2*Knoten+_rlKante[I]]>=0) then
+ begin
+ Result:=Zusammenhang[2*Knoten+_rlKante[I]];
+ exit;
+ end;
+end;
+{$ENDIF}
+
+{$IFDEF vorLoesen}
+procedure TFeld.vorLoesen(var sKn,SRtg: integer);
+var I,J,K,Mi,Ma: integer;
+ weiter: boolean;
+begin
+ setlength(_vlKanten,length(Kanten));
+ for I:=0 to length(Kanten)-1 do
+ _vlKanten[I]:=Kanten[I];
+ for I:=0 to length(Felder)-1 do
+ case Felder[I] of // spezielle Kombinationen suchen
+ 3:
+ for J:=0 to 1 do
+ begin
+ if (I+_rlSchritt[J]>=0) and // zwei 3en nebeneinander ?
+ (I+_rlSchritt[J]<length(Felder)) and
+ (Felder[I+_rlSchritt[J]]=3) then
+ For K:=-1 to 1 do
+ Kanten[2*(I+K*_rlSchritt[J])+_rlFKante[J]]:=1;
+ if (I+_rlSchritt[J]+_rlSchritt[(J+1) mod 4]>=0) and // zwei 3en diagonal ?
+ (I+_rlSchritt[J]+_rlSchritt[(J+1) mod 4]<length(Felder)) and
+ (Felder[I+_rlSchritt[J]+_rlSchritt[(J+1) mod 4]]=3) then
+ begin
+ Kanten[2*(I+_rlSchritt[J]+_rlSchritt[(J+1) mod 4])+_rlFKante[J]]:=1;
+ Kanten[2*(I+_rlSchritt[J]+_rlSchritt[(J+1) mod 4])+_rlFKante[(J+1) mod 4]]:=1;
+ Kanten[2*(I-_rlSchritt[J])+_rlFKante[J]]:=1;
+ Kanten[2*(I-_rlSchritt[(J+1) mod 4])+_rlFKante[(J+1) mod 4]]:=1;
+ end;
+ end;
+ end{of Case};
+ repeat
+ weiter:=false;
+ for I:=0 to length(Felder)-1 do
+ if Felder[I] >= 0 then // "normale" min-max-Suche
+ begin
+ Mi:=0;
+ Ma:=0;
+ for J:=0 to 3 do
+ begin
+ Mi:=Mi+Byte(Kanten[2*I+_rlFKante[J]]=1);
+ Ma:=Ma+Byte(abs(Kanten[2*I+_rlFKante[J]])=1);
+ end;
+ weiter:=weiter or ((Ma<>Mi) and ((Felder[I]=Ma) or (Felder[I]=Mi)));
+ if (Ma<>Mi) and (Felder[I]=Mi) then // alles andere muss leer sein
+ For J:=0 to 3 do
+ if Kanten[2*I+_rlFKante[J]]=-1 then
+ Kanten[2*I+_rlFKante[J]]:=0;
+ if (Ma<>Mi) and (Felder[I]=Ma) then // alles andere muss gefüllt sein
+ For J:=0 to 3 do
+ if Kanten[2*I+_rlFKante[J]]=-1 then
+ Kanten[2*I+_rlFKante[J]]:=1;
+ end;
+ for I:=0 to length(Kanten) div 2 do
+ begin
+ Mi:=0;
+ Ma:=0;
+ For J:=0 to 3 do
+ if (2*I+_rlKante[J] >= 0) and
+ (2*I+_rlKante[J] < length(Kanten)) then
+ begin
+ Mi:=Mi + Byte(Kanten[2*I+_rlKante[J]]=1);
+ Ma:=Ma + Byte(abs(Kanten[2*I+_rlKante[J]])=1);
+ end;
+ if (Mi=2) or (Ma<2) then
+ begin
+ for J:=0 to 3 do
+ if (2*I+_rlKante[J] >= 0) and
+ (2*I+_rlKante[J] < length(Kanten)) and
+ (Kanten[2*I+_rlKante[J]] = -1) then
+ begin
+ weiter:=true;
+ Kanten[2*I+_rlKante[J]]:=0;
+ end;
+ continue;
+ end;
+ if (Ma=2) and (Mi>0) then
+ begin
+ for J:=0 to 3 do
+ if (2*I+_rlKante[J] >= 0) and
+ (2*I+_rlKante[J] < length(Kanten)) and
+ (Kanten[2*I+_rlKante[J]] = -1) then
+ begin
+ weiter:=true;
+ Kanten[2*I+_rlKante[J]]:=1;
+ end;
+ continue;
+ end;
+ end;
+ until not weiter;
+ For I:=0 to length(Kanten) div 2 do
+ begin
+ K:=0;
+ For J:=0 to 3 do
+ if (2*I+_rlKante[J] >= 0) and
+ (2*I+_rlKante[J] < length(Kanten)) and
+ (Kanten[2*I+_rlKante[J]]=1) then
+ inc(K);
+ if K=1 then
+ begin
+ sKn:=I;
+ For J:=0 to 3 do
+ if (2*I+_rlKante[J] >= 0) and
+ (2*I+_rlKante[J] < length(Kanten)) and
+ (Kanten[2*I+_rlKante[J]]=1) then
+ sRtg:=(J+2) mod 4;
+ end;
+ end;
+end;
+
+procedure TFeld.nachLoesen;
+var I: integer;
+begin
+ for I:=0 to length(Kanten)-1 do
+ Kanten[I]:=_vlKanten[I];
+end;
+{$ENDIF}
+
+procedure TFeld.wSchleife(S: boolean);
+begin
+ if S=_Schleife then exit;
+ _Schleife:=S;
+ Breite:=Breite-Byte(S);
+ Hoehe:=Hoehe-Byte(S);
+ FKInitialisieren;
+end;
+
+function TFeld.FesteKante(I: Integer): integer;
+begin
+ result:=-1;
+ if Schleife then exit;
+ if (I<2*Breite) or ((I+3) mod (2*Breite+2) <= 1) then result:=0;
+ if result=0 then
+ begin
+ if (odd(I) and (I<2*Breite)) or
+ (I=0) or ((I+2) mod (2*Breite+2) = 0) or
+ (I=2*(Breite+1)*(Hoehe+1)-3) then result:=1;
+ end;
+end;
+
+function TFeld.FestesFeld(I: Integer): boolean;
+begin
+ result:=
+ not (Schleife or
+ not ((I<Breite) or
+ ((I+2) mod (Breite+1) = 0)));
+end;
+
+procedure TFeld.SaveToFile(Filename: String);
+var F: TRaetselFile;
+ C: Cardinal;
+begin
+ F:=TRaetselFile.Create;
+ F.Kennung:='Slither';
+ F.FAssignfile(Filename);
+ F.FRewrite;
+ C:=Breite;
+ F.FBlockWrite(C,4);
+ C:=Hoehe;
+ F.FBlockWrite(C,4);
+ C:=Byte(Schleife);
+ F.FBlockWrite(C,4);
+ C:=length(Geschichte);
+ F.FBlockWrite(C,4);
+ if length(Kanten)>0 then
+ F.FBlockWrite(Kanten[0],length(Kanten)*SizeOf(Kanten[0]));
+ if length(SKanten)>0 then
+ F.FBlockWrite(SKanten[0],length(SKanten)*SizeOf(SKanten[0]));
+ if length(Felder)>0 then
+ F.FBlockWrite(Felder[0],length(Felder)*SizeOf(Felder[0]));
+ if length(Geschichte)>0 then
+ F.FBlockWrite(Geschichte[0],length(Geschichte)*SizeOf(Geschichte[0]));
+ F.FCloseFile;
+ F.Destroy;
+end;
+
+function TFeld.LoadFromFile(Filename: String): boolean;
+var F: TRaetselFile;
+ C: Cardinal;
+begin
+ F:=TRaetselFile.Create;
+ F.Kennung:='Slither';
+ F.FAssignFile(Filename);
+ Result:=F.FReset;
+ if not Result then exit;
+ C:=0;
+ Result:=F.FBlockRead(C,4);
+ if not Result then exit;
+ _Breite:=C;
+ Result:=F.FBlockRead(C,4);
+ if not Result then exit;
+ _Hoehe:=C;
+ Result:=F.FBlockRead(C,4);
+ if not Result then exit;
+ _Schleife:=C<>0;
+ FKInitialisieren;
+ Result:=F.FBlockRead(C,4);
+ if not Result then exit;
+ Setlength(Geschichte,C);
+ if length(Kanten)>0 then
+ Result:=F.FBlockRead(Kanten[0],length(Kanten)*SizeOf(Kanten[0]));
+ if not Result then Exit;
+ if length(SKanten)>0 then
+ Result:=F.FBlockRead(SKanten[0],length(SKanten)*SizeOf(SKanten[0]));
+ if not Result then Exit;
+ if length(Felder)>0 then
+ Result:=F.FBlockRead(Felder[0],length(Felder)*SizeOf(Felder[0]));
+ if not Result then Exit;
+ if length(Geschichte)>0 then
+ Result:=F.FBlockRead(Geschichte[0],length(Geschichte)*SizeOf(Geschichte[0]));
+ F.FCloseFile;
+ F.Destroy;
+end;
+
+procedure TFeld.LoadFromFeld(F: TFeld);
+begin
+ Schleife:=F.Schleife;
+ Hoehe:=F.Hoehe-byte(not Schleife);
+ Breite:=F.Breite-byte(not Schleife);
+ Setlength(Geschichte,length(F.Geschichte));
+ if length(Kanten)>0 then
+ Move(F.Kanten[0],Kanten[0],length(Kanten)*SizeOf(Kanten[0]));
+ if length(SKanten)>0 then
+ Move(F.SKanten[0],SKanten[0],length(SKanten)*SizeOf(SKanten[0]));
+ if length(Felder)>0 then
+ Move(F.Felder[0],Felder[0],length(Felder)*SizeOf(Felder[0]));
+ if length(Geschichte)>0 then
+ Move(F.Geschichte[0],Geschichte[0],length(Geschichte)*SizeOf(Geschichte[0]));
+end;
+
+procedure TFeld.WohinMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
+begin
+ lmx:=X;
+ lmy:=Y;
+end;
+
+procedure TFeld.OnKeyPress(Sender: TObject; var Key: Char);
+begin
+ case Key of
+ 'x': WohinMouseUp(Sender,mbLeft,[],lmx,lmy);
+ 'y': WohinMouseUp(Sender,mbRight,[],lmx,lmy);
+ 'c':
+ begin
+ Rueckgaengig;
+ Zeichnen;
+ end;
+ end{of Case};
+end;
+
+procedure TFeld.inDieserSituationTutMan(I: Integer);
+var F: File;
+ C: Cardinal;
+ B: Byte;
+ J: Integer;
+begin
+ if Lerndatei='' then exit;
+ AssignFile(F,Lerndatei);
+ Reset(F,1);
+ Seek(F,fileSize(F));
+ B:=Byte(Schleife);
+ BlockWrite(F,B,1);
+ BlockWrite(F,_Breite,4);
+ BlockWrite(F,_Hoehe,4);
+ for J:=0 to length(Kanten)-1 do begin
+ B:=Kanten[J]+2;
+ BlockWrite(F,B,1);
+ end;
+ for J:=0 to length(Felder)-1 do begin
+ B:=Felder[J]+2;
+ BlockWrite(F,B,1);
+ end;
+ BlockWrite(F,I,4);
+ Closefile(F);
+end;
+
+//******************************************************************************
+
+constructor TGenerierungsthread.create(breite, hoehe: integer; Progressbar: TProgressbar; Parent: TWinControl; Schleife: boolean);
+begin
+ inherited create(true);
+ Fertig:=0;
+ PB:=Progressbar;
+ Feld:=TFeld.create(Parent);
+ Feld.Schleife:=Schleife;
+ Feld.Breite:=breite;
+ Feld.Hoehe:=hoehe;
+ Starttime:=now;
+ Priority:=tpLowest;
+ Suspended:=false;
+end;
+
+destructor TGenerierungsthread.destroy;
+begin
+ Feld.destroy;
+ inherited destroy;
+end;
+
+procedure TGenerierungsthread.execute;
+begin
+ Feld.Erzeugen(PB);
+ Fertig:=1;
+end;
+
+begin
+ {$IFNDEF norandomize}
+ randomize;
+ {$ENDIF}
+end.
|