From 4fb084a6af9200f60e4297a215b8a14f3d70dc40 Mon Sep 17 00:00:00 2001 From: Erich Eckner Date: Fri, 28 Oct 2016 09:33:51 +0200 Subject: initial Commit --- .gitignore | 72 +++ RaetselFileUnit.pas | 291 ++++++++++ SLNN.ico | Bin 0 -> 137040 bytes SLNN.lpi | 90 +++ SLNN.lpr | 21 + Slitherlink.ico | Bin 0 -> 137040 bytes Slitherlink.lpi | 91 +++ Slitherlink.lpr | 21 + SlitherlinkUnit.pas | 1548 +++++++++++++++++++++++++++++++++++++++++++++++++++ nnunit.pas | 544 ++++++++++++++++++ slnnunit1.lfm | 40 ++ slnnunit1.pas | 161 ++++++ unit1.lfm | 125 +++++ unit1.pas | 179 ++++++ 14 files changed, 3183 insertions(+) create mode 100644 .gitignore create mode 100644 RaetselFileUnit.pas create mode 100644 SLNN.ico create mode 100644 SLNN.lpi create mode 100644 SLNN.lpr create mode 100644 Slitherlink.ico create mode 100644 Slitherlink.lpi create mode 100644 Slitherlink.lpr create mode 100644 SlitherlinkUnit.pas create mode 100644 nnunit.pas create mode 100644 slnnunit1.lfm create mode 100644 slnnunit1.pas create mode 100644 unit1.lfm create mode 100644 unit1.pas 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)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 new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/SLNN.ico differ diff --git a/SLNN.lpi b/SLNN.lpi new file mode 100644 index 0000000..766bcd1 --- /dev/null +++ b/SLNN.lpi @@ -0,0 +1,90 @@ + + + + + + + + + + <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 new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Slitherlink.ico differ 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. + -- cgit v1.2.3-54-g00ecf