diff options
| author | Erich Eckner <git@eckner.net> | 2016-10-28 09:33:51 +0200 |
|---|---|---|
| committer | Erich Eckner <git@eckner.net> | 2016-10-28 09:33:51 +0200 |
| commit | 4fb084a6af9200f60e4297a215b8a14f3d70dc40 (patch) | |
| tree | 157022fdd32ced462e90cc64b8da49f058f6c090 | |
| download | Slitherlink-4fb084a6af9200f60e4297a215b8a14f3d70dc40.tar.xz | |
initial Commit
| -rw-r--r-- | .gitignore | 72 | ||||
| -rw-r--r-- | RaetselFileUnit.pas | 291 | ||||
| -rw-r--r-- | SLNN.ico | bin | 0 -> 137040 bytes | |||
| -rw-r--r-- | SLNN.lpi | 90 | ||||
| -rw-r--r-- | SLNN.lpr | 21 | ||||
| -rw-r--r-- | Slitherlink.ico | bin | 0 -> 137040 bytes | |||
| -rw-r--r-- | Slitherlink.lpi | 91 | ||||
| -rw-r--r-- | Slitherlink.lpr | 21 | ||||
| -rw-r--r-- | SlitherlinkUnit.pas | 1548 | ||||
| -rw-r--r-- | nnunit.pas | 544 | ||||
| -rw-r--r-- | slnnunit1.lfm | 40 | ||||
| -rw-r--r-- | slnnunit1.pas | 161 | ||||
| -rw-r--r-- | unit1.lfm | 125 | ||||
| -rw-r--r-- | unit1.pas | 179 |
14 files changed, 3183 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a52e7c3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,72 @@ +Slitherlink +*~ +*.~* +*.a +*.aux +*.backup +*.bak +*.bak* +*.bmp +*.bsr +*.cfg +*.compiled +*.dat +data +data_* +Daten +*.dat.gz +*.dat.gz.save +*.dat.ori +*.dat.pgz +*.dat.pgz.save +*.dat.save +*.dcu +*.ddp +Debug +*.dfm +*.dll +*.dof +*.dpr +*.drc +*.dsk +*.dump +*.dylib +*.elf +*.exe +*.gch +*.gramps +*.gz +*.hex +*.la +*.lai +lib +*.lib +*.lo +*.log +Log* +*.lps +*.m +*.map +*.mod +*.o +*.[oa] +*.obj +*_original +*.out +out.* +*.pch +*.png +*.ppu +*.res +*.rsm +*.slo +*.so +*.tar.gz +*.txt +*.txt.gz +*.txt.gz.save +*.txt.pgz +*.txt.pgz.save +*.txt.save +*.xml +*.zip diff --git a/RaetselFileUnit.pas b/RaetselFileUnit.pas new file mode 100644 index 0000000..8d88ef6 --- /dev/null +++ b/RaetselFileUnit.pas @@ -0,0 +1,291 @@ +unit RaetselFileUnit;
+
+interface
+
+ uses dialogs, math;
+
+ type TWort = record
+ W: array of Byte;
+ Bits: Integer;
+ end;
+ TRaetselFile = class
+ private
+ F: File;
+ wacc: boolean;
+ inhalt,
+ conv: array of Byte;
+ FPoint: Integer;
+ WB: array of TWort;
+ procedure FFlush;
+ procedure initWB;
+ procedure concatWs(a,b: integer);
+ function BisAx(A: TWort; B: array of Byte): boolean;
+ procedure rConvert;
+ procedure wConvert;
+ public
+ Kennung: String;
+ procedure FAssignfile(FileName: String);
+ function FReset: boolean;
+ procedure FRewrite;
+ procedure FCloseFile;
+ procedure FBlockWrite(var Data; Len: Integer);
+ function FBlockRead(var Data; Len: Integer): boolean;
+ end;
+
+implementation
+
+procedure TRaetselFile.Fassignfile(FileName: String);
+begin
+ AssignFile(F,FileName);
+end;
+
+function TRaetselFile.FReset: boolean;
+var C: Cardinal;
+ S: String;
+begin
+ wacc:=false;
+ Result:=false;
+ Reset(F,1);
+ if FileSize(F) < 4 then
+ begin
+ FCloseFile;
+ exit;
+ end;
+ Blockread(F,C,4);
+ if C<>$26594131 then
+ begin
+ FCloseFile;
+ exit;
+ end;
+ Setlength(conv,FileSize(F)-4);
+ Blockread(F,conv[0],length(conv));
+ rConvert;
+ if length(inhalt)<length(Kennung) then
+ begin
+ FCloseFile;
+ exit;
+ end;
+ S:=Kennung;
+ FBlockread(S[1],length(S));
+ if S<>Kennung then
+ begin
+ FCloseFile;
+ exit;
+ end;
+ Result:=true;
+end;
+
+procedure TRaetselFile.initWB;
+var B: Byte;
+begin
+(* Setlength(WB,128);
+ for B:=0 to 127 do
+ begin
+ Setlength(WB[B].W,2);
+ WB[B].W[0]:=B;
+ WB[B].W[1]:=0;
+ WB[B].Bits:=7;
+ end; *)
+ Setlength(WB,2);
+ setlength(WB[0].W,2);
+ WB[0].W[0]:=$0;
+ WB[0].W[1]:=0;
+ WB[0].Bits:=1;
+ setlength(WB[1].W,2);
+ WB[1].W[0]:=$1;
+ WB[1].W[1]:=0;
+ WB[1].Bits:=1;
+end;
+
+procedure TRaetselFile.concatWs(a,b: integer);
+var I: integer;
+begin
+ setlength(WB,length(WB)+1); // WB erweitern
+ with WB[length(WB)-1] do begin
+ Bits:=WB[a].Bits+WB[b].Bits;
+ Setlength(W,(Bits+7) div 8 + 1);
+ for I:=0 to length(W)-1 do
+ W[I]:=0;
+ for I:=0 to length(WB[a].W)-2 do
+ W[I]:=WB[a].W[I];
+ for I:=0 to length(WB[b].W)-2 do
+ begin
+ W[length(WB[a].W)-2+I]:=
+ W[length(WB[a].W)-2+I] or
+ ($FF and (WB[b].W[I] shl (WB[a].Bits mod 8)));
+ if length(WB[a].W)-1+I < length(W) then
+ W[length(WB[a].W)-1+I]:=
+ W[length(WB[a].W)-1+I] or
+ (WB[b].W[I] shr (8 - (WB[a].Bits mod 8)));
+ end;
+ end;
+end;
+
+function TRaetselFile.BisAx(A: TWort; B: array of Byte): boolean;
+var I: Integer;
+begin
+ Result:=true;
+ for I:=0 to (A.Bits div 8)-1 do
+ Result:=Result and (A.W[I] = B[I]);
+ Result:=Result and ((A.W[length(A.W)-2] and ($FF shr (8-(A.Bits mod 8)))) =
+ (B[length(A.W)-2] and ($FF shr (8-(A.Bits mod 8)))));
+end;
+
+procedure TRaetselFile.rConvert;
+var rP: longint;
+ wP,I: integer;
+ passt,lp: integer;
+ wBuff: byte;
+begin
+ initWB;
+ Setlength(inhalt,0);
+ rP:=0;
+ wP:=0;
+ wBuff:=0;
+ lp:=-1;
+ setlength(conv,length(conv)+1);
+ conv[length(conv)-1]:=0;
+ while rP<((length(conv)-1)*8) do
+ begin
+ passt:=0;
+ for I:=0 to ceil(ln(length(WB))/ln(2))-1 do
+ begin
+ passt:=passt or (byte(odd(conv[rP div 8] shr (rP mod 8))) shl I);
+ inc(rP);
+ end;
+ for I:=0 to WB[passt].Bits-1 do
+ begin
+ if wP=8 then
+ begin
+ setlength(inhalt,length(inhalt)+1);
+ inhalt[length(inhalt)-1]:=wBuff;
+ wP:=0;
+ wBuff:=0;
+ end;
+ wBuff:=wBuff or (Byte(odd((WB[passt].W[I div 8] shr (I mod 8)))) shl wP);
+ inc(wP);
+ end;
+ if lp<>-1 then
+ concatWs(lp,passt);
+ lp:=passt;
+ end;
+ setlength(conv,length(conv)+1);
+ conv[length(conv)-1]:=wBuff;
+end;
+
+procedure TRaetselFile.wConvert;
+var rP: longint;
+ wP,I,J: integer;
+ rBuff: array of Byte;
+ rBBits,passt,lp: integer;
+ wBuff: byte;
+begin
+ initWB;
+ Setlength(conv,0);
+ rP:=0;
+ wP:=0;
+ wBuff:=0;
+ lp:=-1;
+ Setlength(inhalt,length(inhalt)+1);
+ inhalt[length(inhalt)-1]:=0;
+ while rP<((length(inhalt)-1)*8) do
+ begin
+ setlength(rBuff,0);
+ rBBits:=0;
+ passt:=-1;
+ for I:=length(WB)-1 downto 0 do
+ with WB[I] do begin
+ if Bits > (8*length(inhalt) - rP) then continue;
+ if Bits > rBBits then
+ begin // mehr r-Buffern
+ Setlength(rBuff,(Bits+7) div 8);
+ rBBits:=Bits;
+ for J:=0 to length(rBuff)-1 do
+ begin
+ rBuff[J]:=0;
+ if J + rP div 8 < length(inhalt) then
+ rBuff[J]:=rBuff[J] or (inhalt[J + rP div 8] shr (rP mod 8));
+ if J+1 + rP div 8 < length(inhalt) then
+ rBuff[J]:=rBuff[J] or ($FF and (inhalt[(rP div 8) + J+1] shl (8-(rP mod 8))));
+ end;
+ end;
+ if ((passt=-1) or (WB[passt].Bits < WB[I].Bits)) and
+ BisAx(WB[I],rBuff) then
+ passt:=I;
+ end;
+ if passt=-1 then // geht ja gar nicht ...
+ begin // ... geht ja wohl!
+ Messagedlg('Zu wenig Wörter im Wörterbuch!',mterror,[mbOk],0);
+ exit;
+ end;
+ rP:=rP+WB[passt].Bits;
+ for I:=0 to ceil(ln(length(WB))/ln(2))-1 do
+ begin // WB-index speichern
+ if wP=8 then
+ begin // w-buffer leeren
+ setlength(conv,length(conv)+1);
+ conv[length(conv)-1]:=wBuff;
+ wP:=0;
+ wBuff:=0;
+ end;
+ wBuff:=wBuff or Byte(odd(passt shr I)) shl wP;
+ inc(wP);
+ end;
+ if lp<>-1 then
+ concatWs(lp,passt);
+ lp:=passt;
+ end;
+ setlength(conv,length(conv)+1);
+ conv[length(conv)-1]:=wBuff;
+end;
+
+procedure TRaetselFile.FFlush;
+begin
+ wConvert;
+ BlockWrite(F,conv[0],length(conv));
+ SetLength(inhalt,0);
+end;
+
+procedure TRaetselFile.FRewrite;
+var C: Cardinal;
+begin
+ wacc:=true;
+ Rewrite(F,1);
+ C:=$26594131;
+ BlockWrite(F,C,4);
+ Setlength(inhalt,length(Kennung));
+ Move(Kennung[1],inhalt[0],length(Kennung));
+ FPoint:=length(inhalt);
+end;
+
+procedure TRaetselFile.FCloseFile;
+begin
+ if wacc then
+ begin
+ FFlush;
+ CloseFile(F);
+ end;
+ Setlength(inhalt,0);
+ FPoint:=0;
+end;
+
+procedure TRaetselFile.FBlockWrite(var Data; Len: Integer);
+begin
+ Setlength(inhalt,length(inhalt)+Len);
+ Move(Data,inhalt[FPoint],Len);
+ FPoint:=length(inhalt);
+end;
+
+function TRaetselFile.FBlockRead(var Data; Len: Integer): boolean;
+begin
+ Result:=Len<=(length(inhalt)-FPoint);
+ if not Result then
+ begin
+ FCloseFile;
+ exit;
+ end;
+ Move(inhalt[FPoint],Data,Len);
+ FPoint:=FPoint+Len;
+end;
+
+end.
diff --git a/SLNN.ico b/SLNN.ico Binary files differnew file mode 100644 index 0000000..0341321 --- /dev/null +++ b/SLNN.ico diff --git a/SLNN.lpi b/SLNN.lpi new file mode 100644 index 0000000..766bcd1 --- /dev/null +++ b/SLNN.lpi @@ -0,0 +1,90 @@ +<?xml version="1.0"?>
+<CONFIG>
+ <ProjectOptions>
+ <Version Value="9"/>
+ <PathDelim Value="\"/>
+ <General>
+ <SessionStorage Value="InProjectDir"/>
+ <MainUnit Value="0"/>
+ <Title Value="SLNN"/>
+ <ResourceType Value="res"/>
+ <UseXPManifest Value="True"/>
+ <Icon Value="0"/>
+ </General>
+ <i18n>
+ <EnableI18N LFM="False"/>
+ </i18n>
+ <VersionInfo>
+ <StringTable ProductVersion=""/>
+ </VersionInfo>
+ <BuildModes Count="1">
+ <Item1 Name="Default" Default="True"/>
+ </BuildModes>
+ <PublishOptions>
+ <Version Value="2"/>
+ <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+ <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+ </PublishOptions>
+ <RunParams>
+ <local>
+ <FormatVersion Value="1"/>
+ </local>
+ </RunParams>
+ <RequiredPackages Count="1">
+ <Item1>
+ <PackageName Value="LCL"/>
+ </Item1>
+ </RequiredPackages>
+ <Units Count="2">
+ <Unit0>
+ <Filename Value="SLNN.lpr"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="SLNN"/>
+ </Unit0>
+ <Unit1>
+ <Filename Value="slnnunit1.pas"/>
+ <IsPartOfProject Value="True"/>
+ <ComponentName Value="Form1"/>
+ <ResourceBaseClass Value="Form"/>
+ <UnitName Value="SLNNunit1"/>
+ </Unit1>
+ </Units>
+ </ProjectOptions>
+ <CompilerOptions>
+ <Version Value="11"/>
+ <PathDelim Value="\"/>
+ <Target>
+ <Filename Value="SLNN"/>
+ </Target>
+ <SearchPaths>
+ <IncludeFiles Value="$(ProjOutDir)"/>
+ <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+ </SearchPaths>
+ <Linking>
+ <Options>
+ <Win32>
+ <GraphicApplication Value="True"/>
+ </Win32>
+ </Options>
+ </Linking>
+ <Other>
+ <CompilerMessages>
+ <MsgFileName Value=""/>
+ </CompilerMessages>
+ <CompilerPath Value="$(CompPath)"/>
+ </Other>
+ </CompilerOptions>
+ <Debugging>
+ <Exceptions Count="3">
+ <Item1>
+ <Name Value="EAbort"/>
+ </Item1>
+ <Item2>
+ <Name Value="ECodetoolError"/>
+ </Item2>
+ <Item3>
+ <Name Value="EFOpenError"/>
+ </Item3>
+ </Exceptions>
+ </Debugging>
+</CONFIG>
diff --git a/SLNN.lpr b/SLNN.lpr new file mode 100644 index 0000000..5b0bac2 --- /dev/null +++ b/SLNN.lpr @@ -0,0 +1,21 @@ +program SLNN;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, SLNNunit1
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource := True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/Slitherlink.ico b/Slitherlink.ico Binary files differnew file mode 100644 index 0000000..0341321 --- /dev/null +++ b/Slitherlink.ico diff --git a/Slitherlink.lpi b/Slitherlink.lpi new file mode 100644 index 0000000..689eb5c --- /dev/null +++ b/Slitherlink.lpi @@ -0,0 +1,91 @@ +<?xml version="1.0"?>
+<CONFIG>
+ <ProjectOptions>
+ <Version Value="9"/>
+ <PathDelim Value="\"/>
+ <General>
+ <SessionStorage Value="InProjectDir"/>
+ <MainUnit Value="0"/>
+ <Title Value="Slitherlink"/>
+ <ResourceType Value="res"/>
+ <UseXPManifest Value="True"/>
+ <Icon Value="0"/>
+ </General>
+ <i18n>
+ <EnableI18N LFM="False"/>
+ </i18n>
+ <VersionInfo>
+ <StringTable ProductVersion=""/>
+ </VersionInfo>
+ <BuildModes Count="1">
+ <Item1 Name="Default" Default="True"/>
+ </BuildModes>
+ <PublishOptions>
+ <Version Value="2"/>
+ <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+ <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+ </PublishOptions>
+ <RunParams>
+ <local>
+ <FormatVersion Value="1"/>
+ </local>
+ </RunParams>
+ <RequiredPackages Count="1">
+ <Item1>
+ <PackageName Value="LCL"/>
+ </Item1>
+ </RequiredPackages>
+ <Units Count="2">
+ <Unit0>
+ <Filename Value="Slitherlink.lpr"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="Slitherlink"/>
+ </Unit0>
+ <Unit1>
+ <Filename Value="unit1.pas"/>
+ <IsPartOfProject Value="True"/>
+ <ComponentName Value="Form1"/>
+ <HasResources Value="True"/>
+ <ResourceBaseClass Value="Form"/>
+ <UnitName Value="Unit1"/>
+ </Unit1>
+ </Units>
+ </ProjectOptions>
+ <CompilerOptions>
+ <Version Value="11"/>
+ <PathDelim Value="\"/>
+ <Target>
+ <Filename Value="Slitherlink"/>
+ </Target>
+ <SearchPaths>
+ <IncludeFiles Value="$(ProjOutDir)"/>
+ <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+ </SearchPaths>
+ <Linking>
+ <Options>
+ <Win32>
+ <GraphicApplication Value="True"/>
+ </Win32>
+ </Options>
+ </Linking>
+ <Other>
+ <CompilerMessages>
+ <MsgFileName Value=""/>
+ </CompilerMessages>
+ <CompilerPath Value="$(CompPath)"/>
+ </Other>
+ </CompilerOptions>
+ <Debugging>
+ <Exceptions Count="3">
+ <Item1>
+ <Name Value="EAbort"/>
+ </Item1>
+ <Item2>
+ <Name Value="ECodetoolError"/>
+ </Item2>
+ <Item3>
+ <Name Value="EFOpenError"/>
+ </Item3>
+ </Exceptions>
+ </Debugging>
+</CONFIG>
diff --git a/Slitherlink.lpr b/Slitherlink.lpr new file mode 100644 index 0000000..2d703a3 --- /dev/null +++ b/Slitherlink.lpr @@ -0,0 +1,21 @@ +program Slitherlink;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, Unit1
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource := True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
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.
diff --git a/nnunit.pas b/nnunit.pas new file mode 100644 index 0000000..1f2cedd --- /dev/null +++ b/nnunit.pas @@ -0,0 +1,544 @@ +unit NNunit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, Dialogs, Math, ComCtrls, Forms;
+
+type
+ TExtendedArray = Array of Extended;
+ TLongintArray = Array of Longint;
+ TTrainingsset = Array of Array[Boolean] of TExtendedArray;
+
+ PTEbene = ^TEbene;
+
+ TNeuron = class(TObject)
+ Gewichte,altGew: TExtendedArray;
+ Nummer: Longint;
+ Schwelle,altSch,Wert,rohWert,
+ dPhi,ddPhi,Schranke,
+ Fehler,Ableitung,Kruemmung: Extended;
+ constructor create(vorherGroesze, Nr: Longint); overload;
+ constructor create(Neu: TNeuron); overload;
+ destructor destroy; override;
+ procedure berechnen(Elter: PTEbene);
+ procedure FehlerRueckPropagation(Kind: PTEbene);
+ procedure KruemmungVorPropagation(Elter: PTEbene);
+ procedure Ausgabeschichtfehler(Op: TExtendedArray);
+ procedure FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
+ procedure rueckgaengig;
+ function Gradientquadrat(Elter: PTEbene): Extended;
+ function toString: String; override;
+ end;
+
+ TEbene = class(TObject)
+ Neuronen: array of TNeuron;
+ constructor create(Groesze,vorherGroesze: Longint); overload;
+ constructor create(Eb: TEbene; WerteZufaellig: Boolean); overload;
+ destructor destroy; override;
+ procedure berechnen(Elter: PTEbene);
+ procedure FehlerRueckPropagation(Kind: PTEbene);
+ procedure KruemmungVorPropagation(Elter: PTEbene);
+ procedure Ausgabeschichtfehler(Op: TExtendedArray);
+ procedure FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
+ procedure rueckgaengig;
+ function Gradientquadrat(Elter: PTEbene): Extended;
+ function Kruemmung(Op: TExtendedArray): Extended;
+ function toString: String; override;
+ end;
+
+ TNeuronalesNetz = class(TObject)
+ Ebenen: array of TEbene;
+ constructor create(Tiefe,Groesze: Longint); overload;
+ constructor create(Groesze: TLongintArray); overload;
+ constructor create(NN: TNeuronalesNetz; WerteZufaellig: Boolean); overload;
+ constructor create(NN: TNeuronalesNetz); overload;
+ destructor destroy; override;
+ function Output(Input: TExtendedArray): TExtendedArray;
+ function Lerne(Ip,Op: TExtendedArray; Lernrate: Extended; Meldungen: Boolean): Extended;
+ procedure Trainieren(LR: Extended; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; Sortierung: Longint; Nachrichten: Boolean; out Ausgabe: String);
+ function Pruefen(Anz: Longint; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; out Ausgabe: String): Extended;
+ function toString: String; override;
+ end;
+
+implementation
+
+const Sf = 5;
+
+constructor TNeuron.create(vorherGroesze, Nr: Longint);
+var I: Longint;
+begin
+ inherited create;
+ Nummer:=Nr;
+ Setlength(Gewichte,vorherGroesze);
+ Setlength(altGew,vorherGroesze);
+ for I:=0 to length(Gewichte)-1 do begin
+ Gewichte[I]:=max(-Schranke,min(Schranke,(random-0.5)/vorherGroesze));
+ altGew[I]:=0;
+ end;
+ Schwelle:=max(-Schranke,min(Schranke,0.2*random-0.1));
+ altSch:=0;
+ rohWert:=0;
+ Wert:=1/2;
+ dPhi:=Sf/4;
+ ddPhi:=0;
+ Schranke:=100;
+ Fehler:=0;
+ Ableitung:=0;
+ Kruemmung:=0;
+end;
+
+constructor TNeuron.create(Neu: TNeuron);
+var I: Longint;
+begin
+ inherited create;
+ Nummer:=Neu.Nummer;
+ Setlength(Gewichte,length(Neu.Gewichte));
+ for I:=0 to length(Gewichte)-1 do
+ Gewichte[I]:=Neu.Gewichte[I];
+ Setlength(altGew,length(Neu.altGew));
+ for I:=0 to length(altGew)-1 do
+ altGew[I]:=Neu.altGew[I];
+ Schwelle:=neu.Schwelle;
+ altSch:=neu.altSch;
+ rohWert:=neu.rohWert;
+ Wert:=neu.Wert;
+ dPhi:=neu.dPhi;
+ ddPhi:=neu.ddPhi;
+ Fehler:=neu.Fehler;
+ Ableitung:=neu.Ableitung;
+ Kruemmung:=neu.Kruemmung;
+end;
+
+destructor TNeuron.destroy;
+begin
+ Setlength(Gewichte,0);
+ Setlength(altGew,0);
+ inherited destroy;
+end;
+
+procedure TNeuron.berechnen(Elter: PTEbene);
+var I: Longint;
+begin
+ rohWert:=-Schwelle;
+ for I:=0 to length(Gewichte)-1 do
+ rohWert:=rohWert + Elter^.Neuronen[I].Wert*Gewichte[I];
+ if rohWert>10/Sf then Wert:=1
+ else begin
+ if rohWert<-10/Sf then Wert:=0
+ else Wert:=1/(1+Exp(-Sf*rohWert));
+ end;
+ dPhi:=-Sf*Wert*(Wert-1);
+ ddPhi:=-Sf*dPhi*(2*Wert-1);
+end;
+
+procedure TNeuron.FehlerRueckPropagation(Kind: PTEbene);
+var I: Longint;
+begin
+ Fehler:=0;
+ for I:=0 to length(Kind^.Neuronen)-1 do
+ Fehler:=Fehler+Kind^.Neuronen[I].Fehler*Kind^.Neuronen[I].Gewichte[Nummer];
+ Fehler:=Fehler*dPhi;
+end;
+
+procedure TNeuron.KruemmungVorPropagation(Elter: PTEbene);
+var I: Longint;
+ Teil1,Teil2: Extended;
+begin
+ Teil1:=Fehler; // d Schwelle
+ Teil2:=0;
+ for I:=0 to length(Elter^.Neuronen)-1 do begin
+ Teil1:=Teil1
+ + Gewichte[I]*Elter^.Neuronen[I].Ableitung // w_ij * d n_i
+ + Fehler*sqr(Elter^.Neuronen[I].Wert); // n_i * d w_ij
+ Teil2:=Teil2
+ + Gewichte[I]*Elter^.Neuronen[I].Kruemmung // w_ij * d2 n_i
+ + 2*Fehler*Elter^.Neuronen[I].Wert * Elter^.Neuronen[I].Ableitung; // 2 * d w_ij * d n_i
+ end;
+ Kruemmung:=Teil2 * dPhi // Teil2 * phi'
+ + sqr(Teil1) * ddPhi; // Teil1^2 * phi''
+ Ableitung:=Teil1 * dPhi; // Teil1 * phi'
+end;
+
+procedure TNeuron.Ausgabeschichtfehler(Op: TExtendedArray);
+begin
+ Fehler:=Wert-Op[Nummer];
+ Fehler:=Fehler*dPhi;
+end;
+
+procedure TNeuron.FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
+var I: Longint;
+begin
+ for I:=0 to length(Gewichte)-1 do begin
+ altGew[I]:=Gewichte[I];
+ Gewichte[I]:=max(-Schranke,min(Schranke,Gewichte[I]-Lernrate*Fehler*Elter^.Neuronen[I].Wert));
+ end;
+ altSch:=Schwelle;
+ Schwelle:=max(-Schranke,min(Schranke,Schwelle-Lernrate*Fehler));
+end;
+
+procedure TNeuron.rueckgaengig;
+var I: Longint;
+begin
+ for I:=0 to length(Gewichte)-1 do
+ Gewichte[I]:=altGew[I];
+ Schwelle:=altSch;
+end;
+
+function TNeuron.Gradientquadrat(Elter: PTEbene): Extended;
+var I: Longint;
+begin
+ result:=0;
+ for I:=0 to length(Elter^.Neuronen)-1 do
+ result:=result+sqr(Elter^.Neuronen[I].Wert*Gewichte[I]*Fehler);
+end;
+
+function TNeuron.toString: String;
+var I: Longint;
+begin
+ result:=floattostr(Schwelle);
+ for I:=0 to length(Gewichte)-1 do
+ result:=result+' '+floattostr(Gewichte[I]);
+end;
+
+constructor TEbene.create(Groesze,vorherGroesze: Longint);
+var I: Longint;
+begin
+ inherited create;
+ Setlength(Neuronen,Groesze);
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I]:=TNeuron.create(vorherGroesze,I);
+end;
+
+constructor TEbene.create(Eb: TEbene; WerteZufaellig: Boolean);
+var I: Longint;
+begin
+ inherited create;
+ Setlength(Neuronen,length(Eb.Neuronen));
+ for I:=0 to length(Neuronen)-1 do
+ if WerteZufaellig then
+ Neuronen[I]:=TNeuron.create(length(Eb.Neuronen[0].Gewichte),I)
+ else Neuronen[I]:=TNeuron.create(Eb.Neuronen[I]);
+end;
+
+destructor TEbene.destroy;
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].Free;
+ Setlength(Neuronen,0);
+ inherited destroy;
+end;
+
+procedure TEbene.berechnen(Elter: PTEbene);
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].berechnen(Elter);
+end;
+
+procedure TEbene.FehlerRueckPropagation(Kind: PTEbene);
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].FehlerRueckPropagation(Kind);
+end;
+
+procedure TEbene.KruemmungVorPropagation(Elter: PTEbene);
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].KruemmungVorPropagation(Elter);
+end;
+
+procedure TEbene.Ausgabeschichtfehler(Op: TExtendedArray);
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].Ausgabeschichtfehler(Op);
+end;
+
+procedure TEbene.FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].FehlerEinarbeiten(Elter,Lernrate);
+end;
+
+procedure TEbene.rueckgaengig;
+var I: Longint;
+begin
+ for I:=0 to length(Neuronen)-1 do
+ Neuronen[I].rueckgaengig;
+end;
+
+function TEbene.Gradientquadrat(Elter: PTEbene): Extended;
+var I: Longint;
+begin
+ result:=0;
+ for I:=0 to length(Neuronen)-1 do
+ result:=result + Neuronen[I].Gradientquadrat(Elter);
+end;
+
+function TEbene.Kruemmung(Op: TExtendedArray): Extended;
+var I: Longint;
+begin
+ result:=0;
+ for I:=0 to length(Neuronen)-1 do
+ result:=result
+ + sqr(Neuronen[I].Ableitung)
+ + (Neuronen[I].Wert-Op[I])*Neuronen[I].Kruemmung;
+end;
+
+function TEbene.toString: String;
+var I: Longint;
+begin
+ result:='';
+ for I:=0 to length(Neuronen)-1 do begin
+ result:=result+Neuronen[I].toString;
+ if I<length(Neuronen)-1 then result:=result+#13;
+ end;
+end;
+
+constructor TNeuronalesNetz.create(Tiefe,Groesze: Longint);
+var G: TLongintArray;
+ I: Longint;
+begin
+ setlength(G,Tiefe);
+ for I:=0 to length(G)-1 do
+ G[I]:=Groesze;
+ create(G);
+end;
+
+constructor TNeuronalesNetz.create(Groesze: TLongintArray);
+var I: Longint;
+begin
+ inherited create;
+ Setlength(Ebenen,length(Groesze));
+ for I:=0 to length(Ebenen)-1 do
+ Ebenen[I]:=TEbene.create(Groesze[I],Groesze[I-Byte(I>0)]*Byte(I>0));
+end;
+
+constructor TNeuronalesNetz.create(NN: TNeuronalesNetz);
+begin
+ create(NN,false);
+end;
+
+constructor TNeuronalesNetz.create(NN: TNeuronalesNetz; WerteZufaellig: Boolean);
+var I: Longint;
+begin
+ inherited create;
+ setlength(Ebenen,length(NN.Ebenen));
+ for I:=0 to length(Ebenen)-1 do
+ Ebenen[I]:=TEbene.Create(NN.Ebenen[I],WerteZufaellig);
+end;
+
+destructor TNeuronalesNetz.destroy;
+var I: Longint;
+begin
+ for I:=0 to length(Ebenen)-1 do
+ Ebenen[I].Free;
+ Setlength(Ebenen,0);
+ inherited destroy;
+end;
+
+function TNeuronalesNetz.Output(Input: TExtendedArray): TExtendedArray;
+var I: Longint;
+begin
+ if length(Input)<>length(Ebenen[0].Neuronen) then begin
+ MessageDlg('Eingabelänge ('+inttostr(length(Input))+') ist ungleich der Anzahl Neuronen in der ersten Ebene ('+inttostr(length(Ebenen[0].Neuronen))+')!',mtError,[mbOk],0);
+ exit;
+ end;
+ for I:=0 to length(Input)-1 do
+ Ebenen[0].Neuronen[I].Wert:=Input[I];
+ for I:=1 to length(Ebenen)-1 do
+ Ebenen[I].berechnen(@(Ebenen[I-1]));
+ Setlength(result,length(Ebenen[length(Ebenen)-1].Neuronen));
+ for I:=0 to length(result)-1 do
+ result[I]:=Ebenen[length(Ebenen)-1].Neuronen[I].Wert;
+end;
+
+function TNeuronalesNetz.Lerne(Ip,Op: TExtendedArray; Lernrate: Extended; Meldungen: Boolean): Extended;
+var I,Ausdauer: Longint;
+ iO: TExtendedArray;
+ Fehler0,
+ lFehler,
+ aFehler,
+ LR: Extended;
+begin
+ iO:=Output(Ip);
+ Fehler0:=0;
+ for I:=0 to length(iO)-1 do
+ Fehler0:=Fehler0+sqr(iO[I]-Op[I]);
+
+ lFehler:=Fehler0;
+ Ausdauer:=100;
+
+ repeat
+ Ebenen[length(Ebenen)-1].Ausgabeschichtfehler(Op);
+ for I:=length(Ebenen)-2 downto 1 do
+ Ebenen[I].FehlerRueckPropagation(@(Ebenen[I+1]));
+ LR:=0;
+ for I:=1 to length(Ebenen)-1 do begin
+ Ebenen[I].KruemmungVorPropagation(@(Ebenen[I-1]));
+ LR:=LR+Ebenen[I].Gradientquadrat(@(Ebenen[I-1]));
+ end;
+ LR:=LR/Ebenen[length(Ebenen)-1].Kruemmung(Op);
+ if LR<0 then
+ LR:=Lernrate;
+ For I:=length(Ebenen)-1 downto 1 do
+ Ebenen[I].FehlerEinarbeiten(@(Ebenen[I-1]),LR);
+ iO:=Output(Ip);
+ aFehler:=0;
+ for I:=0 to length(iO)-1 do
+ aFehler:=aFehler+sqr(iO[I]-Op[I]);
+ if aFehler>lFehler then begin
+ For I:=1 to length(Ebenen)-1 do
+ Ebenen[I].rueckgaengig;
+ if Meldungen and (aFehler-lFehler >= 0.1 * Fehler0) then
+ MessageDlg('Keine Verbesserung erreicht! '+floattostr(aFehler-lFehler)+'/'+floattostr(lFehler),mtError,[mbOk],0);
+ LR:=LR/2;
+ end;
+ if aFehler-lFehler >= -0.01 * Fehler0 then dec(Ausdauer);
+ lFehler:=aFehler;
+ until true; //(aFehler<0.01*Fehler0) or (Ausdauer<0);
+
+(* lFehler:=Fehler0;
+
+ LR:=Lernrate;
+
+ repeat
+ Ebenen[length(Ebenen)-1].Ausgabeschichtfehler(Op);
+ For I:=length(Ebenen)-2 downto 1 do
+ Ebenen[I].FehlerRueckPropagation(@(Ebenen[I+1]));
+ For I:=length(Ebenen)-1 downto 1 do
+ Ebenen[I].FehlerEinarbeiten(@(Ebenen[I-1]),LR);
+ iO:=Output(Ip);
+ aFehler:=0;
+ for I:=0 to length(iO)-1 do
+ aFehler:=aFehler+sqr(iO[I]-Op[I]);
+ if aFehler-lFehler >= 0 then LR:=LR*0.2;
+ if lFehler-aFehler > 0 then LR:=LR*1.2;
+ lFehler:=aFehler;
+ until (LR>100*Lernrate) or (LR<0.01*Lernrate) or (aFehler<0.1*Fehler0); *)
+ result:=Fehler0-aFehler;
+end;
+
+procedure TNeuronalesNetz.Trainieren(LR: Extended; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; Sortierung: Longint; Nachrichten: Boolean; out Ausgabe: String);
+var I,J,K: Longint;
+ Erfolg,
+ Fortschritt,
+ Rueckschritt: Extended;
+ Perm: TLongintArray;
+begin
+ Setlength(Perm,length(TS));
+ case Sortierung of
+ 0: begin
+ for I:=0 to length(Perm)-1 do
+ Perm[I]:=-1;
+ for I:=0 to length(Perm)-1 do begin
+ J:=Random(length(Perm)-I);
+ K:=-1;
+ repeat
+ inc(K);
+ if Perm[K]<>-1 then inc(J);
+ until K>=J;
+ Perm[J]:=I;
+ end;
+ end;
+ 1:
+ for I:=0 to length(Perm)-1 do
+ Perm[I]:=I;
+ -1:
+ for I:=0 to length(Perm)-1 do
+ Perm[I]:=length(Perm)-1-I;
+ end{of case};
+ PB.Min:=1;
+ PB.Max:=Min(100,length(TS));
+ PB.Position:=1;
+ PB.Visible:=True;
+ Fortschritt:=0;
+ Rueckschritt:=0;
+ for I:=0 to length(TS)-1 do begin
+ Erfolg:=Lerne(TS[Perm[I],false],TS[Perm[I],true],LR,Nachrichten);
+ Rueckschritt:=Max(Rueckschritt,-Erfolg);
+ Fortschritt:=Max(Fortschritt,Erfolg);
+ if ((100*I) div length(TS) > (100*(I-1)) div length(TS)) then begin
+ PB.StepIt;
+ AP.ProcessMessages;
+ end;
+ end;
+ PB.Visible:=False;
+ Ausgabe:='Fortschritt: '+floattostr(Fortschritt)+' Rückschritt: '+floattostr(Rueckschritt);
+end;
+
+function TNeuronalesNetz.Pruefen(Anz: Longint; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; out Ausgabe: String): Extended;
+var I,J,K,L,gut,StGut: Longint;
+ dasistgut: Boolean;
+ Fehler: Extended;
+ Op: TExtendedArray;
+ Vari: TLongintArray;
+begin
+ Anz:=min(Anz,length(TS));
+ Setlength(Vari,Anz);
+ if Anz>=length(TS) then begin
+ for I:=0 to length(Vari)-1 do
+ Vari[I]:=I;
+ end
+ else begin
+ for I:=0 to length(Vari)-1 do begin
+ J:=Random(length(TS)-I);
+ K:=0;
+ while K<=J do begin
+ for L:=0 to I-1 do
+ if Vari[L]=K then begin
+ inc(J);
+ break;
+ end;
+ inc(K);
+ end;
+ Vari[I]:=J;
+ end;
+ end;
+ gut:=0;
+ StGut:=0;
+ PB.Min:=1;
+ PB.Max:=Min(100,Anz);
+ PB.Position:=1;
+ PB.Visible:=True;
+ Fehler:=0;
+ for I:=0 to length(Vari)-1 do begin
+ Op:=Output(TS[Vari[I],false]);
+ dasistgut:=true;
+ for J:=0 to 9 do begin
+ Fehler:=Fehler + Sqr(Op[J] - TS[Vari[I],true,J]);
+ dasistgut:=dasistgut and ((Op[J]<0.5) xor (TS[Vari[I],true,J]>=0.5));
+ StGut:=StGut + Byte((Op[J]<0.5) xor (TS[Vari[I],true,J]>=0.5));
+ end;
+ gut:=gut+byte(dasistgut);
+ if ((100*I) div Anz > (100*(I-1)) div Anz) then begin
+ PB.StepIt;
+ AP.ProcessMessages;
+ end;
+ end;
+ PB.Visible:=False;
+ Ausgabe:=inttostr(gut)+'/'+inttostr(Anz)+' -> '+floattostr(100*gut/Anz)+'%, '+floattostr(100*Stgut/Anz/10)+'% Fehler: '+floattostr(Fehler/Anz);
+ result:=(gut+0.01)/Anz;
+end;
+
+function TNeuronalesNetz.toString: String;
+var I: Longint;
+begin
+ result:='';
+ for I:=1 to length(Ebenen)-1 do begin
+ result:=result+Ebenen[I].toString;
+ if I<length(Ebenen)-1 then
+ result:=result+#13#13;
+ end;
+end;
+
+
+end.
+
diff --git a/slnnunit1.lfm b/slnnunit1.lfm new file mode 100644 index 0000000..a4d5ae0 --- /dev/null +++ b/slnnunit1.lfm @@ -0,0 +1,40 @@ +object Form1: TForm1
+ Left = 441
+ Height = 483
+ Top = 228
+ Width = 606
+ Caption = 'Form1'
+ ClientHeight = 483
+ ClientWidth = 606
+ OnCreate = FormCreate
+ OnResize = FormResize
+ LCLVersion = '1.0.2.0'
+ object Button1: TButton
+ Left = 8
+ Height = 25
+ Top = 8
+ Width = 88
+ Caption = 'Lernsatz laden'
+ OnClick = Button1Click
+ TabOrder = 0
+ end
+ object Memo1: TMemo
+ Left = 8
+ Height = 376
+ Top = 96
+ Width = 376
+ Lines.Strings = (
+ 'Memo1'
+ )
+ TabOrder = 1
+ end
+ object OpenDialog1: TOpenDialog
+ Options = [ofAllowMultiSelect, ofEnableSizing, ofViewDetail]
+ left = 8
+ top = 40
+ end
+ object SaveDialog1: TSaveDialog
+ left = 56
+ top = 40
+ end
+end
diff --git a/slnnunit1.pas b/slnnunit1.pas new file mode 100644 index 0000000..51f600c --- /dev/null +++ b/slnnunit1.pas @@ -0,0 +1,161 @@ +unit SLNNunit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
+ NNUnit;
+
+type
+
+ { TForm1 }
+
+ TBeispiel = record
+ Schl: Boolean;
+ _Br,_Ho,
+ WasIstGut: Integer;
+ Felder,
+ Kanten: Array of Byte;
+ end;
+
+ TForm1 = class(TForm)
+ Button1: TButton;
+ Memo1: TMemo;
+ OpenDialog1: TOpenDialog;
+ SaveDialog1: TSaveDialog;
+ procedure Button1Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormResize(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ LernSatz: Array of TBeispiel;
+ function LadeLernSatz(Nam: String): Boolean;
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormResize(Sender: TObject);
+begin
+ Memo1.Width:=Form1.ClientWidth - 2*Memo1.Left;
+ Memo1.Height:=Form1.ClientHeight - Memo1.Left - Memo1.Top;
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var I: Longint;
+begin
+ if OpenDialog1.Execute then
+ for I:=0 to OpenDialog1.Files.Count-1 do
+ if not LadeLernSatz(OpenDialog1.Files[I]) then
+ MessageDlg('Datei '''+OpenDialog1.Files[I]+''' ist ungültig!',mtError,[mbOk],0);
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ Setlength(LernSatz,0);
+end;
+
+function TForm1.LadeLernSatz(Nam: String): Boolean;
+var F: File;
+ B: Byte;
+ J,Gr: Longint;
+ Schleife: Boolean;
+ _Breite,
+ _Hoehe: Integer;
+ Eimer: Array of Array[0..4] of Integer;
+ Daten: Array[Boolean] of Array of Byte;
+// Input,
+// Output: TLongintArray;
+begin
+ Result:=false;
+ if not FileExists(Nam) then exit;
+ Setlength(Eimer,0);
+ AssignFile(F,Nam);
+ Reset(F,1);
+ B:=0;
+ _Breite:=1;
+ _Hoehe:=1;
+ while not eof(F) do begin
+ BlockRead(F,B,1);
+ if B>1 then begin
+ CloseFile(F);
+ exit;
+ end;
+ Schleife:=B=1;
+ if eof(F) then begin
+ CloseFile(F);
+ exit;
+ end;
+ BlockRead(F,_Breite,4);
+ if eof(F) then begin
+ CloseFile(F);
+ exit;
+ end;
+ BlockRead(F,_Hoehe,4);
+ J:=0;
+ while J<length(Eimer) do begin
+ if (Eimer[J,0]=Byte(Schleife)) and
+ (Eimer[J,1]=_Hoehe) and
+ (Eimer[J,2]=_Breite) then begin
+ inc(Eimer[J,3]);
+ break;
+ end;
+ inc(J);
+ end;
+ if J>=length(Eimer) then begin
+ setlength(Eimer,length(Eimer)+1);
+ Eimer[J,0]:=Byte(Schleife);
+ Eimer[J,1]:=_Hoehe;
+ Eimer[J,2]:=_Breite;
+ Eimer[J,3]:=1;
+ end;
+ Setlength(Daten[false],2*(_Breite-Byte(not Schleife)+1)*(_Hoehe-Byte(not Schleife)+1)-2); // Kanten
+ Setlength(Daten[true],(_Breite-Byte(not Schleife)+1)*(_Hoehe-Byte(not Schleife))-1); // Felder
+ for J:=0 to 1 do begin
+ if eof(F) then begin
+ CloseFile(F);
+ exit;
+ end;
+ BlockRead(F,Daten[J=1,0],length(Daten[J=1]));
+ end;
+ if eof(F) then begin
+ CloseFile(F);
+ exit;
+ end;
+ BlockRead(F,J,4);
+ SetLength(LernSatz,length(LernSatz)+1);
+ with LernSatz[length(LernSatz)-1] do begin
+ Schl:=Schleife;
+ _Br:=_Breite;
+ _Ho:=_Hoehe;
+ WasIstGut:=J;
+ SetLength(Kanten,length(Daten[false]));
+ for J:=0 to length(Kanten)-1 do
+ Kanten[J]:=Daten[false,J];
+ SetLength(Felder,length(Daten[true]));
+ for J:=0 to length(Felder)-1 do
+ Felder[J]:=Daten[true,J];
+ end;
+ end;
+ Closefile(F);
+ for J:=0 to length(Eimer)-1 do
+ Memo1.Lines.Add(inttostr(Eimer[J,0])+' '+inttostr(Eimer[J,1])+' '+inttostr(Eimer[J,2])+' '+inttostr(Eimer[J,3]));
+ Gr:=0;
+ for J:=0 to length(LernSatz)-1 do
+ Gr:=Gr+length(LernSatz[J].Kanten)+length(LernSatz[J].Felder);
+ Memo1.Lines.Add(inttostr(length(LernSatz))+' Beispiele insgesamt ('+floattostr((length(LernSatz)*sizeOf(TBeispiel)+Gr)/1024/1024)+'MB)');
+ Result:=true;
+end;
+
+end.
+
diff --git a/unit1.lfm b/unit1.lfm new file mode 100644 index 0000000..7d13593 --- /dev/null +++ b/unit1.lfm @@ -0,0 +1,125 @@ +object Form1: TForm1
+ Left = 282
+ Height = 325
+ Top = 130
+ Width = 647
+ Caption = 'Form1'
+ ClientHeight = 325
+ ClientWidth = 647
+ OnActivate = FormActivate
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ OnKeyDown = FormKeyDown
+ OnResize = FormResize
+ LCLVersion = '1.0.2.0'
+ object Button1: TButton
+ Left = 0
+ Height = 25
+ Top = 0
+ Width = 67
+ Caption = 'erzeugen'
+ OnClick = Button1Click
+ TabOrder = 0
+ end
+ object SpinEdit1: TSpinEdit
+ Left = 72
+ Height = 21
+ Hint = 'Breite'
+ Top = 2
+ Width = 56
+ OnChange = SpinEdit1Change
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 1
+ Value = 5
+ end
+ object SpinEdit2: TSpinEdit
+ Left = 136
+ Height = 21
+ Hint = 'Höhe'
+ Top = 2
+ Width = 56
+ OnChange = SpinEdit2Change
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 2
+ Value = 5
+ end
+ object SpinEdit3: TSpinEdit
+ Left = 200
+ Height = 21
+ Hint = 'Höhe'
+ Top = 2
+ Width = 56
+ OnChange = SpinEdit3Change
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 3
+ Value = 16
+ end
+ object ProgressBar1: TProgressBar
+ Left = 584
+ Height = 21
+ Top = 2
+ Width = 100
+ TabOrder = 4
+ end
+ object Button2: TButton
+ Left = 340
+ Height = 25
+ Top = 0
+ Width = 48
+ Caption = 'zurück'
+ OnClick = Button2Click
+ TabOrder = 5
+ end
+ object Button3: TButton
+ Left = 392
+ Height = 25
+ Top = 0
+ Width = 48
+ Caption = 'laden'
+ OnClick = Button3Click
+ TabOrder = 6
+ end
+ object Button4: TButton
+ Left = 444
+ Height = 25
+ Top = 0
+ Width = 67
+ Caption = 'speichern'
+ OnClick = Button4Click
+ TabOrder = 7
+ end
+ object Button5: TButton
+ Left = 515
+ Height = 25
+ Top = 0
+ Width = 64
+ Caption = 'erzeugen'
+ OnClick = Button5Click
+ TabOrder = 8
+ end
+ object CheckBox1: TCheckBox
+ Left = 260
+ Height = 17
+ Top = 4
+ Width = 78
+ Caption = 'geschlossen'
+ OnChange = CheckBox1Change
+ TabOrder = 9
+ end
+ object Timer1: TTimer
+ Interval = 100
+ OnTimer = Timer1Timer
+ top = 32
+ end
+ object OpenDialog1: TOpenDialog
+ left = 32
+ top = 32
+ end
+ object SaveDialog1: TSaveDialog
+ left = 64
+ top = 32
+ end
+end
diff --git a/unit1.pas b/unit1.pas new file mode 100644 index 0000000..c4fa179 --- /dev/null +++ b/unit1.pas @@ -0,0 +1,179 @@ +unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
+ Spin, ComCtrls, ExtCtrls, SlitherlinkUnit;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ Button1: TButton;
+ Button2: TButton;
+ Button3: TButton;
+ Button4: TButton;
+ Button5: TButton;
+ CheckBox1: TCheckBox;
+ OpenDialog1: TOpenDialog;
+ ProgressBar1: TProgressBar;
+ SaveDialog1: TSaveDialog;
+ SpinEdit1: TSpinEdit;
+ SpinEdit2: TSpinEdit;
+ SpinEdit3: TSpinEdit;
+ Timer1: TTimer;
+ procedure Button1Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure Button5Click(Sender: TObject);
+ procedure CheckBox1Change(Sender: TObject);
+ procedure FormActivate(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+ procedure FormResize(Sender: TObject);
+ procedure SpinEdit1Change(Sender: TObject);
+ procedure SpinEdit2Change(Sender: TObject);
+ procedure SpinEdit3Change(Sender: TObject);
+ procedure Timer1Timer(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ Feld: TFeld;
+ GenThread: TGenerierungsThread;
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ Feld:=TFeld.Create(Form1);
+ Feld.Lerndatei:=Extractfilepath(Application.Exename)+'gelerntes.dat';
+ Feld.Oben:=32;
+ Form1.OnKeyPress:=@(Feld.OnKeyPress);
+ SpinEdit1.OnKeyPress:=@(Feld.OnKeyPress);
+ SpinEdit2.OnKeyPress:=@(Feld.OnKeyPress);
+ SpinEdit3.OnKeyPress:=@(Feld.OnKeyPress);
+ Button1.OnKeyPress:=@(Feld.OnKeyPress);
+ Button2.OnKeyPress:=@(Feld.OnKeyPress);
+ Button3.OnKeyPress:=@(Feld.OnKeyPress);
+ Button4.OnKeyPress:=@(Feld.OnKeyPress);
+ Button5.OnKeyPress:=@(Feld.OnKeyPress);
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+ if Button1.Caption = 'erzeugen' then Feld.Erzeugen(Progressbar1)
+ else Feld.LoadFromFeld(GenThread.Feld);
+ Feld.Zeichnen;
+ if Assigned(GenThread) then GenThread.destroy;
+ GenThread:=TGenerierungsThread.create(Spinedit1.Value,Spinedit2.Value,Progressbar1,nil,Checkbox1.Checked);
+ Button1.Caption:='noch eins';
+ Button1.Enabled:=false;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+begin
+ Feld.RueckGaengig;
+ Feld.Zeichnen;
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+begin
+ if OpenDialog1.Execute then
+ if Feld.LoadFromFile(OpenDialog1.FileName) then Feld.Zeichnen
+ else MessageDlg('Ungültiges Dateiformat!',mterror,[mbOk],0);
+end;
+
+procedure TForm1.Button4Click(Sender: TObject);
+begin
+ if SaveDialog1.Execute then
+ Feld.SaveToFile(SaveDialog1.FileName);
+end;
+
+procedure TForm1.Button5Click(Sender: TObject);
+begin
+ Feld.Erzeugen(Progressbar1,true);
+end;
+
+procedure TForm1.CheckBox1Change(Sender: TObject);
+begin
+ Feld.Schleife:=Checkbox1.Checked;
+ Feld.Zeichnen;
+end;
+
+procedure TForm1.FormActivate(Sender: TObject);
+var I: Integer;
+begin
+ For I:=0 to Form1.ComponentCount-1 do begin
+ if Form1.Components[I] is TButton then
+ (Form1.Components[I] as TButton).OnKeyDown:=Form1.OnKeyDown;
+ if Form1.Components[I] is TSpinEdit then
+ (Form1.Components[I] as TSpinEdit).OnKeyDown:=Form1.OnKeyDown;
+ end;
+end;
+
+procedure TForm1.FormDestroy(Sender: TObject);
+begin
+ Feld.Destroy;
+ if assigned(GenThread) then GenThread.destroy;
+end;
+
+procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState
+ );
+var C: Char;
+begin
+ if Key in [ord('c'),ord('x'),ord('y')] then
+ begin
+ C:=char(Key);
+ Feld.OnKeyPress(Sender,C);
+ Key:=0;
+ end;
+end;
+
+procedure TForm1.FormResize(Sender: TObject);
+begin
+ Progressbar1.Width:=Form1.ClientWidth-Progressbar1.Left;
+end;
+
+procedure TForm1.SpinEdit1Change(Sender: TObject);
+begin
+ Feld.Breite:=SpinEdit1.Value;
+ Feld.Zeichnen;
+end;
+
+procedure TForm1.SpinEdit2Change(Sender: TObject);
+begin
+ Feld.Hoehe:=SpinEdit2.Value;
+ Feld.Zeichnen;
+end;
+
+procedure TForm1.SpinEdit3Change(Sender: TObject);
+begin
+ Feld.Optionen.Schriftgroesse:=Spinedit3.Value;
+ Feld.Zeichnen;
+end;
+
+procedure TForm1.Timer1Timer(Sender: TObject);
+begin
+ if Assigned(GenThread) and (GenThread.Fertig=1) then begin
+ GenThread.Fertig:=2;
+ Button1.Enabled:=true;
+ end;
+end;
+
+end.
+
|