summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore17
-rw-r--r--energiefunktion.inc221
-rw-r--r--grampsmath.pas79
-rw-r--r--grampstypen.pas2050
-rw-r--r--grampsunit.pas4674
-rwxr-xr-xmake3
-rw-r--r--stabile.lpi93
-rw-r--r--stabile.lpr95
-rw-r--r--stabile.lps194
9 files changed, 7426 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..00ca7bf
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,17 @@
+*.bmp
+*.png
+*.bak
+*.ppu
+*.o
+*.zip
+*.tar.gz
+*.out
+*.gramps
+*.exe
+*.backup
+*.gz
+*.xml
+lib
+*~
+Log*
+stabile
diff --git a/energiefunktion.inc b/energiefunktion.inc
new file mode 100644
index 0000000..946bd96
--- /dev/null
+++ b/energiefunktion.inc
@@ -0,0 +1,221 @@
+{$IFDEF Energie}
+{$IFDEF Gradient}
+ Ich kann nur Energie _oder_ Gradient berechnen!
+ Bitte Compilerschalter richtig setzen!
+{$ENDIF}
+{$ENDIF}
+
+{$IFNDEF Energie}
+{$IFNDEF Gradient}
+ Ich muss mindestens Energie oder Gradient berechnen!
+ Bitte Compilerschalter richtig setzen!
+{$ENDIF}
+{$ENDIF}
+
+// berechnet die Energie oder den Gradienten
+var
+ i,j,k: Longint;
+ tmp,tmp2: extended;
+{$IFDEF Gradient}
+ px,py,tmp3: extended;
+{$ENDIF}
+
+begin
+
+ // Initialisierung
+ {$IFDEF Energie}
+ Kreuzungen:=0;
+ Kreuzung:=-1;
+ result:=0;
+ {$ENDIF}
+ {$IFDEF Gradient}
+ if length(grad)<>length(p) then begin
+ writeln('*** Warnung ***');
+ writeln('Länge das Gradienten wurde angepasst!');
+ setlength(grad,length(p));
+ end;
+ for i:=0 to length(grad)-1 do
+ grad[i]:=0;
+ {$ENDIF}
+
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then ffTimer.start;
+ {$ENDIF}
+
+ for I:=0 to length(FFInteraktionen)-1 do
+ with FFInteraktionen[I] do
+ // auf Kreuzung prüfen:
+ // ((B1-A1)x(A2-A1))*((B2-A1)x(A2-A1))<=0 und
+ // ((A1-B1)x(B2-B1))*((A2-B1)x(B2-B1))<=0 <=> Kreuzung
+ if (KreuzproduktZ(P,_Fs[1].Eltern[0],_Fs[0].Eltern[0],_Fs[0].Eltern[1],_Fs[0].Eltern[0]) *
+ KreuzproduktZ(P,_Fs[1].Eltern[1],_Fs[0].Eltern[0],_Fs[0].Eltern[1],_Fs[0].Eltern[0]) <= 0 ) and
+ (KreuzproduktZ(P,_Fs[0].Eltern[0],_Fs[1].Eltern[0],_Fs[1].Eltern[1],_Fs[1].Eltern[0]) *
+ KreuzproduktZ(P,_Fs[0].Eltern[1],_Fs[1].Eltern[0],_Fs[1].Eltern[1],_Fs[1].Eltern[0]) <= 0 )
+ then begin
+ {$IFDEF Energie}
+ inc(Kreuzungen);
+ if (Kreuzung=-1) or
+ (random*Kreuzungen<1) then Kreuzung:=i; // eine Kreuzung zufällig, gleichverteilt auswählen
+ {$ENDIF}
+
+ // jetzt soll belohnt (!) werden, wenn ein Elternteil der einen Familie nah an der "Kante" der anderen Familie liegt
+ // -> dadurch kann eine Energie-Optimierung auch Kreuzungen entfernen
+ for j:=0 to 1 do // Familie
+ for k:=0 to 1 do begin // Elter
+ tmp:=(1e-9 + (QAbstand(P,_FS[j].Eltern[k],_FS[1-j].Eltern[0])
+ - ( sqr(Skalarprodukt(P,_FS[j].Eltern[k],_FS[1-j].Eltern[0],_FS[1-j].Eltern[1],_FS[1-j].Eltern[0]))
+ / (1e-9+QAbstand(P,_FS[1-j].Eltern[1],_FS[1-j].Eltern[0])))));
+ {$IFDEF Energie}
+ result:=result - Entkreuzungsbelohnungsskalierung * 1/tmp;
+ {$ENDIF}
+ {$IFDEF Gradient}
+ px:= P[_FS[1-j].Eltern[1].p2]-P[_FS[1-j].Eltern[0].p2];
+ py:=-P[_FS[1-j].Eltern[1].p1]+P[_FS[1-j].Eltern[0].p1];
+ tmp2:=1/sqrt(sqr(px)+sqr(py)+epsilon);
+ if (px*(P[_FS[j].Eltern[k].p1]-P[_FS[1-j].Eltern[0].p1])+py*(P[_FS[j].Eltern[k].p2]-P[_FS[1-j].Eltern[0].p2]) <= 0) then
+ tmp2:=-tmp2;
+ px:=px*tmp2;
+ py:=py*tmp2;
+ tmp2:=Entkreuzungsbelohnungsskalierung*2/sqr(tmp)*sqrt(tmp);
+
+ tmp:=Skalarprodukt(P,_FS[j].Eltern[k],_FS[1-j].Eltern[0],_FS[1-j].Eltern[1],_FS[1-j].Eltern[0]) / // (P-F1)*(F2-F1) / (F2-F1)^2
+ (1e-9+QAbstand(P,_FS[1-j].Eltern[1],_FS[1-j].Eltern[0]));
+
+ grad[_FS[j].Eltern[k].p1]:= // Ableitungen nach Position der Person
+ grad[_FS[j].Eltern[k].p1] + tmp2*px;
+ grad[_FS[j].Eltern[k].p2]:=
+ grad[_FS[j].Eltern[k].p2] + tmp2*py;
+
+ grad[_FS[1-j].Eltern[0].p1]:= // Ableitungen nach Position der Eltern
+ grad[_FS[1-j].Eltern[0].p1] - tmp2*(1-tmp)*px;
+ grad[_FS[1-j].Eltern[0].p2]:=
+ grad[_FS[1-j].Eltern[0].p2] - tmp2*(1-tmp)*py;
+
+ grad[_FS[1-j].Eltern[1].p1]:=
+ grad[_FS[1-j].Eltern[1].p1] - tmp2*tmp*px;
+ grad[_FS[1-j].Eltern[1].p2]:=
+ grad[_FS[1-j].Eltern[1].p2] - tmp2*tmp*py;
+ {$ENDIF}
+ end;
+ end;
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then begin
+ ffTimer.stop;
+ mmTimer.start;
+ end;
+ {$ENDIF}
+
+ for I:=0 to length(MMInteraktionen)-1 do
+ with MMInteraktionen[I] do begin // 1/x^2 - Abstoßung
+ {$IFDEF Energie}
+ result:=result +
+ Laenge/(1e-9 + QAbstand(P,_Ps[0],_Ps[1]));
+ {$ENDIF}
+ {$IFDEF Gradient}
+ tmp:=1/(1e-9 + QAbstand(P,_Ps[0],_Ps[1]));
+ tmp:=-Laenge*2*sqr(tmp);
+ grad[_Ps[0].p1]:=
+ grad[_Ps[0].p1] + tmp * (P[_Ps[0].p1]-P[_Ps[1].p1]);
+ grad[_Ps[0].p2]:=
+ grad[_Ps[0].p2] + tmp * (P[_Ps[0].p2]-P[_Ps[1].p2]);
+ grad[_Ps[1].p1]:=
+ grad[_Ps[1].p1] + tmp * (P[_Ps[1].p1]-P[_Ps[0].p1]);
+ grad[_Ps[1].p2]:=
+ grad[_Ps[1].p2] + tmp * (P[_Ps[1].p2]-P[_Ps[0].p2]);
+ {$ENDIF}
+ end;
+
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then begin
+ mmTimer.stop;
+ mfTimer.start;
+ end;
+ {$ENDIF}
+
+ for I:=0 to length(MFInteraktionen)-1 do
+ with MFInteraktionen[I] do begin
+ tmp:= Skalarprodukt(P,_P,_F.Eltern[0],_F.Eltern[1],_F.Eltern[0]) / // (P-F1)*(F2-F1) / (F2-F1)^2
+ (epsilon+QAbstand(P,_F.Eltern[1],_F.Eltern[0]));
+ if (tmp<=0) or (tmp>=1) then begin // Person liegt "vor"/"hinter" Familie -> Abstand zu Elter relevant
+ tmp2:=epsilon + QAbstand(P,_P,_F.Eltern[byte(tmp>0.5)]);
+ {$IFDEF Gradient}
+ tmp3:=-2*Laenge/sqr(tmp2);
+ grad[_P.p1]:=
+ grad[_P.p1] + tmp3*(P[_P.p1]-P[_F.Eltern[byte(tmp>0.5)].p1]);
+ grad[_P.p2]:=
+ grad[_P.p2] + tmp3*(P[_P.p2]-P[_F.Eltern[byte(tmp>0.5)].p2]);
+ grad[_F.Eltern[byte(tmp>0.5)].p1]:=
+ grad[_F.Eltern[byte(tmp>0.5)].p1] + tmp3*(P[_F.Eltern[byte(tmp>0.5)].p1]-P[_P.p1]);
+ grad[_F.Eltern[byte(tmp>0.5)].p2]:=
+ grad[_F.Eltern[byte(tmp>0.5)].p2] + tmp3*(P[_F.Eltern[byte(tmp>0.5)].p2]-P[_P.p2]);
+ {$ENDIF}
+ end
+ else begin // Person liegt "neben" Familie -> senkrechter Abstand relevant
+ tmp2:=1e-9 + QAbstand(P,_P,_F.Eltern[0]) - // Pythagoras
+ sqr(tmp)*QAbstand(P,_F.Eltern[1],_F.Eltern[0]);
+ {$IFDEF Gradient}
+ px:=-P[_F.Eltern[1].p2]+P[_F.Eltern[0].p2];
+ py:= P[_F.Eltern[1].p1]-P[_F.Eltern[0].p1];
+ tmp3:=1/sqrt(sqr(px)+sqr(py)+epsilon);
+ if (px*(P[_P.p1]-P[_F.Eltern[0].p1])+py*(P[_P.p2]-P[_F.Eltern[0].p2]) <= 0) then
+ tmp3:=-tmp3;
+ px:=px*tmp3;
+ py:=py*tmp3;
+
+ tmp2:=-2*Laenge/sqr(tmp2)*sqrt(tmp2);
+
+ grad[_P.p1]:= // Ableitungen nach Position der Person
+ grad[_P.p1] + tmp2*px;
+ grad[_P.p2]:=
+ grad[_P.p2] + tmp2*py;
+
+ grad[_F.Eltern[0].p1]:= // Ableitungen nach Position der Eltern
+ grad[_F.Eltern[0].p1] - tmp2*(1-tmp)*px;
+ grad[_F.Eltern[0].p2]:=
+ grad[_F.Eltern[0].p2] - tmp2*(1-tmp)*py;
+
+ grad[_F.Eltern[1].p1]:=
+ grad[_F.Eltern[1].p1] - tmp2*tmp*px;
+ grad[_F.Eltern[1].p2]:=
+ grad[_F.Eltern[1].p2] - tmp2*tmp*py;
+ {$ENDIF}
+ end;
+
+ {$IFDEF Energie}
+ result:=result + Laenge/tmp2;
+ {$ENDIF}
+ end;
+
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then begin
+ mfTimer.stop;
+ famTimer.start;
+ end;
+ {$ENDIF}
+
+ {$IFDEF Energie}
+ for i:=0 to length(Familien)-1 do
+ result:=result +
+ Laengengewicht *
+ sqr(sqr(QAbstand(P,Familien[i].Eltern[0],Familien[i].Eltern[1])));
+ {$ENDIF}
+ {$IFDEF Gradient}
+ for i:=0 to length(Familien)-1 do begin
+ tmp:=QAbstand(P,Familien[i].Eltern[0],Familien[i].Eltern[1]);
+ tmp:=8*Laengengewicht*sqr(tmp)*tmp; // 8 (a-b)^6
+ grad[Familien[i].Eltern[0].p1]:=
+ grad[Familien[i].Eltern[0].p1] + tmp*(P[Familien[i].Eltern[0].p1]-P[Familien[i].Eltern[1].p1]);
+ grad[Familien[i].Eltern[0].p2]:=
+ grad[Familien[i].Eltern[0].p2] + tmp*(P[Familien[i].Eltern[0].p2]-P[Familien[i].Eltern[1].p2]);
+ grad[Familien[i].Eltern[1].p1]:=
+ grad[Familien[i].Eltern[1].p1] + tmp*(P[Familien[i].Eltern[1].p1]-P[Familien[i].Eltern[0].p1]);
+ grad[Familien[i].Eltern[1].p2]:=
+ grad[Familien[i].Eltern[1].p2] + tmp*(P[Familien[i].Eltern[1].p2]-P[Familien[i].Eltern[0].p2]);
+ end;
+ {$ENDIF}
+
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then famTimer.stop;
+ {$ENDIF}
+
+end;
diff --git a/grampsmath.pas b/grampsmath.pas
new file mode 100644
index 0000000..6739273
--- /dev/null
+++ b/grampsmath.pas
@@ -0,0 +1,79 @@
+unit grampsmath;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, grampstypen, math;
+
+function KreuzproduktZ(P: tExtendedArray; A1,A2,B1,B2: tPerson): extended; inline;
+function QAbstand(P: tExtendedArray; A1,A2: tPerson): extended; inline;
+function Skalarprodukt(P: tExtendedArray; A1,A2,B1,B2: tPerson): extended; inline;
+function rootDet(mat: array of tExtendedarray): extended;
+
+implementation
+
+function KreuzproduktZ(P: tExtendedArray; A1,A2,B1,B2: tPerson): extended;
+begin
+ result:= // ( (A1-A2) x (B1-B2) ).z =
+ (P[A1.p1]-P[A2.p1])*(P[B1.p2]-P[B2.p2]) // (A1.x - A2.x) * (B1.y - B2.y)
+ - (P[B1.p1]-P[B2.p1])*(P[A1.p2]-P[A2.p2]); // - (B1.x - B2.x) * (A1.y - A2.y)
+(* writeln((P[A1.p1]-P[A2.p1])*(P[B1.p2]-P[B2.p2]) - (P[B1.p1]-P[B2.p1])*(P[A1.p2]-P[A2.p2]));
+ writeln('(',P[A1.p1],' - ',P[A2.p1],') * (',P[B1.p2],' - ',P[B2.p2],') - (',P[B1.p1],' - ',P[B2.p1],') * (',P[A1.p2],' - ',P[A2.p2],')');
+ writeln('(',A1.p1,' - ',A2.p1,') * (',B1.p2,' - ',B2.p2,') - (',B1.p1,' - ',B2.p1,') * (',A1.p2,' - ',A2.p2,')'); *)
+end;
+
+function QAbstand(P: tExtendedArray; A1,A2: tPerson): extended;
+begin
+ result:=
+ sqr(P[A1.p1]-P[A2.p1]) +
+ sqr(P[A1.p2]-P[A2.p2]);
+end;
+
+function Skalarprodukt(P: tExtendedArray; A1,A2,B1,B2: tPerson): extended;
+begin
+ result:=
+ (P[A1.p1]-P[A2.p1])*(P[B1.p1]-P[B2.p1]) +
+ (P[A1.p2]-P[A2.p2])*(P[B1.p2]-P[B2.p2]);
+end;
+
+function rootDet(mat: array of tExtendedarray): extended;
+var
+ dim,i,j,k: longint;
+ fak,tmp: extended;
+begin
+ dim:=length(mat);
+ result:=1;
+
+ for i:=0 to dim-1 do begin // die zu eliminierende Spalte
+ k:=-1;
+ tmp:=0;
+ for j:=i to dim-1 do
+ if abs(mat[j,i])>tmp then begin
+ k:=j;
+ tmp:=abs(mat[j,i]);
+ end;
+
+ if tmp<1e-40 then begin // nur noch 0en in Spalte i
+ result:=0;
+ break;
+ end;
+
+ if k<>i then // Zeile k und i tauschen
+ for j:=i to dim-1 do begin
+ tmp:=mat[i,j];
+ mat[i,j]:=mat[k,j];
+ mat[k,j]:=tmp;
+ end;
+ result:=result*power(abs(mat[i,i]),1/dim);
+ for j:=i+1 to dim-1 do begin
+ fak:=-mat[j,i]/mat[i,i];
+ for k:=i to dim-1 do
+ mat[j,k]:=mat[j,k]+fak*mat[i,k];
+ end;
+ end;
+end;
+
+end.
+
diff --git a/grampstypen.pas b/grampstypen.pas
new file mode 100644
index 0000000..4505324
--- /dev/null
+++ b/grampstypen.pas
@@ -0,0 +1,2050 @@
+unit grampstypen;
+
+interface
+
+uses classes, matheunit;
+
+type
+ tExtendedArray = array of extended;
+ tIntArray = array of longint;
+ tIntArrayArray = array of tIntArray;
+ tBooleanArray = array of boolean;
+ tPointArray = array of tPoint;
+ tPointArrayArray = array of tPointArray;
+ tEreignisart = (eaDummy,eaGeburt,eaTod,eaHochzeit,eaTaufe,eaBeerdigung,eaSonstiges);
+ t4DPoint = record
+ x,y,z,u: longint;
+ end;
+ tExtPoint = record
+ x,y: extended;
+ end;
+ tSchrittErgebnis = record
+ besserAlsVorher,
+ faktorNeutralisiert: boolean;
+ Platzveraenderung: longint;
+ end;
+ t4DPointArray = array of t4DPoint;
+ tParameterAttribut = object
+ istKoordinate,istUnabhaengig,wirdBenutzt: boolean;
+ procedure setzeKoordinate(ik: boolean);
+ procedure setzeUnabhaengig(iu: boolean);
+ procedure setzeBenutzt(wb: boolean);
+ procedure fromChar(c: char);
+ function toChar: char;
+ end;
+ tParameterAttributArray = array of tParameterAttribut;
+ tGenerikum = class
+ ID: string;
+ index: longint;
+ constructor create;
+ destructor destroy; override;
+ procedure init(g: tGenerikum); dynamic;
+ function istGleich(g: tGenerikum): boolean; dynamic;
+ end;
+ tGenerikumArray = array of tGenerikum;
+ tEreignis = class;
+ tEreignisArray = array of tEreignis;
+ tPerson = class;
+ tPersonArray = array of tPerson;
+ tFamilie = class;
+ tFamilieArray = array of tFamilie;
+ tVerknuepfung = class;
+ tVerknuepfungArray = array of tVerknuepfung;
+ tMMInteraktion = class;
+ tMMInteraktionArray = array of tMMInteraktion;
+ tMFInteraktion = class;
+ tMFInteraktionArray = array of tMFInteraktion;
+ tFFInteraktion = class;
+ tFFInteraktionArray = array of tFFInteraktion;
+
+ tEreignis = class (tGenerikum)
+ Jahr: longint;
+ Art: tEreignisart;
+ function istDummy: boolean;
+ constructor create;
+ destructor destroy; override;
+ procedure init(e: tGenerikum); override;
+ function istGleich(e: tGenerikum): boolean; override;
+ end;
+ tPerson = class (tGenerikum)
+ Anfang,Ende: tEreignis;
+ Ereignisse: array[tEreignisart] of tEreignis;
+ KindIn: tFamilie;
+ ElterIn: tFamilieArray;
+ inputIn,outputIn: tVerknuepfungArray;
+ inMMInteraktion: tMMInteraktionArray;
+ inMFInteraktion: tMFInteraktionArray;
+ Vorname,Nachname: string;
+ p1,p2,p3: longint;
+ constructor create;
+ destructor destroy; override;
+ procedure entferneElterIn(wo: tFamilie);
+ procedure entferneKindIn(wo: tFamilie);
+ procedure fuegeInputInHinzu(wo: tVerknuepfung);
+ procedure entferneInputIn(wo: tVerknuepfung);
+ procedure fuegeOutputInHinzu(wo: tVerknuepfung);
+ procedure entferneOutputIn(wo: tVerknuepfung);
+ procedure fuegeInMMInteraktionHinzu(wo: tMMInteraktion);
+ procedure entferneInMMInteraktion(wo: tMMInteraktion);
+ procedure fuegeInMFInteraktionHinzu(wo: tMFInteraktion);
+ procedure entferneInMFInteraktion(wo: tMFInteraktion);
+ procedure init(p: tGenerikum); override; overload;
+ procedure init(p: tGenerikum; var es: tEreignisArray); overload;
+ procedure init(p: tGenerikum; var es: tEreignisArray; var fs: tFamilieArray); overload;
+ procedure init(p: tGenerikum; var es: tEreignisArray; var fs: tFamilieArray; darfErzeugen: boolean); overload;
+ function anzahlVerbindungen: longint;
+ function istGleich(p: tGenerikum): boolean; override;
+ function elterVonFamilie(eNum: longint): tFamilie;
+ function istElterIn(f: tFamilie): boolean;
+ end;
+ tFamilie = class (tGenerikum)
+ Anfang: tEreignis;
+ verheiratet: boolean;
+ Eltern: array[0..1] of tPerson;
+ Kinder: tPersonArray;
+ inMFInteraktion: tMFInteraktionArray;
+ inFFInteraktion: tFFInteraktionArray;
+ constructor create;
+ destructor destroy; override;
+ procedure entferneElter(wen: tPerson);
+ procedure entferneKind(wen: tPerson);
+ procedure fuegeInMFInteraktionHinzu(wo: tMFInteraktion);
+ procedure entferneInMFInteraktion(wo: tMFInteraktion);
+ procedure fuegeInFFInteraktionHinzu(wo: tFFInteraktion);
+ procedure entferneInFFInteraktion(wo: tFFInteraktion);
+ procedure init(f: tGenerikum); override; overload;
+ procedure init(f: tGenerikum; var Es: tEreignisArray; var Ps: tPersonArray); overload;
+ procedure init(f: tGenerikum; var Es: tEreignisArray; var Ps: tPersonArray; darfErzeugen: boolean); overload;
+ function anzahlVerbindungen: longint; inline;
+ function istGleich(f: tGenerikum): boolean; override;
+ function hatKind(p: tPerson): boolean; inline;
+ function hatElter(p: tPerson): boolean; inline;
+ end;
+ tVerknuepfung = class
+ private
+ _outP: tPerson;
+ procedure wOutP(p: tPerson);
+ public
+ index: longint;
+ Input: array[0..1,'x'..'y'] of Longint;
+ Lambda: Longint;
+ Output: array['x'..'y'] of Longint;
+ property outP: tPerson
+ read _outP
+ write wOutP;
+ destructor destroy; override;
+ function istGleich(v: tVerknuepfung; p2p: tIntArray): boolean;
+ end;
+ tMMInteraktion = class
+ private
+ __Ps: array[0..1] of tPerson;
+ function r_Ps(i: longint): tPerson; inline;
+ procedure w_Ps(i: longint; p: tPerson);
+ public
+ index: longint;
+ Laenge: extended;
+ property _Ps[i: integer]: tPerson
+ read r_Ps
+ write w_Ps;
+ destructor destroy; override;
+ function istGleich(ia: tMMInteraktion): boolean;
+ end;
+ tMFInteraktion = class
+ private
+ __P: tPerson;
+ __F: tFamilie;
+ procedure w_P(p: tPerson);
+ procedure w_F(f: tFamilie);
+ public
+ index: longint;
+ Laenge: extended;
+ property _P: tPerson
+ read __P
+ write w_P;
+ property _F: tFamilie
+ read __F
+ write w_F;
+ destructor destroy; override;
+ function istGleich(ia: tMFInteraktion): boolean;
+ end;
+ tFFInteraktion = class
+ private
+ __Fs: array[0..1] of tFamilie;
+ function r_Fs(i: longint): tFamilie; inline;
+ procedure w_Fs(i: longint; f: tFamilie);
+ public
+ index: longint;
+ property _Fs[i: integer]: tFamilie
+ read r_Fs
+ write w_Fs;
+ destructor destroy; override;
+ function istGleich(ia: tFFInteraktion): boolean;
+ end;
+
+ tZusammenhangskomponente = class
+ public
+ Familien: tFamilieArray;
+ constructor create;
+ destructor destroy; override;
+ function grenztAn(p: tPerson): boolean;
+ procedure verschmelzeMit(zhk: tZusammenhangskomponente);
+ procedure UmfeldEinfuegen(Fs: tFamilieArray; p: tPerson);
+ end;
+
+ tGraph = class
+ private
+ function entferneBlaetter(var f: tIntArray): tIntArray;
+ function Pfadigkeit(Ks: tIntArray; a,b: longint): longint; // 0 -> zu wenig; 1 -> ein Pfad; 2-> zu viel
+ function etwasDoppelt: boolean; overload;
+ function etwasDoppelt(Ks: tIntArray): boolean; overload;
+ function etwasRedundant(Ks1,Ks2: tIntArray): boolean;
+ procedure dumpKantenArray(Ks: tIntArray);
+ public
+ Ecken,Kanten: tPointArray;
+ constructor create;
+ destructor destroy; override;
+ function findeKreise: tIntArrayArray;
+ function findeKreise(f: tIntArray): tIntArrayArray;
+ end;
+
+ tSortObject = class
+ oG: tGenerikum;
+ oMM: tMMInteraktion;
+ oMF: tMFInteraktion;
+ oFF: tFFInteraktion;
+ oV: tVerknuepfung;
+ ID: string;
+ constructor create;
+ procedure assign(g: tGenerikum); overload;
+ procedure assign(i: tMMInteraktion); overload;
+ procedure assign(i: tMFInteraktion); overload;
+ procedure assign(i: tFFInteraktion); overload;
+ procedure assign(v: tVerknuepfung); overload;
+ end;
+ tSortObjectArray = array of tSortObject;
+
+function paramsGleich(p1,p2: longint; p2p: tIntArray): boolean; inline;
+function pEreignisToStr(E: tEreignis): string; inline;
+function pFamilieToStr(F: tFamilie): string; inline;
+function pPersonToStr(P: tPerson): string; inline;
+function tEreignisToStr(E: tEreignis): string; inline;
+function tPersonToStr(P: tPerson): string; inline;
+function tFamilieToStr(F: tFamilie): string; inline;
+function tVerknuepfungToStr(V: tVerknuepfung): string; inline;
+function tMMInteraktionToStr(I: tMMInteraktion): string; inline;
+function tMFInteraktionToStr(I: tMFInteraktion): string; inline;
+function tFFInteraktionToStr(I: tFFInteraktion): string; inline;
+function findeEreignis(var Es: tEreignisArray; eID: string): tEreignis;
+function findeFamilie(var Fs: tFamilieArray; fID: string): tFamilie; overload;
+function findeFamilie(var Fs: tFamilieArray; fID: string; darfErzeugen: boolean): tFamilie; overload;
+function findePerson(var Ps: tPersonArray; pID: string): tPerson; overload;
+function findePerson(var Ps: tPersonArray; pID: string; darfErzeugen: boolean): tPerson; overload;
+function findeMMInteraktion(var MMs: tMMInteraktionArray; var Ps: tPersonArray; ia: string): tMMInteraktion;
+function findeMFInteraktion(var MFs: tMFInteraktionArray; var Ps: tPersonArray; var Fs: tFamilieArray; ia: string): tMFInteraktion;
+function findeFFInteraktion(var FFs: tFFInteraktionArray; var Fs: tFamilieArray; ia: string): tFFInteraktion;
+procedure loescheEreignis(var Es: tEreignisArray; eID: string);
+procedure loescheFamilie(var Fs: tFamilieArray; fID: string);
+procedure loeschePerson(var Ps: tPersonArray; pID: string);
+procedure mergePerson(var Ps: tPersonArray; var P: tPerson);
+procedure mergeFamilie(var Fs: tFamilieArray; var F: tFamilie);
+function importEreignis(s: string; var Es: tEreignisArray): tEreignis;
+function importPerson(s: string; var Ps: tPersonArray; var Es: tEreignisArray; var Fs: tFamilieArray): tPerson;
+function importFamilie(s: string; var Ps: tPersonArray; var Es: tEreignisArray; var Fs: tFamilieArray): tFamilie;
+function strToTVerknuepfung(var Ps: tPersonArray; s: string): tVerknuepfung;
+function importMMInteraktion(var Ps: tPersonArray; s: string): tMMInteraktion;
+function importMFInteraktion(var Ps: tPersonArray; var Fs: tFamilieArray; s: string): tMFInteraktion;
+function importFFInteraktion(var Fs: tFamilieArray; s: string): tFFInteraktion;
+function importFamilieArray(var s: string; var Fs: tFamilieArray): tFamilieArray;
+function importPersonArray(var s: string; var Ps: tPersonArray): tPersonArray;
+procedure strToTIntArray(var s: string; var A: tIntArray);
+function Permutation(n: longint): tIntArray;
+function sortStringFromObject(g: tGenerikum): string; overload;
+function sortStringFromObject(i: tMMInteraktion): string; overload;
+function sortStringFromObject(i: tMFInteraktion): string; overload;
+function sortStringFromObject(i: tFFInteraktion): string; overload;
+function sortStringFromObject(v: tVerknuepfung): string; overload;
+function sortiere(arr: tGenerikumArray): tGenerikumArray; overload; inline;
+function sortiere(arr: tMMInteraktionArray): tMMInteraktionArray; overload; inline;
+function sortiere(arr: tMFInteraktionArray): tMFInteraktionArray; overload; inline;
+function sortiere(arr: tFFInteraktionArray): tFFInteraktionArray; overload; inline;
+function sortiere(arr: tVerknuepfungArray): tVerknuepfungArray; overload; inline;
+function sortiere(arr: tSortObjectArray): tSortObjectArray; overload; inline;
+procedure sortiere(var arr: tSortObjectArray; von,bis: longint; mi,ma: string); overload;
+
+implementation
+
+uses sysutils;
+
+function paramsGleich(p1,p2: longint; p2p: tIntArray): boolean;
+begin
+ if p2=-1 then result:=p1=-1
+ else result:=p2p[p2]=p1;
+end;
+
+function pEreignisToStr(E: tEreignis): string;
+begin
+ if assigned(E) then
+ result:=E.ID
+ else
+ result:='NIL';
+end;
+
+function pFamilieToStr(F: tFamilie): string;
+begin
+ if assigned(F) then
+ result:=F.ID
+ else
+ result:='NIL';
+end;
+
+function pPersonToStr(P: tPerson): string;
+begin
+ if assigned(P) then
+ result:=P.ID
+ else
+ result:='NIL';
+end;
+
+function TEreignisToStr(E: TEreignis): String;
+begin
+ TEreignisToStr:=
+ E.ID+' '+
+ inttostr(E.Jahr)+' '+
+ inttostr(Integer(E.Art));
+end;
+
+function TPersonToStr(P: TPerson): String;
+var
+ ea: TEreignisart;
+ I: Longint;
+begin
+ result:=
+ P.ID+' '+
+ pEreignisToStr(P.Anfang)+' '+
+ pEreignisToStr(P.Ende)+' ';
+ for ea:=low(TEreignisart) to high(TEreignisart) do
+ result:=result+PEreignisToStr(P.Ereignisse[ea])+' ';
+ result:=result+
+ pFamilieToStr(P.KindIn)+' '+
+ inttostr(length(P.ElterIn))+' ';
+ for I:=0 to length(P.ElterIn)-1 do
+ result:=result+
+ pFamilieToStr(P.ElterIn[I])+' ';
+ result:=result+
+ ''''+P.Vorname+''' '+
+ ''''+P.Nachname+''' '+
+ inttostr(P.P1)+' '+
+ inttostr(P.P2)+' '+
+ inttostr(P.P3);
+end;
+
+function TFamilieToStr(F: TFamilie): String;
+var
+ I: Longint;
+begin
+ result:=
+ F.ID+' '+
+ PEreignisToStr(F.Anfang)+' '+
+ inttostr(byte(F.Verheiratet))+' '+
+ pPersonToStr(F.Eltern[0])+' '+
+ pPersonToStr(F.Eltern[1])+' '+
+ inttostr(length(F.Kinder));
+ for I:=0 to length(F.Kinder)-1 do
+ result:=result+' '+
+ pPersonToStr(F.Kinder[I]);
+end;
+
+function TVerknuepfungToStr(V: TVerknuepfung): String;
+begin
+ result:=
+ pPersonToStr(V.outP)+' '+
+ inttostr(V.Input[0,'x'])+' '+
+ inttostr(V.Input[0,'y'])+' '+
+ inttostr(V.Input[1,'x'])+' '+
+ inttostr(V.Input[1,'y'])+' '+
+ inttostr(V.Lambda)+' '+
+ inttostr(V.Output['x'])+' '+
+ inttostr(V.Output['y']);
+end;
+
+function TMMInteraktionToStr(I: TMMInteraktion): String;
+begin
+ result:=
+ pPersonToStr(I._Ps[0])+' '+
+ pPersonToStr(I._Ps[1])+' '+
+ myfloattostr(I.Laenge);
+end;
+
+function TMFInteraktionToStr(I: TMFInteraktion): String;
+begin
+ TMFInteraktionToStr:=
+ pPersonToStr(I._P)+' '+
+ pFamilieToStr(I._F)+' '+
+ myfloattostr(I.Laenge);
+end;
+
+function TFFInteraktionToStr(I: TFFInteraktion): String;
+begin
+ TFFInteraktionToStr:=
+ pFamilieToStr(I._Fs[0])+' '+
+ pFamilieToStr(I._Fs[1]);
+end;
+
+function findeEreignis(var Es: tEreignisArray; eID: String): tEreignis;
+var i: longint;
+begin
+ if eID='NIL' then begin
+ result:=nil;
+ exit;
+ end;
+ for i:=0 to length(Es)-1 do
+ if Es[i].ID=eID then begin
+ result:=Es[i];
+ exit;
+ end;
+ result:=tEreignis.create;
+ result.ID:=eID;
+ setlength(Es,length(Es)+1);
+ Es[length(Es)-1]:=result;
+ Es[length(Es)-1].index:=length(Es)-1;
+end;
+
+function findeFamilie(var Fs: tFamilieArray; fID: String): tFamilie;
+begin
+ result:=findeFamilie(Fs,fID,true);
+end;
+
+function findeFamilie(var Fs: tFamilieArray; fID: String; darfErzeugen: boolean): tFamilie;
+var i: longint;
+begin
+ if fID='NIL' then begin
+ result:=nil;
+ exit;
+ end;
+ for i:=0 to length(Fs)-1 do
+ if Fs[i].ID=fID then begin
+ result:=Fs[i];
+ exit;
+ end;
+ if darfErzeugen then begin
+ result:=tFamilie.create;
+ result.ID:=fID;
+ setlength(Fs,length(Fs)+1);
+ Fs[length(Fs)-1]:=result;
+ Fs[length(Fs)-1].index:=length(Fs)-1;
+ end
+ else
+ result:=nil;
+end;
+
+function findePerson(var Ps: tPersonArray; pID: String): tPerson;
+begin
+ result:=findePerson(Ps,pID,true);
+end;
+
+function findePerson(var Ps: tPersonArray; pID: String; darfErzeugen: boolean): tPerson;
+var i: longint;
+begin
+ if pID='NIL' then begin
+ result:=nil;
+ exit;
+ end;
+ for i:=0 to length(Ps)-1 do
+ if Ps[i].ID=pID then begin
+ result:=Ps[i];
+ exit;
+ end;
+ if darfErzeugen then begin
+ result:=tPerson.create;
+ result.ID:=pID;
+ setlength(Ps,length(Ps)+1);
+ Ps[length(Ps)-1]:=result;
+ Ps[length(Ps)-1].index:=length(Ps)-1;
+ end
+ else
+ result:=nil;
+end;
+
+function findeMMInteraktion(var MMs: tMMInteraktionArray; var Ps: tPersonArray; ia: string): tMMInteraktion;
+var
+ i: longint;
+begin
+ for i:=0 to length(MMs)-1 do
+ if tMMInteraktionToStr(MMs[i])=ia then begin
+ result:=MMs[i];
+ exit;
+ end;
+ setlength(MMs,length(MMs)+1);
+ MMs[length(MMs)-1]:=importMMInteraktion(Ps,ia);
+ MMs[length(MMs)-1].index:=length(MMs)-1;
+end;
+
+function findeMFInteraktion(var MFs: tMFInteraktionArray; var Ps: tPersonArray; var Fs: tFamilieArray; ia: string): tMFInteraktion;
+var
+ i: longint;
+begin
+ for i:=0 to length(MFs)-1 do
+ if tMFInteraktionToStr(MFs[i])=ia then begin
+ result:=MFs[i];
+ exit;
+ end;
+ setlength(MFs,length(MFs)+1);
+ MFs[length(MFs)-1]:=importMFInteraktion(Ps,Fs,ia);
+ MFs[length(MFs)-1].index:=length(MFs)-1;
+end;
+
+function findeFFInteraktion(var FFs: tFFInteraktionArray; var Fs: tFamilieArray; ia: string): tFFInteraktion;
+var
+ i: longint;
+begin
+ for i:=0 to length(FFs)-1 do
+ if tFFInteraktionToStr(FFs[i])=ia then begin
+ result:=FFs[i];
+ exit;
+ end;
+ setlength(FFs,length(FFs)+1);
+ FFs[length(FFs)-1]:=importFFInteraktion(Fs,ia);
+ FFs[length(FFs)-1].index:=length(FFs)-1;
+end;
+
+procedure loescheEreignis(var Es: tEreignisArray; eID: string);
+var i,j: longint;
+begin
+ if eID='NIL' then
+ exit;
+ for i:=0 to length(Es)-1 do
+ if Es[i].ID=eID then begin
+ Es[i].free;
+ for j:=i+1 to length(Es)-1 do begin
+ Es[j-1]:=Es[j];
+ Es[j-1].index:=j-1;
+ end;
+ setlength(Es,length(Es)-1);
+ exit;
+ end;
+end;
+
+procedure loescheFamilie(var Fs: tFamilieArray; fID: string);
+var i,j: longint;
+begin
+ if fID='NIL' then
+ exit;
+ for i:=0 to length(Fs)-1 do
+ if Fs[i].ID=fID then begin
+ Fs[i].free;
+ for j:=i+1 to length(Fs)-1 do begin
+ Fs[j-1]:=Fs[j];
+ Fs[j-1].index:=j-1;
+ end;
+ setlength(Fs,length(Fs)-1);
+ exit;
+ end;
+end;
+
+procedure loeschePerson(var Ps: tPersonArray; pID: string);
+var i,j: longint;
+begin
+ if pID='NIL' then
+ exit;
+ for i:=0 to length(Ps)-1 do
+ if Ps[i].ID=pID then begin
+ Ps[i].free;
+ for j:=i+1 to length(Ps)-1 do begin
+ Ps[j-1]:=Ps[j];
+ Ps[j-1].index:=j-1;
+ end;
+ setlength(Ps,length(Ps)-1);
+ exit;
+ end;
+end;
+
+procedure mergePerson(var Ps: tPersonArray; var P: tPerson);
+var i: longint;
+begin
+ for i:=0 to length(Ps)-1 do
+ if Ps[i].ID=P.ID then begin
+ P.free;
+ P:=Ps[i];
+ exit;
+ end;
+ setlength(Ps,length(Ps)+1);
+ Ps[length(Ps)-1]:=P;
+ Ps[length(Ps)-1].index:=length(Ps)-1;
+end;
+
+procedure mergeFamilie(var Fs: tFamilieArray; var F: tFamilie);
+var i: longint;
+begin
+ for i:=0 to length(Fs)-1 do
+ if Fs[i].ID=F.ID then begin
+ F.free;
+ F:=Fs[i];
+ exit;
+ end;
+ setlength(Fs,length(Fs)+1);
+ Fs[length(Fs)-1]:=F;
+ Fs[length(Fs)-1].index:=length(Fs)-1;
+end;
+
+function ImportEreignis(S: string; var Es: tEreignisArray): tEreignis;
+var i: Longint;
+ found: boolean;
+begin
+ result:=tEreignis.create;
+ result.ID:=leftStr(S,pos(' ',S)-1);
+ found:=false;
+ for i:=0 to length(Es)-1 do
+ if result.ID = Es[i].ID then begin
+ result.free;
+ result:=Es[i];
+ found:=true;
+ break;
+ end;
+ if not found then begin
+ setlength(Es,length(Es)+1);
+ Es[length(Es)-1]:=result;
+ Es[length(Es)-1].index:=length(Es)-1;
+ end;
+ delete(S,1,pos(' ',S));
+ result.Jahr:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.Art:=TEreignisart(strtoint(S));
+end;
+
+function ImportPerson(S: string; var Ps: tPersonArray; var Es: tEreignisArray; var Fs: tFamilieArray): tPerson;
+var i: longint;
+ found: boolean;
+ ea: TEreignisart;
+begin
+ result:=tPerson.create;
+ result.ID:=leftStr(S,pos(' ',S)-1);
+ found:=false;
+ for i:=0 to length(Ps)-1 do
+ if Ps[i].ID = result.ID then begin
+ result.free;
+ result:=Ps[i];
+ found:=true;
+ break;
+ end;
+ if not found then begin
+ setlength(Ps,length(Ps)+1);
+ Ps[length(Ps)-1]:=result;
+ Ps[length(Ps)-1].index:=length(Ps)-1;
+ end;
+ delete(S,1,pos(' ',S));
+ result.Anfang:=findeEreignis(Es,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.Ende:=findeEreignis(Es,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ for ea:=low(TEreignisart) to high(TEreignisart) do begin
+ result.Ereignisse[ea]:=findeEreignis(Es,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+ result.KindIn:=findeFamilie(Fs,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.ElterIn:=ImportFamilieArray(S,Fs);
+ delete(S,1,1);
+ result.Vorname:=leftStr(S,pos('''',S)-1);
+ delete(S,1,pos('''',S)+2);
+ result.Nachname:=leftStr(S,pos('''',S)-1);
+ delete(S,1,pos('''',S)+1);
+ result.P1:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.P2:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.P3:=strtoint(S);
+end;
+
+function ImportFamilie(s: string; var Ps: tPersonArray; var Es: tEreignisArray; var Fs: tFamilieArray): tFamilie;
+var i: longint;
+ found: boolean;
+begin
+ result:=tFamilie.create;
+ result.ID:=leftStr(S,pos(' ',S)-1);
+ found:=false;
+ for i:=0 to length(Fs)-1 do
+ if Fs[i].ID = result.ID then begin
+ result.free;
+ result:=Fs[i];
+ found:=true;
+ break;
+ end;
+ if not found then begin
+ setlength(Fs,length(Fs)+1);
+ Fs[length(Fs)-1]:=result;
+ Fs[length(Fs)-1].index:=length(Fs)-1;
+ end;
+ delete(S,1,pos(' ',S));
+ result.Anfang:=findeEreignis(Es,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.Verheiratet:=leftStr(S,pos(' ',S)-1)='1';
+ delete(S,1,pos(' ',S));
+ result.Eltern[0]:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.Eltern[1]:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ S:=S+' ';
+ result.Kinder:=importPersonArray(S,Ps);
+end;
+
+function strToTVerknuepfung(var Ps: tPersonArray; S: String): tVerknuepfung;
+var i: Longint;
+ c: Char;
+begin
+ S:=S+' ';
+ result:=tVerknuepfung.create;
+ result.outP:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ for i:=0 to 1 do
+ for c:='x' to 'y' do begin
+ result.Input[i,c]:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+ result.Lambda:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ for C:='x' to 'y' do begin
+ result.Output[C]:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+end;
+
+function importMMInteraktion(var Ps: tPersonArray; S: String): tMMInteraktion;
+var i: Longint;
+begin
+ result:=tMMInteraktion.create;
+ for i:=0 to 1 do begin
+ result._Ps[i]:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+ result.Laenge:=mystrtofloat(S);
+end;
+
+function importMFInteraktion(var Ps: tPersonArray; var Fs: tFamilieArray; S: String): tMFInteraktion;
+begin
+ result:=tMFInteraktion.create;
+ result._P:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result._F:=findeFamilie(Fs,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ result.Laenge:=mystrtofloat(S);
+end;
+
+function importFFInteraktion(var Fs: tFamilieArray; S: String): tFFInteraktion;
+var i: longint;
+begin
+ result:=tFFInteraktion.create;
+ S:=S+' ';
+ for i:=0 to 1 do begin
+ result._Fs[i]:=findeFamilie(Fs,leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+end;
+
+function ImportFamilieArray(var S: String; var Fs: tFamilieArray): tFamilieArray;
+var I: Longint;
+begin
+ setlength(result,strtoint(leftStr(S,pos(' ',S)-1)));
+ delete(S,1,pos(' ',S));
+ for I:=0 to length(result)-1 do begin
+ result[I]:=findeFamilie(Fs,leftStr(S,pos(' ',S)-1));
+ result[I].index:=I;
+ delete(S,1,pos(' ',S));
+ end;
+end;
+
+function ImportPersonArray(var S: String; var Ps: tPersonArray): tPersonArray;
+var I: Longint;
+begin
+ setlength(result,strtoint(leftStr(S,pos(' ',S)-1)));
+ delete(S,1,pos(' ',S));
+ for I:=0 to length(result)-1 do begin
+ result[I]:=findePerson(Ps,leftStr(S,pos(' ',S)-1));
+ result[I].index:=I;
+ delete(S,1,pos(' ',S));
+ end;
+end;
+
+procedure StrToTIntArray(var S: String; var A: TIntArray);
+var I: Longint;
+begin
+ setlength(A,strtoint(leftStr(S,pos(' ',S)-1)));
+ delete(S,1,pos(' ',S));
+ for I:=0 to length(A)-1 do begin
+ A[I]:=strtoint(leftStr(S,pos(' ',S)-1));
+ delete(S,1,pos(' ',S));
+ end;
+end;
+
+function Permutation(n: Longint): TIntArray;
+var
+ I,J: integer;
+begin
+ if n<=0 then setlength(result,0)
+ else begin
+ result:=Permutation(n-1);
+ I:=random(n);
+ setlength(result,n);
+ for J:=n-1 downto I+1 do
+ result[J]:=result[J-1];
+ result[I]:=n-1;
+ end;
+end;
+
+// tParameterAttribut **********************************************************
+
+procedure tParameterAttribut.setzeKoordinate(ik: boolean);
+begin
+ if istKoordinate=ik then begin
+ write('Parameter ist bereits als ');
+ if not ik then write('nicht-');
+ writeln('Koordinate markiert!');
+ halt;
+ end;
+ istKoordinate:=ik;
+end;
+
+procedure tParameterAttribut.setzeUnabhaengig(iu: boolean);
+begin
+ if istUnabhaengig=iu then begin
+ write('Parameter ist bereits als ');
+ if iu then write('un');
+ writeln('abhängig markiert!');
+ halt;
+ end;
+ istUnabhaengig:=iu;
+end;
+
+procedure tParameterAttribut.setzeBenutzt(wb: boolean);
+begin
+ if wirdBenutzt=wb then begin
+ write('Parameter ist bereits als ');
+ if not wb then write('un');
+ writeln('benutzt markiert!');
+ halt;
+ end;
+ wirdBenutzt:=wb;
+end;
+
+procedure tParameterAttribut.fromChar(c: char);
+begin
+ if (c<'0') or (c>'7') then begin
+ writeln(''''+c+''' ist kein gültiger Wert für Parametereigenschaften, sondern nur 0..7.');
+ halt;
+ end;
+ istKoordinate:=odd(ord(c)-ord('0'));
+ istUnabhaengig:=odd((ord(c)-ord('0')) shr 1);
+ wirdBenutzt:=odd((ord(c)-ord('0')) shr 2);
+end;
+
+function tParameterAttribut.toChar: char;
+begin
+ result:=char(ord('0') + byte(istKoordinate) + 2*byte(istUnabhaengig) + 4*byte(wirdBenutzt));
+end;
+
+// tGenerikum ******************************************************************
+
+constructor tGenerikum.create;
+begin
+ inherited create;
+ fillchar(ID,sizeof(ID),#0);
+ index:=-1;
+end;
+
+destructor tGenerikum.destroy;
+begin
+ setlength(ID,0);
+ inherited destroy;
+end;
+
+procedure tGenerikum.init(g: tGenerikum);
+begin
+ ID:=g.ID;
+ index:=g.index;
+end;
+
+function tGenerikum.istGleich(g: tGenerikum): boolean;
+begin
+ result:=ID=g.ID; // Index wird absichtlich nicht mit überprüft, da die Reihenfolge im Array egal sein soll
+end;
+
+// tEreignis *******************************************************************
+
+function tEreignis.istDummy: boolean;
+begin
+ result:=(Art=eaDummy) or (Jahr=0);
+end;
+
+constructor tEreignis.create;
+begin
+ inherited create;
+ jahr:=0;
+ Art:=eaDummy;
+end;
+
+destructor tEreignis.destroy;
+begin
+ inherited destroy;
+end;
+
+procedure tEreignis.init(e: tGenerikum);
+begin
+ inherited init(e);
+ if not (e is tEreignis) then begin
+ writeln('Ereignis kann nicht mit nicht-Ereignis initialisiert werden!');
+ halt;
+ end;
+ jahr:=(e as tEreignis).Jahr;
+ Art:=(e as tEreignis).Art;
+end;
+
+function tEreignis.istGleich(e: tGenerikum): boolean;
+begin
+ result:=inherited istGleich(e);
+ if not (e is tEreignis) then begin
+ writeln('Ereignis kann nicht mit nicht-Ereignis verglichen werden!');
+ halt;
+ end;
+ result:=result and ((e as tEreignis).Jahr=Jahr) and ((e as tEreignis).Art=Art);
+end;
+
+// tPerson *********************************************************************
+
+constructor tPerson.create;
+var ea: tEreignisart;
+begin
+ inherited create;
+ Anfang:=nil;
+ Ende:=nil;
+ for ea:=low(ea) to high(ea) do
+ Ereignisse[ea]:=nil;
+ KindIn:=nil;
+ fillchar(ElterIn,sizeof(ElterIn),#0);
+ fillchar(inputIn,sizeof(inputIn),#0);
+ fillchar(outputIn,sizeof(outputIn),#0);
+ fillchar(Vorname,sizeof(Vorname),#0);
+ fillchar(Nachname,sizeof(Nachname),#0);
+ fillchar(inMMInteraktion,sizeof(inMMInteraktion),#0);
+ fillchar(inMFInteraktion,sizeof(inMFInteraktion),#0);
+ P1:=-1;
+ P2:=-1;
+ P3:=-1;
+end;
+
+destructor tPerson.destroy;
+var
+ i: longint;
+begin
+ if assigned(KindIn) then
+ KindIn.entferneKind(self);
+ for i:=0 to length(ElterIn)-1 do
+ if assigned(ElterIn[i]) then
+ ElterIn[i].entferneElter(self);
+ setlength(ElterIn,0);
+ setlength(Vorname,0);
+ setlength(Nachname,0);
+ if length(inMMInteraktion)<>0 then
+ raise Exception.create('Diese Person ist noch in einer MMInteraktion verzeichnet!');
+ setlength(inMMInteraktion,0);
+ if length(inMFInteraktion)<>0 then
+ raise Exception.create('Diese Person ist noch in einer MFInteraktion verzeichnet!');
+ setlength(inMFInteraktion,0);
+ inherited destroy;
+end;
+
+procedure tPerson.entferneElterIn(wo: tFamilie);
+var
+ i,j: longint;
+begin
+ for i:=length(ElterIn)-1 downto 0 do
+ if ElterIn[i]=wo then begin
+ for j:=i+1 to length(ElterIn)-1 do
+ ElterIn[j-1]:=ElterIn[j];
+ setlength(ElterIn,length(ElterIn)-1);
+ end;
+end;
+
+procedure tPerson.entferneKindIn(wo: tFamilie);
+begin
+ if KindIn=wo then
+ KindIn:=nil;
+end;
+
+procedure tPerson.fuegeInputInHinzu(wo: tVerknuepfung);
+var
+ i: longint;
+begin
+ for i:=0 to length(inputIn)-1 do
+ if inputIn[i]=wo then
+ writeln(inputIn[i+length(inputIn)].outP.id);
+ setlength(inputIn,length(inputIn)+1);
+ inputIn[length(inputIn)-1]:=wo;
+end;
+
+procedure tPerson.entferneInputIn(wo: tVerknuepfung);
+var
+ i,j: longint;
+begin
+ for i:=length(inputIn)-1 downto 0 do
+ if inputIn[i]=wo then begin
+ for j:=i+1 to length(inputIn)-1 do
+ inputIn[j-1]:=inputIn[j];
+ setlength(inputIn,length(inputIn)-1);
+ end;
+end;
+
+procedure tPerson.fuegeOutputInHinzu(wo: tVerknuepfung);
+var
+ i: longint;
+begin
+ for i:=0 to length(outputIn)-1 do
+ if outputIn[i]=wo then
+ writeln(outputIn[i+length(outputIn)].outP.id);
+ setlength(outputIn,length(outputIn)+1);
+ outputIn[length(outputIn)-1]:=wo;
+end;
+
+procedure tPerson.entferneOutputIn(wo: tVerknuepfung);
+var
+ i,j: longint;
+begin
+ for i:=length(outputIn)-1 downto 0 do
+ if outputIn[i]=wo then begin
+ for j:=i+1 to length(outputIn)-1 do
+ outputIn[j-1]:=outputIn[j];
+ setlength(outputIn,length(outputIn)-1);
+ end;
+end;
+
+procedure tPerson.fuegeInMMInteraktionHinzu(wo: tMMInteraktion);
+begin
+ setlength(inMMInteraktion,length(inMMInteraktion)+1);
+ inMMInteraktion[length(inMMInteraktion)-1]:=wo;
+end;
+
+procedure tPerson.entferneInMMInteraktion(wo: tMMInteraktion);
+var
+ i,j: longint;
+begin
+ for i:=length(inMMInteraktion)-1 downto 0 do
+ if inMMInteraktion[i]=wo then begin
+ for j:=i+1 to length(inMMInteraktion)-1 do
+ inMMInteraktion[j-1]:=inMMInteraktion[j];
+ setlength(inMMInteraktion,length(inMMInteraktion)-1);
+ end;
+end;
+
+procedure tPerson.fuegeInMFInteraktionHinzu(wo: tMFInteraktion);
+begin
+ setlength(inMFInteraktion,length(inMFInteraktion)+1);
+ inMFInteraktion[length(inMFInteraktion)-1]:=wo;
+end;
+
+procedure tPerson.entferneInMFInteraktion(wo: tMFInteraktion);
+var
+ i,j: longint;
+begin
+ for i:=length(inMFInteraktion)-1 downto 0 do
+ if inMFInteraktion[i]=wo then begin
+ for j:=i+1 to length(inMFInteraktion)-1 do
+ inMFInteraktion[j-1]:=inMFInteraktion[j];
+ setlength(inMFInteraktion,length(inMFInteraktion)-1);
+ end;
+end;
+
+procedure tPerson.init(p: tGenerikum);
+begin
+ inherited init(p);
+ if not (p is tPerson) then begin
+ writeln('Person kann nicht mit nicht-Person initialisiert werden!');
+ halt;
+ end;
+ Vorname:=(p as tPerson).Vorname;
+ Nachname:=(p as tPerson).Nachname;
+ P1:=(p as tPerson).P1;
+ P2:=(p as tPerson).P2;
+ P3:=(p as tPerson).P3;
+end;
+
+procedure tPerson.init(p: tGenerikum; var es: tEreignisArray);
+var
+ ea: tEreignisArt;
+begin
+ init(p);
+ Anfang:=FindeEreignis(es,pEreignisToStr((p as tPerson).Anfang));
+ Ende:=FindeEreignis(es,pEreignisToStr((p as tPerson).Ende));
+ for ea:=low(tEreignisArt) to high(tEreignisArt) do
+ Ereignisse[ea]:=FindeEreignis(es,pEreignisToStr((p as tPerson).Ereignisse[ea]));
+end;
+
+procedure tPerson.init(p: tGenerikum; var es: tEreignisArray; var fs: tFamilieArray);
+begin
+ init(p,es,fs,true);
+end;
+
+procedure tPerson.init(p: tGenerikum; var es: tEreignisArray; var fs: tFamilieArray; darfErzeugen: boolean);
+var
+ i,j: longint;
+begin
+ init(p,es);
+ KindIn:=findeFamilie(fs,pFamilieToStr((p as tPerson).KindIn),darfErzeugen);
+ if assigned(KindIn) and
+ not KindIn.hatKind(self) then begin
+ setlength(KindIn.Kinder,length(KindIn.Kinder)+1);
+ KindIn.Kinder[length(KindIn.Kinder)-1]:=self;
+ end;
+ setlength(ElterIn,length((p as tPerson).ElterIn));
+ for i:=length(ElterIn)-1 downto 0 do begin
+ ElterIn[i]:=findeFamilie(fs,pFamilieToStr((p as tPerson).ElterIn[i]),darfErzeugen);
+ if assigned(ElterIn[i]) and
+ not ElterIn[i].hatElter(self) then
+ ElterIn[i].Eltern[byte((p as tPerson).ElterIn[i].Eltern[1]=p)]:=self
+ else begin
+ for j:=i+1 to length(ElterIn)-1 do
+ ElterIn[j-1]:=ElterIn[j];
+ setlength(ElterIn,length(ElterIn)-1);
+ end;
+ end;
+end;
+
+function tPerson.anzahlVerbindungen: longint;
+begin
+ result:=length(ElterIn)+byte(assigned(KindIn));
+end;
+
+function tPerson.istGleich(p: tGenerikum): boolean;
+var
+ ea: tEreignisart;
+ i,j,cnt: longint;
+begin
+ result:=inherited istGleich(p);
+ if not (p is tPerson) then begin
+ writeln('Person kann nicht mit nicht-Person verglichen werden!');
+ halt;
+ end;
+ result:=
+ result and
+ (Vorname=(p as tPerson).Vorname) and
+ (Nachname=(p as tPerson).Nachname) and
+ Anfang.istGleich((p as tPerson).Anfang) and
+ Ende.istGleich((p as tPerson).Ende);
+ for ea:=low(tEreignisArt) to high(tEreignisArt) do
+ result:=
+ result and ((Ereignisse[ea]=(p as tPerson).Ereignisse[ea]) or Ereignisse[ea].istGleich((p as tPerson).Ereignisse[ea]));
+ result:=result and (pFamilieToStr(KindIn)=pFamilieToStr((p as tPerson).KindIn));
+ result:=result and (length(ElterIn)=length((p as tPerson).ElterIn));
+ if result then
+ for i:=0 to length(ElterIn)-1 do begin
+ cnt:=0;
+ for j:=0 to length(ElterIn)-1 do
+ if pFamilieToStr(ElterIn[i])=pFamilieToStr((p as tPerson).ElterIn[j]) then
+ inc(cnt);
+ result:=result and (cnt=1);
+ end;
+end;
+
+function tPerson.elterVonFamilie(eNum: longint): tFamilie;
+var
+ i: longint;
+begin
+ result:=nil;
+ for i:=0 to length(elterIn)-1 do
+ if elterIn[i].Eltern[eNum]=self then begin
+ if result<>nil then begin
+ writeln('*** Warnung ***');
+ writeln('Rückgabewert nicht eindeutig, Person '+pPersonToStr(self)+' ist Elter '+inttostr(eNum)+' in mehreren Familien!');
+ exit;
+ end;
+ result:=elterIn[i];
+ end;
+end;
+
+function tPerson.istElterIn(f: tFamilie): boolean;
+var
+ i: longint;
+begin
+ result:=false;
+ for i:=0 to length(elterIn)-1 do
+ result:=result or (elterIn[i]=f);
+end;
+
+// tFamilie ********************************************************************
+
+constructor tFamilie.create;
+begin
+ inherited create;
+ Anfang:=nil;
+ Verheiratet:=false;
+ Eltern[0]:=nil;
+ Eltern[1]:=nil;
+ fillchar(Kinder,sizeof(Kinder),#0);
+ fillchar(inMFInteraktion,sizeof(inMFInteraktion),#0);
+ fillchar(inFFInteraktion,sizeof(inFFInteraktion),#0);
+end;
+
+destructor tFamilie.destroy;
+var
+ i: longint;
+begin
+ for i:=0 to length(Kinder)-1 do
+ if assigned(Kinder[i]) then
+ Kinder[i].entferneKindIn(self);
+ for i:=0 to length(Eltern)-1 do
+ if assigned(Eltern[i]) then
+ Eltern[i].entferneElterIn(self);
+ setlength(Kinder,0);
+ if length(inMFInteraktion)<>0 then
+ raise Exception.create('Diese Familie ist noch in einer MFInteraktion verzeichnet!');
+ setlength(inMFInteraktion,0);
+ if length(inFFInteraktion)<>0 then
+ raise Exception.create('Diese Familie ist noch in einer FFInteraktion verzeichnet!');
+ setlength(inFFInteraktion,0);
+ inherited destroy;
+end;
+
+procedure tFamilie.entferneElter(wen: tPerson);
+var
+ i,anz: longint;
+begin
+ anz:=0;
+ for i:=0 to length(Eltern)-1 do
+ if Eltern[i]=wen then begin
+ inc(anz);
+ Eltern[i]:=nil;
+ end;
+ if anz=0 then begin
+ writeln('Ich habe den Elter '''+wen.ID+''' nicht in Familie '''+ID+''' gefunden!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Ich habe den Elter '''+wen.ID+''' mehrmals in Familie '''+ID+''' gefunden!');
+ halt;
+ end;
+end;
+
+procedure tFamilie.entferneKind(wen: tPerson);
+var
+ i,j,anz: longint;
+begin
+ anz:=0;
+ for i:=length(Kinder)-1 downto 0 do
+ if Kinder[i]=wen then begin
+ inc(Anz);
+ Kinder[i]:=nil;
+ for j:=i+1 to length(Kinder)-1 do
+ Kinder[j-1]:=Kinder[j];
+ setlength(Kinder,length(Kinder)-1);
+ end;
+ if anz=0 then begin
+ writeln('Ich habe das Kind '''+wen.ID+''' nicht in Familie '''+ID+''' gefunden!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Ich habe das Kind '''+wen.ID+''' mehrmals in Familie '''+ID+''' gefunden!');
+ halt;
+ end;
+end;
+
+procedure tFamilie.fuegeInMFInteraktionHinzu(wo: tMFInteraktion);
+begin
+ setlength(inMFInteraktion,length(inMFInteraktion)+1);
+ inMFInteraktion[length(inMFInteraktion)-1]:=wo;
+end;
+
+procedure tFamilie.entferneInMFInteraktion(wo: tMFInteraktion);
+var
+ i,j: longint;
+begin
+ for i:=length(inMFInteraktion)-1 downto 0 do
+ if inMFInteraktion[i]=wo then begin
+ for j:=i+1 to length(inMFInteraktion)-1 do
+ inMFInteraktion[j-1]:=inMFInteraktion[j];
+ setlength(inMFInteraktion,length(inMFInteraktion)-1);
+ end;
+end;
+
+procedure tFamilie.fuegeInFFInteraktionHinzu(wo: tFFInteraktion);
+begin
+ setlength(inFFInteraktion,length(inFFInteraktion)+1);
+ inFFInteraktion[length(inFFInteraktion)-1]:=wo;
+end;
+
+procedure tFamilie.entferneInFFInteraktion(wo: tFFInteraktion);
+var
+ i,j: longint;
+begin
+ for i:=length(inFFInteraktion)-1 downto 0 do
+ if inFFInteraktion[i]=wo then begin
+ for j:=i+1 to length(inFFInteraktion)-1 do
+ inFFInteraktion[j-1]:=inFFInteraktion[j];
+ setlength(inFFInteraktion,length(inFFInteraktion)-1);
+ end;
+end;
+
+procedure tFamilie.init(f: tGenerikum);
+begin
+ inherited init(f);
+ if not (f is tFamilie) then begin
+ writeln('Familie kann nicht mit nicht-Familie initialisiert werden!');
+ halt;
+ end;
+ Verheiratet:=(f as tFamilie).Verheiratet;
+end;
+
+procedure tFamilie.init(f: tGenerikum; var Es: tEreignisArray; var Ps: tPersonArray);
+begin
+ init(f,Es,Ps,true);
+end;
+
+procedure tFamilie.init(f: tGenerikum; var Es: tEreignisArray; var Ps: tPersonArray; darfErzeugen: boolean);
+var
+ i,j: longint;
+begin
+ init(f);
+ Anfang:=findeEreignis(Es,pEreignisToStr((f as tFamilie).Anfang));
+ for i:=0 to 1 do begin
+ Eltern[i]:=findePerson(Ps,pPersonToStr((f as tFamilie).Eltern[i]),darfErzeugen);
+ if assigned(Eltern[i]) and
+ not Eltern[i].istElterIn(self) then begin
+ setlength(Eltern[i].ElterIn,length(Eltern[i].ElterIn)+1);
+ Eltern[i].ElterIn[length(Eltern[i].ElterIn)-1]:=self;
+ end;
+ end;
+ setlength(Kinder,length((f as tFamilie).Kinder));
+ for i:=length(Kinder)-1 downto 0 do begin
+ Kinder[i]:=findePerson(Ps,pPersonToStr((f as tFamilie).Kinder[i]),darfErzeugen);
+ if assigned(Kinder[i]) then
+ Kinder[i].KindIn:=self
+ else begin
+ for j:=i+1 to length(Kinder)-1 do
+ Kinder[j-1]:=Kinder[j];
+ setlength(Kinder,length(Kinder)-1);
+ end;
+ end;
+end;
+
+function tFamilie.anzahlVerbindungen: longint;
+var
+ i: longint;
+begin
+ result:=length(Kinder);
+ for i:=0 to 1 do
+ result:=result+byte(assigned(Eltern[i]));
+end;
+
+function tFamilie.istGleich(f: tGenerikum): boolean;
+var
+ i,j,cnt: longint;
+begin
+ result:=inherited istGleich(f);
+ if not (f is tFamilie) then begin
+ writeln('Familie kann nicht mit nicht-Familie verglichen werden!');
+ halt;
+ end;
+ result:=
+ result and
+ (Verheiratet=(f as tFamilie).Verheiratet) and
+ (Anfang.istGleich((f as tFamilie).Anfang));
+ for i:=0 to 1 do
+ result:=
+ result and
+ (pPersonToStr(Eltern[i])=pPersonToStr((f as tFamilie).Eltern[i]));
+ result:=result and (length(Kinder)=length((f as tFamilie).Kinder));
+ if result then
+ for i:=0 to length(Kinder)-1 do begin
+ cnt:=0;
+ for j:=0 to length(Kinder)-1 do
+ if pPersonToStr(Kinder[i])=pPersonToStr((f as tFamilie).Kinder[j]) then
+ inc(cnt);
+ result:=result and (cnt=1);
+ end;
+end;
+
+function tFamilie.hatKind(p: tPerson): boolean;
+var
+ i: longint;
+begin
+ result:=false;
+ for i:=0 to length(Kinder)-1 do
+ result:=result or (Kinder[i]=p);
+end;
+
+function tFamilie.hatElter(p: tPerson): boolean;
+begin
+ result:=(Eltern[0]=p) or (Eltern[1]=p);
+end;
+
+// tVerknuepfung ***************************************************************
+
+procedure tVerknuepfung.wOutP(p: tPerson);
+begin
+ if assigned(outP) then begin
+ if assigned(outP.KindIn) then begin
+ if assigned(outP.KindIn.Eltern[0]) then
+ outP.KindIn.Eltern[0].entferneInputIn(self);
+ if assigned(outP.KindIn.Eltern[1]) then
+ outP.KindIn.Eltern[1].entferneInputIn(self);
+ outP.entferneOutputIn(self);
+ end;
+ end;
+ _outP:=p;
+ if assigned(outP) then begin
+ if assigned(outP.KindIn) then begin
+ if assigned(outP.KindIn.Eltern[0]) then
+ outP.KindIn.Eltern[0].fuegeInputInHinzu(self);
+ if assigned(outP.KindIn.Eltern[1]) then
+ outP.KindIn.Eltern[1].fuegeInputInHinzu(self);
+ outP.fuegeOutputInHinzu(self);
+ end;
+ end;
+end;
+
+destructor tVerknuepfung.destroy;
+begin
+ if assigned(outP) then begin
+ if assigned(outP.KindIn) then begin
+ if assigned(outP.KindIn.Eltern[0]) then
+ outP.KindIn.Eltern[0].entferneInputIn(self);
+ if assigned(outP.KindIn.Eltern[1]) then
+ outP.KindIn.Eltern[1].entferneInputIn(self);
+ end;
+ outP.entferneOutputIn(self);
+ end;
+ inherited destroy;
+end;
+
+function tVerknuepfung.istGleich(v: tVerknuepfung; p2p: tIntArray): boolean;
+var
+ i: longint;
+ c: char;
+begin
+ result:=
+ (pPersonToStr(outP)=pPersonToStr(v.outP)) and
+ paramsGleich(Lambda,v.Lambda,p2p);
+ for c:='x' to 'y' do begin
+ result:=result and paramsGleich(Output[c],v.Output[c],p2p);
+ for i:=0 to 1 do
+ result:=result and paramsGleich(Input[i,c],v.Input[i,c],p2p);
+ end;
+end;
+
+// tMMInteraktion **************************************************************
+
+function tMMInteraktion.r_Ps(i: longint): tPerson;
+begin
+ result:=__Ps[i];
+end;
+
+procedure tMMInteraktion.w_Ps(i: longint; p: tPerson);
+begin
+ if assigned(_Ps[i]) then
+ _Ps[i].entferneInMMInteraktion(self);
+ __Ps[i]:=p;
+ if assigned(_Ps[i]) then
+ _Ps[i].fuegeInMMInteraktionHinzu(self);
+end;
+
+function tMMInteraktion.istGleich(ia: tMMInteraktion): boolean;
+var
+ i: longint;
+begin
+ result:=Laenge=ia.Laenge;
+ for i:=0 to 1 do
+ result:=result and (pPersonToStr(_Ps[i])=pPersonToStr(ia._Ps[i]));
+end;
+
+destructor tMMInteraktion.destroy;
+begin
+ if assigned(_Ps[0]) then
+ _Ps[0].entferneInMMInteraktion(self);
+ if assigned(_Ps[1]) then
+ _Ps[1].entferneInMMInteraktion(self);
+ inherited destroy;
+end;
+
+// tMFInteraktion **************************************************************
+
+procedure tMFInteraktion.w_P(p: tPerson);
+begin
+ if assigned(_P) then
+ _P.entferneInMFInteraktion(self);
+ __P:=p;
+ if assigned(_P) then
+ _P.fuegeInMFInteraktionHinzu(self);
+end;
+
+procedure tMFInteraktion.w_F(f: tFamilie);
+begin
+ if assigned(_F) then
+ _F.entferneInMFInteraktion(self);
+ __F:=f;
+ if assigned(_F) then
+ _F.fuegeInMFInteraktionHinzu(self);
+end;
+
+function tMFInteraktion.istGleich(ia: tMFInteraktion): boolean;
+begin
+ result:=
+ (Laenge=ia.Laenge) and
+ (pPersonToStr(_P)=pPersonToStr(ia._P)) and
+ (pFamilieToStr(_F)=pFamilieToStr(ia._F));
+end;
+
+destructor tMFInteraktion.destroy;
+begin
+ if assigned(_P) then
+ _P.entferneInMFInteraktion(self);
+ if assigned(_F) then
+ _F.entferneInMFInteraktion(self);
+ inherited destroy;
+end;
+
+// tFFInteraktion **************************************************************
+
+function tFFInteraktion.r_Fs(i: longint): tFamilie;
+begin
+ result:=__Fs[i];
+end;
+
+procedure tFFInteraktion.w_Fs(i: longint; f: tFamilie);
+begin
+ if assigned(_Fs[i]) then
+ _Fs[i].entferneInFFInteraktion(self);
+ __Fs[i]:=f;
+ if assigned(_Fs[i]) then
+ _Fs[i].fuegeInFFInteraktionHinzu(self);
+end;
+
+function tFFInteraktion.istGleich(ia: tFFInteraktion): boolean;
+var
+ i: longint;
+begin
+ result:=true;
+ for i:=0 to 1 do
+ result:=result and (pFamilieToStr(_Fs[i])=pFamilieToStr(ia._Fs[i]));
+end;
+
+destructor tFFInteraktion.destroy;
+begin
+ if assigned(_Fs[0]) then
+ _Fs[0].entferneInFFInteraktion(self);
+ if assigned(_Fs[1]) then
+ _Fs[1].entferneInFFInteraktion(self);
+ inherited destroy;
+end;
+
+// tZusammenhangskomponente ****************************************************
+constructor tZusammenhangskomponente.create;
+begin
+ inherited create;
+ fillchar(Familien,sizeof(Familien),#0);
+ setlength(Familien,0);
+end;
+
+destructor tZusammenhangskomponente.destroy;
+begin
+ setlength(Familien,0);
+ inherited destroy;
+end;
+
+function tZusammenhangskomponente.grenztAn(p: tPerson): boolean;
+var i,j: longint;
+begin
+ result:=false;
+ for i:=0 to length(Familien)-1 do begin
+ for j:=0 to 1 do
+ result:=result or (assigned(Familien[i].Eltern[j]) and (p.ID=Familien[i].Eltern[j].ID));
+ for j:=0 to length(Familien[i].Kinder)-1 do
+ result:=result or (p.ID=Familien[i].Kinder[j].ID);
+ end;
+end;
+
+procedure tZusammenhangskomponente.verschmelzeMit(zhk: tZusammenhangskomponente);
+var i,j: longint;
+ gefunden: boolean;
+begin
+ for i:=0 to length(zhk.Familien)-1 do begin
+ gefunden:=false;
+ for j:=0 to length(Familien)-1 do
+ gefunden:=gefunden or (zhk.Familien[i].ID=Familien[j].ID);
+ if not gefunden then begin
+ setlength(Familien,length(Familien)+1);
+ Familien[length(Familien)-1]:=zhk.Familien[i];
+ end;
+ end;
+end;
+
+procedure tZusammenhangskomponente.UmfeldEinfuegen(Fs: tFamilieArray; p: tPerson);
+var i,j: longint;
+ gefunden: boolean;
+begin
+ for i:=0 to length(Fs)-1 do begin
+ gefunden:=false;
+ for j:=0 to 1 do
+ gefunden:=gefunden or (assigned(Fs[i].Eltern[j]) and (p.ID=Fs[i].Eltern[j].ID));
+ for j:=0 to length(Fs[i].Kinder)-1 do
+ gefunden:=gefunden or (p.ID=Fs[i].Kinder[j].ID);
+ if gefunden then begin
+ for j:=0 to length(Familien)-1 do
+ gefunden:=gefunden and (Familien[j].ID <> Fs[i].ID);
+ if gefunden then begin
+ setlength(Familien,length(Familien)+1);
+ Familien[length(Familien)-1]:=Fs[i];
+ end;
+ end;
+ end;
+end;
+
+// tGraph **********************************************************************
+
+constructor tGraph.create;
+begin
+ inherited create;
+ fillchar(Ecken,sizeof(Ecken),#0);
+ setlength(Ecken,0);
+ fillchar(Kanten,sizeof(Kanten),#0);
+ setlength(Kanten,0);
+end;
+
+destructor tGraph.destroy;
+begin
+ setlength(Ecken,0);
+ setlength(Kanten,0);
+end;
+
+function tGraph.entferneBlaetter(var f: tIntArray): tIntArray;
+var i,j,n1,n2,anz: longint;
+ gefunden: boolean;
+begin
+ setlength(result,0);
+ anz:=0;
+ repeat
+ gefunden:=false;
+ for i:=length(f)-1 downto 0 do begin // nur Kanten, die noch dabei sind, können gelöscht werden
+ n1:=0;
+ n2:=0;
+ for j:=0 to length(f)-1 do begin // angrenzende Kanten, die noch dabei sind, zählen
+ n1:=n1 + byte((Kanten[f[j]].x=Kanten[f[i]].x) or (Kanten[f[j]].y=Kanten[f[i]].x));
+ n2:=n2 + byte((Kanten[f[j]].x=Kanten[f[i]].y) or (Kanten[f[j]].y=Kanten[f[i]].y));
+ end;
+ if (n1<=1) or (n2<=1) then begin // nur die Kante i selbst hängt an einer ihrer Ecken
+ gefunden:=true;
+ if anz>=length(result) then
+ setlength(result,anz+1024);
+ result[anz]:=f[i];
+ inc(anz);
+ for j:=i+1 to length(f)-1 do // aus dem Rennen
+ f[j-1]:=f[j];
+ setlength(f,length(f)-1);
+ end;
+ end;
+ until not gefunden;
+ setlength(result,anz);
+end;
+
+function tGraph.Pfadigkeit(Ks: tIntArray; a,b: longint): longint; // 0 -> zu wenig; 1 -> ein Pfad; 2-> zu viel
+var i,j,k,ich,letzter: longint;
+begin
+ ich:=a;
+ letzter:=-1;
+ repeat
+ j:=-1;
+ k:=0;
+ for i:=0 to length(Ks)-1 do begin
+ if (Kanten[Ks[i]].x=ich) and (Kanten[Ks[i]].y<>letzter) then begin // vorwärts immer, rückwärts nimmer
+ j:=Ks[i];
+ inc(k);
+ end;
+ if (Kanten[Ks[i]].y=ich) and (Kanten[Ks[i]].x<>letzter) then begin // vorwärts immer, rückwärts nimmer
+ j:=Ks[i];
+ inc(k);
+ end;
+ end;
+ if k=0 then begin // hier geht es nicht weiter
+ result:=0;
+ exit;
+ end;
+ if k>1+byte((letzter=-1) and (a=b)) then begin // hier gibt es eine Weggabelung
+ result:=2;
+ exit;
+ end;
+ if Kanten[j].x=ich then begin
+ letzter:=ich;
+ ich:=Kanten[j].y;
+ end
+ else begin
+ letzter:=ich;
+ ich:=Kanten[j].x;
+ end;
+ until ich=b;
+ result:=1;
+end;
+
+function tGraph.etwasDoppelt: boolean;
+var Ks: tIntArray;
+ i: longint;
+begin
+ setlength(Ks,length(Kanten));
+ for i:=0 to length(Ks)-1 do
+ Ks[i]:=i;
+ result:=etwasDoppelt(Ks);
+end;
+
+function tGraph.etwasDoppelt(Ks: tIntArray): boolean;
+var i,j: longint;
+begin
+ result:=false;
+ for i:=0 to length(Ks)-2 do
+ for j:=i+1 to length(Ks)-1 do
+ result:=
+ result or
+ ((Kanten[Ks[i]].x = Kanten[Ks[j]].x) and (Kanten[Ks[i]].y = Kanten[Ks[j]].y)) or
+ ((Kanten[Ks[i]].x = Kanten[Ks[j]].y) and (Kanten[Ks[i]].y = Kanten[Ks[j]].x));
+end;
+
+function tGraph.etwasRedundant(Ks1,Ks2: tIntArray): boolean;
+var i,j: longint;
+begin
+ result:=false;
+ for i:=0 to length(Ks1)-1 do
+ for j:=0 to length(Ks2)-1 do
+ result:=
+ result or
+ ((Kanten[Ks1[i]].x = Kanten[Ks2[j]].x) and (Kanten[Ks1[i]].y = Kanten[Ks2[j]].y)) or
+ ((Kanten[Ks1[i]].x = Kanten[Ks2[j]].y) and (Kanten[Ks1[i]].y = Kanten[Ks2[j]].x));
+end;
+
+procedure tGraph.dumpKantenArray(Ks: tIntArray);
+var
+ i: longint;
+begin
+ writeln(length(Ks));
+ for i:=0 to length(Ks)-1 do
+ writeln(' '+inttostr(Kanten[Ks[i]].x)+' -- '+inttostr(Kanten[Ks[i]].y));
+end;
+
+function tGraph.findeKreise: tIntArrayArray;
+var Farben: tIntArray;
+ i: longint;
+begin
+ setlength(result,0);
+ setlength(Farben,length(Kanten));
+ for i:=0 to length(Farben)-1 do // alles noch dabei
+ Farben[i]:=i;
+ entferneBlaetter(Farben);
+ if length(Farben)>0 then begin
+ result:=findeKreise(Farben);
+ exit;
+ end;
+end;
+
+function tGraph.findeKreise(f: tIntArray): tIntArrayArray;
+var j,k,l,m: longint;
+ loeschung,
+ sicherung: tIntArray;
+begin
+ setlength(result,0);
+ setlength(sicherung,length(f)-1);
+ for j:=0 to length(sicherung)-1 do
+ sicherung[j]:=f[j];
+ loeschung:=entferneBlaetter(sicherung);
+ if length(sicherung)>0 then begin // es sind noch Kanten da, also auch noch Kreise!
+ result:=findeKreise(sicherung); // alle bisher gefundenen Kreise
+ setlength(sicherung,length(sicherung)+length(loeschung)+1);
+ for j:=0 to length(loeschung)-1 do // alle gelöschten Kanten wieder einfügen ...
+ sicherung[length(sicherung)-j-2]:=loeschung[j];
+ sicherung[length(sicherung)-1]:=f[length(f)-1]; // ... wirklich alle!
+ for j:=0 to length(result)-1 do begin // jedem Kreis, der noch in sicherung ist ...
+ m:=-1;
+ for k:=0 to length(result[j])-1 do
+ if m=-1 then
+ for l:=0 to length(sicherung)-1 do
+ if sicherung[l]=result[j,k] then begin // die l-te Kante der Sicherung ist im j-ten Kreis (die k-te Kante)
+ m:=l;
+ break;
+ end;
+ if m=-1 then begin
+ writeln('interessanter Weise habe ich keine Kanten gefunden ...');
+ halt(1);
+ end;
+ for k:=m+1 to length(sicherung)-1 do // ... wird eine noch vorhandene Kante gelöscht ...
+ sicherung[k-1]:=sicherung[k];
+ setlength(sicherung,length(sicherung)-1);
+ entferneBlaetter(sicherung); // ... und dann die Blätter entfernt
+ end;
+ // jetzt sollte ein einziger, "neuer", Kreis verblieben sein
+ if pfadigkeit(sicherung,Kanten[sicherung[0]].x,Kanten[sicherung[0]].x)<>1 then begin
+ writeln('Die Pfadigkeit ist '+inttostr(pfadigkeit(sicherung,Kanten[sicherung[0]].x,Kanten[sicherung[0]].x))+' und nicht 1!');
+ writeln('Der Programmierer hat sich geirrt.'); // offenbar ist es kein einfacher Kreis :-/
+ halt(1);
+ end;
+ setlength(result,length(result)+1);
+ setlength(result[length(result)-1],length(sicherung));
+ for j:=0 to length(sicherung)-1 do
+ result[length(result)-1,j]:=sicherung[j];
+ exit;
+ end;
+
+ setlength(result,1); // es war der letzte Kreis
+ setlength(result[0],length(loeschung)+1);
+ for j:=0 to length(loeschung)-1 do
+ result[0,j]:=loeschung[j];
+ result[0,length(loeschung)]:=f[length(f)-1];
+
+ if pfadigkeit(result[0],Kanten[result[0,0]].x,Kanten[result[0,0]].x)<>1 then begin
+ writeln('Die Pfadigkeit ist '+inttostr(pfadigkeit(result[0],Kanten[result[0,0]].x,Kanten[result[0,0]].x))+' und nicht 1!');
+ writeln('Der Programmierer hat sich geirrt.'); // offenbar ist es kein einfacher Kreis :-/
+ writeln('f:');
+ dumpKantenArray(f);
+ writeln('result[0]:');
+ dumpKantenArray(result[0]);
+ writeln('loeschung:');
+ dumpKantenArray(loeschung);
+ halt(1);
+ end;
+end;
+
+// tSortObject *****************************************************************
+
+constructor tSortObject.create;
+begin
+ inherited create;
+ oG:=nil;
+ oMM:=nil;
+ oMF:=nil;
+ oFF:=nil;
+ oV:=nil;
+ fillchar(ID,sizeof(ID),#0);
+ ID:='';
+end;
+
+procedure tSortObject.assign(g: tGenerikum);
+begin
+ oG:=g;
+ oMM:=nil;
+ oMF:=nil;
+ oFF:=nil;
+ oV:=nil;
+ ID:=sortStringFromObject(g);
+end;
+
+procedure tSortObject.assign(i: tMMInteraktion);
+begin
+ oG:=nil;
+ oMM:=i;
+ oMF:=nil;
+ oFF:=nil;
+ oV:=nil;
+ ID:=sortStringFromObject(oMM);
+end;
+
+procedure tSortObject.assign(i: tMFInteraktion);
+begin
+ oG:=nil;
+ oMM:=nil;
+ oMF:=i;
+ oFF:=nil;
+ oV:=nil;
+ ID:=sortStringFromObject(oMF);
+end;
+
+procedure tSortObject.assign(i: tFFInteraktion);
+begin
+ oG:=nil;
+ oMM:=nil;
+ oMF:=nil;
+ oFF:=i;
+ oV:=nil;
+ ID:=sortStringFromObject(oFF);
+end;
+
+procedure tSortObject.assign(v: tVerknuepfung);
+begin
+ oG:=nil;
+ oMM:=nil;
+ oMF:=nil;
+ oFF:=nil;
+ oV:=v;
+ ID:=sortStringFromObject(oV);
+end;
+
+// allgemeine Funktionen *******************************************************
+
+function sortStringFromObject(g: tGenerikum): string;
+begin
+ result:=g.ID;
+end;
+
+function sortStringFromObject(i: tMMInteraktion): string;
+begin
+ result:=pPersonToStr(i._Ps[0])+','+pPersonToStr(i._Ps[1]);
+end;
+
+function sortStringFromObject(i: tMFInteraktion): string;
+begin
+ result:=pPersonToStr(i._P)+','+pFamilieToStr(i._F);;
+end;
+
+function sortStringFromObject(i: tFFInteraktion): string;
+begin
+ result:=pFamilieToStr(i._Fs[0])+','+pFamilieToStr(i._Fs[1]);
+end;
+
+function sortStringFromObject(v: tVerknuepfung): string;
+begin
+ result:=pPersonToStr(v.outP);
+end;
+
+function sortiere(arr: tGenerikumArray): tGenerikumArray; overload; inline;
+var
+ saIn,saOut: tSortObjectArray;
+ i: longint;
+begin
+ setlength(saIn,length(arr));
+ for i:=0 to length(saIn)-1 do begin
+ saIn[i]:=tSortObject.create;
+ saIn[i].assign(arr[i]);
+ end;
+ saOut:=sortiere(saIn);
+ setlength(result,length(saOut));
+ for i:=0 to length(result)-1 do begin
+ result[i]:=saOut[i].oG;
+ saOut[i].free;
+ end;
+ setlength(saIn,0);
+ setlength(saOut,0);
+end;
+
+function sortiere(arr: tMMInteraktionArray): tMMInteraktionArray; overload; inline;
+var
+ saIn,saOut: tSortObjectArray;
+ i: longint;
+begin
+ setlength(saIn,length(arr));
+ for i:=0 to length(saIn)-1 do begin
+ saIn[i]:=tSortObject.create;
+ saIn[i].assign(arr[i]);
+ end;
+ saOut:=sortiere(saIn);
+ setlength(result,length(saOut));
+ for i:=0 to length(result)-1 do begin
+ result[i]:=saOut[i].oMM;
+ saOut[i].free;
+ end;
+ setlength(saIn,0);
+ setlength(saOut,0);
+end;
+
+function sortiere(arr: tMFInteraktionArray): tMFInteraktionArray; overload; inline;
+var
+ saIn,saOut: tSortObjectArray;
+ i: longint;
+begin
+ setlength(saIn,length(arr));
+ for i:=0 to length(saIn)-1 do begin
+ saIn[i]:=tSortObject.create;
+ saIn[i].assign(arr[i]);
+ end;
+ saOut:=sortiere(saIn);
+ setlength(result,length(saOut));
+ for i:=0 to length(result)-1 do begin
+ result[i]:=saOut[i].oMF;
+ saOut[i].free;
+ end;
+ setlength(saIn,0);
+ setlength(saOut,0);
+end;
+
+function sortiere(arr: tFFInteraktionArray): tFFInteraktionArray; overload; inline;
+var
+ saIn,saOut: tSortObjectArray;
+ i: longint;
+begin
+ setlength(saIn,length(arr));
+ for i:=0 to length(saIn)-1 do begin
+ saIn[i]:=tSortObject.create;
+ saIn[i].assign(arr[i]);
+ end;
+ saOut:=sortiere(saIn);
+ setlength(result,length(saOut));
+ for i:=0 to length(result)-1 do begin
+ result[i]:=saOut[i].oFF;
+ saOut[i].free;
+ end;
+ setlength(saIn,0);
+ setlength(saOut,0);
+end;
+
+function sortiere(arr: tVerknuepfungArray): tVerknuepfungArray; overload; inline;
+var
+ saIn,saOut: tSortObjectArray;
+ i: longint;
+begin
+ setlength(saIn,length(arr));
+ for i:=0 to length(saIn)-1 do begin
+ saIn[i]:=tSortObject.create;
+ saIn[i].assign(arr[i]);
+ end;
+ saOut:=sortiere(saIn);
+ setlength(result,length(saOut));
+ for i:=0 to length(result)-1 do begin
+ result[i]:=saOut[i].oV;
+ saOut[i].free;
+ end;
+ setlength(saIn,0);
+ setlength(saOut,0);
+end;
+
+function sortiere(arr: tSortObjectArray): tSortObjectArray;
+var
+ i: longint;
+ mi,ma: string;
+begin
+ setlength(result,length(arr));
+ if length(arr)=0 then exit;
+ mi:=arr[0].ID;
+ ma:=arr[0].ID;
+ for i:=0 to length(result)-1 do begin
+ result[i]:=arr[i];
+ if cmpStr(mi,arr[i].ID)>0 then
+ mi:=arr[i].ID;
+ if cmpStr(ma,arr[i].ID)<0 then
+ ma:=arr[i].ID;
+ end;
+ sortiere(result,0,length(result)-1,mi,ma);
+end;
+
+procedure sortiere(var arr: tSortObjectArray; von,bis: longint; mi,ma: string);
+var
+ li,re: longint;
+ pivot: string;
+ tmp: tSortObject;
+begin
+ if (von>=bis) or (mi=ma) then exit;
+ li:=von;
+ re:=bis;
+ pivot:=mitte(mi,ma);
+
+ while li<=re do begin
+ while (li<=re) and
+ (cmpStr(arr[li].ID,pivot)<=0) do
+ inc(li);
+ while (li<=re) and
+ (cmpStr(arr[re].ID,pivot)>=0) do
+ dec(re);
+ if li>=re then continue;
+ tmp:=arr[li];
+ arr[li]:=arr[re];
+ arr[re]:=tmp;
+ tmp:=nil;
+ inc(li);
+ dec(re);
+ end;
+ if li<>re+1 then begin
+ writeln('Fehler bei der Pivotisierung: li='+inttostr(li)+' und re='+inttostr(re));
+ halt;
+ end;
+ sortiere(arr,von,li-1,mi,pivot);
+ sortiere(arr,re+1,bis,pivot,ma);
+end;
+
+end.
diff --git a/grampsunit.pas b/grampsunit.pas
new file mode 100644
index 0000000..566c394
--- /dev/null
+++ b/grampsunit.pas
@@ -0,0 +1,4674 @@
+unit grampsunit;
+
+interface
+
+{ $DEFINE detaillierteZeitanalyse}
+
+uses cthreads, grampstypen, sysutils, classes, gmp, grampsmath, randomunit, mystringlistunit, matheunit, systemunit;
+
+const
+ aktuellesJahr = 2015;
+ Standardhochzeitsalter = 25;
+ StandardLebensdauer = 80;
+ Jahrestoleranz = 2;
+ Zusatzueberlapp = 2*Jahrestoleranz;
+ Ueberlappcutoff = 20;
+ Entkreuzungsbelohnungsskalierung = 1e9;
+ OptimaleEhelaenge = 0.03;
+ Laengengewicht = 2*Ueberlappcutoff/(8*sqr(OptimaleEhelaenge*sqr(sqr(OptimaleEhelaenge))));
+ sollABAnteil = 1/20;
+ Schrittweitenmultiplikator = 1.2;
+ epsilon = 1e-100;
+ minSchrittweite = 1e-13;
+ SchrittweitenSchwelle = 1e-10;
+
+ WenTauschen: array[0..3,0..1] of Byte = ((0,0),(0,1),(1,1),(1,0));
+
+type
+ tTimer = class
+ Zeit: extended;
+ stStCnt: int64;
+ running: boolean;
+ constructor create;
+ procedure start;
+ procedure stop;
+ function gibZeit: extended;
+ function gibZeitMittel: extended;
+ end;
+ tNotAus = class(TObject)
+ private
+ bitteBeenden: boolean;
+ public
+ Stati: array[0..9] of boolean;
+ lastKey: char;
+ function istZuende: boolean;
+ constructor create;
+ end;
+
+ tMetaData = class(TObject)
+ private
+ {$IFDEF detaillierteZeitanalyse}
+ abvTimer,ffTimer,mmTimer,mfTimer,famTimer: tTimer;
+ {$ENDIF}
+ Sicherung: tMetaData;
+ Laubhaufen: tGenerikumArray;
+ personAuchDrueber,
+ familieAuchDrueber: tBooleanArray; // ist die Person/Familie auch im darüberliegenden tMetaData vorhanden? (hat nur Bedeutung, wenn es sich um tMetaData.Sicherung handelt)
+ procedure loescheVerknuepfungenZu(p: tPerson);
+ procedure loescheAlleVerbindungenZu(p: tPerson; f: tFamilie);
+ procedure arraysAufraeumen;
+ public
+ ParameterLaenge: longint;
+
+ Ereignisse: tEreignisArray;
+ Personen: tPersonArray;
+ Familien: tFamilieArray;
+
+ Verknuepfungen: tVerknuepfungArray;
+ MMInteraktionen: tMMInteraktionArray;
+ MFInteraktionen: tMFInteraktionArray;
+ FFInteraktionen: tFFInteraktionArray;
+ Parameterattribute: tParameterAttributArray;
+ UnabIndizes: tIntArray;
+ Tauschfamilien: tFamilieArray;
+ constructor create;
+ destructor destroy; override;
+ procedure init(md: tMetaData);
+ procedure printStatus(Level: longint);
+ {$IFDEF detaillierteZeitanalyse}
+ procedure printTimer(prefix: string);
+ {$ENDIF}
+ procedure berechneAbhaengigeVariable(var P: tExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+ procedure GradientenRueckPropagation(P: tExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}; var grad: tExtendedArray);
+ function Energie(P: tExtendedArray; out Kreuzungen, Kreuzung: longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}): extended;
+ procedure Gradient(P: TExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}; var grad: tExtendedArray);
+// function findeNaechstesAbhaengiges(Fam: tFamilie; out wo: longint; out Pers: tPerson): boolean;
+ function ladeXML(Datei: String): boolean;
+ procedure generiereFehlendeInfos;
+ function analysiereInteraktionen: boolean;
+ function findeKreise: tPointArrayArray; // x: Person, y: Familie
+ procedure blaetterAbschneiden;
+ procedure letztesBlattWiederAnkleben(out vkn: tVerknuepfung; out p: tPerson);
+ // gibt neue Verknüpfung zurück (oder nil, falls neue Familie eingefügt wurde) und neue Person (oder nil, falls beide Eltern neu sind)
+ procedure nurGroeszteZusammenhangskomponente;
+ procedure konsistenzTest(mitIndizes: boolean);
+ procedure pruefeAufGleichheit(vgl: tMetaData);
+ procedure habePersonGeloescht(p: tPerson);
+ procedure habeFamilieGeloescht(f: tFamilie);
+ procedure habePersonHinzugefuegt(p: tPerson);
+ procedure habeFamilieHinzugefuegt(f: tFamilie);
+ function istPersonAuchDrueber(p: tPerson): boolean;
+ function istFamilieAuchDrueber(f: tFamilie): boolean;
+ procedure indizesErzeugen;
+ function anzUnabhaengig: longint;
+ function anzUnbenutzt: longint;
+ end;
+
+ tParameterSimplex = class
+ private
+ dim,pdim: longint;
+ Ecken: array of tExtendedArray;
+ Schwerpunkt,Energien: tExtendedArray;
+ Kreuzungens,Kreuzungs,Reihenfolge: tIntArray;
+ letzteSchwerpunktberechnung: longint;
+ letzteSchwerpunktabweichung: extended;
+ function besserAls(a,b: longint): longint; overload; // -1: a schlechter als b; 0: gleich gut; 1: a besser als b
+ function besserAls(aKrz: longint; aEnerg: extended; b: longint): longint; overload; // -1: a schlechter als b; 0: gleich gut; 1: a besser als b
+ function besserAls(a,b: longint; hart: boolean): longint; overload; // -1: a schlechter als b; 0: gleich gut (nur, wenn hart=false); 1: a besser als b
+ procedure ordnen;
+ function einsortieren(wen,Luecke: longint): longint;
+ function normalisiere(i: longint): boolean; overload;
+ function normalisiere(ps: tExtendedArray): boolean; overload;
+ procedure berechneEnergien(mt: longint); overload;
+ procedure berechneEnergien(mt: longint; ParameterBerechnen: boolean); overload;
+ function berechneSchwerpunkt: extended;
+ public
+ md: tMetaData;
+ constructor create;
+ destructor destroy; override;
+ procedure init(ps: tExtendedArray; mt: longint);
+ procedure outit(var ps: tExtendedArray);
+ function simplexSchritt(f,f1,f2,f3: extended; offset: longint): tSchrittErgebnis; overload;
+ function simplexSchritt(var np: tExtendedArray; f,f1,f2,f3: extended; offset: longint): tSchrittErgebnis; overload; // ohne Speicher-Alloziierung
+ // f ... erster Versuch
+ // f1 ... wenn schlechtester
+ // f2 ... sonst
+ // f3 ... wenn bester
+ procedure berechneEnergie(i: longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+ procedure berechneAbhaengigeVariable(i: longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+ function minKreuzungen: longint;
+ function maxKreuzungen: longint;
+ function minEnergie: extended;
+ function maxEnergie: extended;
+ procedure printHistogramm;
+ function mittlereKantenlaenge: extended;
+ procedure printSpur(nam: string; von,nach: longint);
+ end;
+
+ tStabile = class(TObject)
+ private
+ NotAus: tNotAus;
+ MD: tMetaData;
+ Parameter: tExtendedArray;
+ Kreuzungen,Schritte: longint;
+ Energie,stepsize,laufzeit: extended;
+ procedure setzeFamilie(Fam: tFamilie; x,y,dist,lambda: extended; var P: tExtendedArray);
+ public
+ property Zeit: extended read laufzeit;
+ constructor create; overload;
+ constructor create(MetaData: TMetaData); overload;
+ destructor destroy; override;
+ procedure assignMetaData(MetaData: TMetaData);
+ procedure printStatus(Level: Longint);
+ function ladeXML(Datei: String): boolean;
+ procedure generiereFehlendeInfos;
+ procedure nurGroeszteZusammenhangskomponente;
+ procedure blaetterAbschneiden;
+ function analysiereInteraktionen: boolean;
+ function LadeVonDatei(Datei: String): boolean;
+ function SpeichereInDatei(Datei: String): boolean;
+ procedure Initialisiere(Anzahl: Longint; Art: string);
+ procedure optimiere;
+ procedure downHillSimplex;
+ procedure gradientenOptimierung;
+ end;
+
+ tEnergieThread = class(tThread)
+ _s: tParameterSimplex;
+ _von,_bis: longint;
+ fertig,bp: boolean;
+ constructor create(s: tParameterSimplex; von,bis: longint; psBerechnen: boolean);
+ destructor destroy; override;
+ procedure execute; override;
+ end;
+
+ tStabileInitThread = class(tThread)
+ private
+ _s: tStabile;
+ _werDran,_extraZufall: tIntArray; // werDran[wannDran[i].x] = i und
+ // wannDran[werDran[j]].x = j
+ _wannDran: t4DPointArray; // 2 ^ -wannDran[i].y ist die eigene Sollbeziehungslänge;
+ _anzahl: longint;
+ _Art: char;
+ _mt: tMersenneTwister;
+ public
+ fertig: boolean;
+ Kreuzungen: longint;
+ Energie: extended;
+ Parameter: tExtendedArray;
+ constructor create(s: tStabile; werDran,extraZufall: tIntArray; wannDran: t4DPointArray; art: char; anzahl: longint);
+ destructor destroy; override;
+ procedure execute; override;
+ end;
+
+implementation
+
+uses crt, math;
+
+constructor tTimer.create;
+begin
+ inherited create;
+ running:=false;
+ Zeit:=0;
+ stStCnt:=0;
+end;
+
+procedure tTimer.start;
+begin
+ if running then exit;
+ running:=true;
+ inc(stStCnt);
+ Zeit:=Zeit-now;
+end;
+
+procedure tTimer.stop;
+begin
+ if not running then exit;
+ running:=false;
+ Zeit:=Zeit+now;
+end;
+
+function tTimer.gibZeit: extended;
+begin
+ if running then
+ result:=Zeit+now
+ else
+ result:=Zeit;
+end;
+
+function tTimer.gibZeitMittel: extended;
+begin
+ if stStCnt=0 then
+ result:=0
+ else if running then
+ result:=(Zeit+now)/stStCnt
+ else
+ result:=Zeit/stStCnt;
+end;
+
+// ********************************* TNotAus ********************************************************
+
+function TNotAus.istZuende: boolean;
+var c: char;
+begin
+ if keyPressed then begin
+ c:=readkey;
+ case c of
+ #27,'q': bitteBeenden:=true;
+ ' ','p': readkey;
+ '0'..'9': Stati[ord(c)-ord('0')]:=not Stati[ord(c)-ord('0')];
+ else lastKey:=c;
+ end{of case};
+ end;
+ result:=bitteBeenden;
+end;
+
+constructor TNotAus.create;
+var i: longint;
+begin
+ inherited create;
+ bitteBeenden:=false;
+ for i:=0 to 9 do
+ stati[i]:=i<>6;
+ lastKey:=#0;
+end;
+
+// ************************************** TMetaData **********************************************
+
+constructor TMetaData.create;
+begin
+ inherited create;
+ fillchar(Ereignisse,sizeof(Ereignisse),#0);
+ setlength(Ereignisse,0);
+ fillchar(Personen,sizeof(Personen),#0);
+ setlength(Personen,0);
+ fillchar(Familien,sizeof(Familien),#0);
+ setlength(Familien,0);
+ fillchar(Verknuepfungen,sizeof(Verknuepfungen),#0);
+ setlength(Verknuepfungen,0);
+ fillchar(MMInteraktionen,sizeof(MMInteraktionen),#0);
+ setlength(MMInteraktionen,0);
+ fillchar(MFInteraktionen,sizeof(MFInteraktionen),#0);
+ setlength(MFInteraktionen,0);
+ fillchar(FFInteraktionen,sizeof(FFInteraktionen),#0);
+ setlength(FFInteraktionen,0);
+ fillchar(Tauschfamilien,sizeof(Tauschfamilien),#0);
+ setlength(Tauschfamilien,0);
+ fillchar(ParameterAttribute,sizeof(ParameterAttribute),#0);
+ setlength(ParameterAttribute,0);
+ Sicherung:=nil;
+ fillchar(Laubhaufen,sizeof(Laubhaufen),#0);
+ setlength(Laubhaufen,0);
+ fillchar(personAuchDrueber,sizeof(personAuchDrueber),#0);
+ setlength(personAuchDrueber,0);
+ fillchar(familieAuchDrueber,sizeof(familieAuchDrueber),#0);
+ setlength(familieAuchDrueber,0);
+ {$IFDEF detaillierteZeitanalyse}
+ abvTimer:=tTimer.create;
+ ffTimer:=tTimer.create;
+ mfTimer:=tTimer.create;
+ mmTimer:=tTimer.create;
+ famTimer:=tTimer.create;
+ {$ENDIF}
+ ParameterLaenge:=0;
+end;
+
+destructor TMetaData.destroy;
+var
+ i: longint;
+begin
+ for i:=0 to length(MMInteraktionen)-1 do
+ MMInteraktionen[i].free;
+ setlength(MMInteraktionen,0);
+ for i:=0 to length(MFInteraktionen)-1 do
+ MFInteraktionen[i].free;
+ setlength(MFInteraktionen,0);
+ for i:=0 to length(FFInteraktionen)-1 do
+ FFInteraktionen[i].free;
+ setlength(FFInteraktionen,0);
+ for i:=0 to length(Verknuepfungen)-1 do
+ Verknuepfungen[i].free;
+ setlength(Verknuepfungen,0);
+ for i:=0 to length(Ereignisse)-1 do
+ Ereignisse[i].free;
+ setlength(Ereignisse,0);
+ for i:=0 to length(Personen)-1 do
+ Personen[i].free;
+ setlength(Personen,0);
+ for i:=0 to length(Familien)-1 do
+ Familien[i].free;
+ setlength(Familien,0);
+ setlength(Tauschfamilien,0);
+ setlength(ParameterAttribute,0);
+ Sicherung.free;
+ setlength(Laubhaufen,0);
+ setlength(personAuchDrueber,0);
+ setlength(familieAuchDrueber,0);
+ {$IFDEF detaillierteZeitanalyse}
+ abvTimer.free;
+ ffTimer.free;
+ mfTimer.free;
+ mmTimer.free;
+ famTimer.free;
+ {$ENDIF}
+ inherited destroy;
+end;
+
+procedure TMetaData.init(md: tMetaData);
+var
+ i,j: longint;
+ c: char;
+begin
+ md.konsistenzTest(true);
+
+ ParameterLaenge:=md.ParameterLaenge;
+ setlength(ParameterAttribute,length(md.ParameterAttribute));
+ for i:=0 to length(ParameterAttribute)-1 do
+ ParameterAttribute[i]:=md.ParameterAttribute[i];
+
+ setlength(Ereignisse,length(md.Ereignisse));
+ for i:=0 to length(Ereignisse)-1 do begin
+ Ereignisse[i]:=tEreignis.create;
+ Ereignisse[i].init(md.Ereignisse[i]);
+ end;
+
+ setlength(Personen,length(md.Personen));
+ setlength(personAuchDrueber,length(Personen));
+ for i:=0 to length(Personen)-1 do begin
+ Personen[i]:=tPerson.create;
+ Personen[i].init(md.Personen[i],Ereignisse,Familien,false);
+ personAuchDrueber[i]:=true;
+ end;
+
+ setlength(Familien,length(md.Familien));
+ setlength(familieAuchDrueber,length(Familien));
+ for i:=0 to length(Familien)-1 do begin
+ Familien[i]:=tFamilie.create;
+ Familien[i].init(md.Familien[i],Ereignisse,Personen,false);
+ familieAuchDrueber[i]:=true;
+ end;
+
+ setlength(Verknuepfungen,length(md.Verknuepfungen));
+ for i:=0 to length(Verknuepfungen)-1 do begin
+ Verknuepfungen[i]:=tVerknuepfung.create;
+ Verknuepfungen[i].outP:=Personen[md.Verknuepfungen[i].outP.index];
+ Verknuepfungen[i].Lambda:=md.Verknuepfungen[i].Lambda;
+ for c:='x' to 'y' do begin
+ Verknuepfungen[i].Output[c]:=md.Verknuepfungen[i].Output[c];
+ for j:=0 to 1 do
+ Verknuepfungen[i].Input[j,c]:=md.Verknuepfungen[i].Input[j,c];
+ end;
+ Verknuepfungen[i].index:=i;
+ end;
+
+ setlength(MMInteraktionen,length(md.MMInteraktionen));
+ for i:=0 to length(MMInteraktionen)-1 do begin
+ MMInteraktionen[i]:=tMMInteraktion.create;
+ MMInteraktionen[i].Laenge:=md.MMInteraktionen[i].Laenge;
+ for j:=0 to 1 do
+ MMInteraktionen[i]._Ps[j]:=Personen[md.MMInteraktionen[i]._Ps[j].index];
+ MMInteraktionen[i].index:=i;
+ end;
+
+ setlength(MFInteraktionen,length(md.MFInteraktionen));
+ for i:=0 to length(MFInteraktionen)-1 do begin
+ MFInteraktionen[i]:=tMFInteraktion.create;
+ MFInteraktionen[i].Laenge:=md.MFInteraktionen[i].Laenge;
+ MFInteraktionen[i]._F:=Familien[md.MFInteraktionen[i]._F.index];
+ MFInteraktionen[i]._P:=Personen[md.MFInteraktionen[i]._P.index];
+ MFInteraktionen[i].index:=i;
+ end;
+
+ setlength(FFInteraktionen,length(md.FFInteraktionen));
+ for i:=0 to length(FFInteraktionen)-1 do begin
+ FFInteraktionen[i]:=tFFInteraktion.create;
+ for j:=0 to 1 do
+ FFInteraktionen[i]._Fs[j]:=Familien[md.FFInteraktionen[i]._Fs[j].index];
+ FFInteraktionen[i].index:=i;
+ end;
+
+ setlength(Tauschfamilien,length(md.Tauschfamilien));
+ for i:=0 to length(Tauschfamilien)-1 do
+ Tauschfamilien[i]:=Familien[md.Tauschfamilien[i].index];
+
+ konsistenzTest(true);
+end;
+
+procedure TMetaData.printStatus(Level: Longint);
+var
+ I,J,K,L,M: Longint;
+ ea: TEreignisart;
+begin writeln('printstatus('+inttostr(level)+')');
+ case Level of
+ 0: begin
+ J:=0;
+ K:=0;
+ L:=0;
+ M:=0;
+ for I:=0 to length(Personen)-1 do
+ for ea:=low(TEreignisart) to high(TEreignisart) do begin
+ J:=J+Byte(assigned(Personen[I].Ereignisse[ea]));
+ K:=K+Byte(assigned(Personen[I].Ereignisse[ea]) and not Personen[I].Ereignisse[ea].istDummy);
+ end;
+ for I:=0 to length(Familien)-1 do begin
+ L:=L+Byte(assigned(Familien[I].Anfang));
+ M:=M+Byte(assigned(Familien[I].Anfang) and not Familien[I].Anfang.istDummy);
+ end;
+ writeln(inttostr(Level)+') '+inttostr(length(Ereignisse))+' Ereignisse');
+ writeln(inttostr(Level)+') '+inttostr(K)+'/'+inttostr(J)+'<-'+inttostr(length(Personen))+' Personen');
+ writeln(inttostr(Level)+') '+inttostr(M)+'/'+inttostr(L)+'<-'+inttostr(length(Familien))+' Familien');
+ end;
+ 1: begin
+ J:=0;
+ K:=0;
+ L:=0;
+ for I:=0 to length(Personen)-1 do begin
+ J:=J+Byte(not Personen[I].Anfang.istDummy);
+ K:=K+Byte(not Personen[I].Ende.istDummy);
+ end;
+ for I:=0 to length(Familien)-1 do
+ L:=L+Byte(not Familien[I].Anfang.istDummy);
+ writeln(inttostr(Level)+') '+inttostr(J)+'/'+inttostr(K)+'/'+inttostr(length(Personen))+' Personen');
+ writeln(inttostr(Level)+') '+inttostr(L)+'/'+inttostr(length(Familien))+' Familien');
+ end;
+ 2,3: begin
+ K:=4096;//Familien[0].Anfang.Jahr-Familien[0].Eltern[0].Anfang.Jahr;
+ L:=-K;
+ for i:=0 to length(Familien)-1 do
+ if not Familien[i].Anfang.istDummy then
+ for j:=0 to 1 do
+ if assigned(Familien[I].Eltern[J]) and
+ not Familien[I].Eltern[J].Anfang.istDummy then begin
+ K:=min(K,Familien[I].Anfang.Jahr-Familien[I].Eltern[J].Anfang.Jahr);
+ L:=max(L,Familien[I].Anfang.Jahr-Familien[I].Eltern[J].Anfang.Jahr);
+ end;
+ writeln(inttostr(Level)+') '+inttostr(K)+' <= Hochzeitsalter <= '+inttostr(L));
+ if Level=2 then exit;
+ for i:=0 to length(Familien)-1 do
+ if not Familien[i].Anfang.istDummy then
+ for j:=0 to 1 do
+ if assigned(Familien[I].Eltern[J]) and
+ not Familien[I].Eltern[J].Anfang.istDummy then begin
+ if K=Familien[I].Anfang.Jahr-Familien[I].Eltern[J].Anfang.Jahr then begin
+ writeln(
+ inttostr(Level)+') Minimalist:');
+ writeln(
+ ' '+Familien[I].Eltern[J].Vorname+' '+
+ Familien[I].Eltern[J].Nachname+' (G:'+
+ inttostr(Familien[I].Eltern[J].Anfang.Jahr)+' H:'+
+ inttostr(Familien[I].Anfang.Jahr)+' ['+
+ inttostr(byte(Familien[I].Anfang.Art))+']) in Familie '+inttostr(I));
+ if assigned(Familien[i].Eltern[1-j]) then
+ writeln(
+ ' mit '+Familien[I].Eltern[1-j].Vorname+' '+
+ Familien[I].Eltern[1-j].Nachname+' (G:'+
+ inttostr(Familien[I].Eltern[1-j].Anfang.Jahr)+' H:'+
+ inttostr(Familien[I].Anfang.Jahr)+' ['+
+ inttostr(byte(Familien[I].Anfang.Art))+']) in Familie '+inttostr(I));
+// writeln(' '+(Familien[I].Eltern[J])+' in Familie '+tFamilieToStr(Familien[I]));
+ end;
+ if L=Familien[I].Anfang.Jahr-Familien[I].Eltern[J].Anfang.Jahr then begin
+ writeln(
+ inttostr(Level)+') Maximalist:');
+ writeln(
+ ' '+Familien[I].Eltern[J].Vorname+' '+
+ Familien[I].Eltern[J].Nachname+' (G:'+
+ inttostr(Familien[I].Eltern[J].Anfang.Jahr)+' H:'+
+ inttostr(Familien[I].Anfang.Jahr)+' ['+
+ inttostr(byte(Familien[I].Anfang.Art))+']) in Familie '+inttostr(I));
+ if assigned(Familien[i].Eltern[1-j]) then
+ writeln(
+ ' mit '+Familien[I].Eltern[1-j].Vorname+' '+
+ Familien[I].Eltern[1-j].Nachname+' (G:'+
+ inttostr(Familien[I].Eltern[1-j].Anfang.Jahr)+' H:'+
+ inttostr(Familien[I].Anfang.Jahr)+' ['+
+ inttostr(byte(Familien[I].Anfang.Art))+']) in Familie '+inttostr(I));
+// writeln(' '+tPersonToStr(Familien[I].Eltern[J])+' in Familie '+tFamilieToStr(Familien[I]));
+ end;
+ end;
+ end;
+ 4: begin
+ writeln(inttostr(Level)+') '+inttostr(anzUnabhaengig)+' unabhängige Variable');
+ writeln(inttostr(Level)+') '+inttostr(ParameterLaenge)+' Variable insgesamt');
+ writeln(inttostr(Level)+') '+inttostr(length(Verknuepfungen))+' Verknuepfungen');
+ writeln(inttostr(Level)+') '+inttostr(length(MMInteraktionen))+' Mensch-Mensch-Wechselwirkungen');
+ writeln(inttostr(Level)+') '+inttostr(length(MFInteraktionen))+' Mensch-Familie-Wechselwirkungen');
+ writeln(inttostr(Level)+') '+inttostr(length(FFInteraktionen))+' Familie-Familie-Wechselwirkungen');
+ writeln(inttostr(Level)+') '+inttostr(length(Tauschfamilien))+' Familien mit >= 2 Kindern');
+ end;
+ else
+ writeln('Illegales Argument für Funktionsaufruf von TMetaData.printStatus!');
+ end{of case};
+end;
+
+{$IFDEF detaillierteZeitanalyse}
+procedure TMetaData.printTimer(prefix: string);
+begin
+ writeln(prefix+'Abv: '+mytimetostr(abvTimer.gibZeit)+' (avg. '+myfloattostr(abvTimer.gibZeitMittel*24*60*60)+' s)');
+ writeln(prefix+'MM: '+mytimetostr(mmTimer.gibZeit)+' (avg. '+myfloattostr(mmTimer.gibZeitMittel*24*60*60)+' s)');
+ writeln(prefix+'MF: '+mytimetostr(mfTimer.gibZeit)+' (avg. '+myfloattostr(mfTimer.gibZeitMittel*24*60*60)+' s)');
+ writeln(prefix+'FF: '+mytimetostr(ffTimer.gibZeit)+' (avg. '+myfloattostr(ffTimer.gibZeitMittel*24*60*60)+' s)');
+ writeln(prefix+'Fam: '+mytimetostr(famTimer.gibZeit)+' (avg. '+myfloattostr(famTimer.gibZeitMittel*24*60*60)+' s)');
+end;
+{$ENDIF}
+
+procedure TMetaData.berechneAbhaengigeVariable(var P: TExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+var
+ i: Longint;
+ c: Char;
+begin
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then abvTimer.start;
+ {$ENDIF}
+ for i:=0 to length(Verknuepfungen)-1 do
+ for c:='x' to 'y' do
+ P[Verknuepfungen[i].Output[c]]:=
+ P[Verknuepfungen[i].Input[0,c]]*(1-P[Verknuepfungen[i].Lambda]) +
+ P[Verknuepfungen[i].Input[1,c]]*P[Verknuepfungen[i].Lambda];
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then abvTimer.stop;
+ {$ENDIF}
+end;
+
+procedure TMetaData.GradientenRueckPropagation(P: tExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}; var grad: tExtendedArray);
+var
+ i: Longint;
+ c: Char;
+begin
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then abvTimer.start;
+ {$ENDIF}
+ for i:=length(Verknuepfungen)-1 downto 0 do
+ for c:='x' to 'y' do begin
+ grad[Verknuepfungen[i].Input[0,c]]:=
+ grad[Verknuepfungen[i].Input[0,c]] + (1-P[Verknuepfungen[i].Lambda])*grad[Verknuepfungen[i].Output[c]];
+ grad[Verknuepfungen[i].Input[1,c]]:=
+ grad[Verknuepfungen[i].Input[1,c]] + P[Verknuepfungen[i].Lambda]*grad[Verknuepfungen[i].Output[c]];
+ grad[Verknuepfungen[i].Lambda]:=
+ grad[Verknuepfungen[i].Lambda]
+ + (P[Verknuepfungen[i].Input[1,c]] - P[Verknuepfungen[i].Input[0,c]])*grad[Verknuepfungen[i].Output[c]];
+
+// P[Verknuepfungen[i].Output[c]]:=
+// P[Verknuepfungen[i].Input[0,c]]*(1-P[Verknuepfungen[i].Lambda]) +
+// P[Verknuepfungen[i].Input[1,c]]*P[Verknuepfungen[i].Lambda];
+ end;
+ {$IFDEF detaillierteZeitanalyse}
+ if mainThread then abvTimer.stop;
+ {$ENDIF}
+end;
+
+function TMetaData.Energie(P: TExtendedArray; out Kreuzungen, Kreuzung: Longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}): extended;
+{$DEFINE Energie}
+{$I energiefunktion.inc}
+{$UNDEF Energie}
+
+procedure TMetaData.Gradient(P: TExtendedArray{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF}; var Grad: tExtendedArray);
+{$DEFINE Gradient}
+{$I energiefunktion.inc}
+{$UNDEF Gradient}
+
+(*
+function TMetaData.findeNaechstesAbhaengiges(Fam: tFamilie; out wo: longint; out Pers: tPerson): Boolean;
+var
+ I,J,W: Longint;
+ P: tPerson;
+begin
+ if not assigned(Fam) then begin
+ result:=false;
+ wo:=-1;
+ Pers:=nil;
+ exit;
+ end;
+ for I:=0 to 1 do
+ if assigned(Fam.Eltern[I].KindIn) and
+ Fam.Eltern[I].KindIn.abhaengig then begin
+ Pers:=Fam.Eltern[I];
+ wo:=0;
+ result:=true;
+ exit;
+ end;
+ result:=false;
+ wo:=-1;
+ W:=-1;
+ Pers:=nil;
+ for I:=0 to length(Fam.Kinder)-1 do
+ for J:=0 to length(Fam.Kinder[I].ElterIn)-1 do
+ if findeNaechstesAbhaengiges(Fam.Kinder[I].ElterIn[J],W,P) then begin
+ result:=true;
+ if (wo=-1) or (W+1<wo) or ((W+1=wo) and (random<0.5)) then begin
+ Pers:=P;
+ wo:=W+1;
+ end;
+ end;
+end;
+*)
+function TMetaData.ladeXML(Datei: string): boolean;
+var
+ f: tMyStringlist;
+ s: ansistring;
+ Ebene,UEbene,i,j,k,l: longint;
+ Speichern,gefunden: boolean;
+ neuEreignis: tEreignis;
+ neuPerson: tPerson;
+ neuFamilie: tFamilie;
+ duplikatKind: array of tPerson;
+ duplikatFamilie: array of tFamilie;
+begin
+ result:=false;
+ writeln(Datei+' einlesen ...');
+ f:=tMyStringlist.create;
+ if rightStr(Datei,4)='.xml' then
+ f.loadFromFile(Datei)
+ else if rightStr(Datei,7)='.gramps' then
+ f.loadFromGz(Datei)
+ else begin
+ f.free;
+ exit;
+ end;
+
+ neuEreignis:=nil;
+ neuPerson:=nil;
+ neuFamilie:=nil;
+
+ Setlength(Ereignisse,0);
+ Setlength(Personen,0);
+ Setlength(Familien,0);
+
+ writeln('... verarbeiten ...');
+
+ setlength(duplikatKind,0);
+ setlength(duplikatFamilie,0);
+
+ Ebene:=0;
+ for i:=0 to f.count-1 do begin
+ s:=f[i];
+ case Ebene of
+ 0: begin
+ if leftStr(S,9)='<database' then
+ inc(Ebene);
+ continue;
+ end;
+ 1: begin
+ if S='</database>' then begin
+ dec(Ebene);
+ break;
+ end;
+ if S='<events>' then begin
+ inc(Ebene);
+ UEbene:=0;
+ continue;
+ end;
+ if leftStr(S,7)='<people' then begin
+ inc(Ebene);
+ UEbene:=1;
+ continue;
+ end;
+ if S='<families>' then begin
+ inc(Ebene);
+ UEbene:=2;
+ continue;
+ end;
+ end;
+ 2: begin
+ case UEbene of
+ 0: begin
+ if S='</events>' then begin
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,6)='<event' then begin
+ delete(S,1,pos('handle="',S)+7);
+ neuEreignis:=findeEreignis(Ereignisse,leftStr(S,pos('"',S)-1));
+ Speichern:=true;
+ inc(Ebene);
+ end;
+ end;
+ 1: begin
+ if S='</people>' then begin
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,7)='<person' then begin
+ delete(S,1,pos('handle="',S)+7);
+ neuPerson:=findePerson(Personen,leftStr(S,pos('"',S)-1));
+ Speichern:=true;
+ inc(Ebene);
+ end;
+ end;
+ 2: begin
+ if S='</families>' then begin
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,7)='<family' then begin
+ delete(S,1,pos('handle="',S)+7);
+ neufamilie:=findeFamilie(Familien,leftStr(S,pos('"',S)-1));
+ Speichern:=true;
+ inc(Ebene);
+ end;
+ end;
+ end{of Case};
+ end;
+ 3: begin
+ if (leftStr(s,11)='<attribute ') or (s='</attribute>') or
+ (leftStr(s,8)='<objref ') or (leftStr(s,13)='<citationref ') or
+ (s='</objref>') or (leftStr(s,9)='<noteref ') or
+ (leftStr(s,7)='<place ') or (leftStr(s,12)='<description') then
+ continue;
+ case UEbene of
+ 0: begin
+ if S='</event>' then begin
+ if not (Speichern and ((neuEreignis.Jahr<>0) or (neuEreignis.Art=eaHochzeit))) then
+ loescheEreignis(Ereignisse,neuEreignis.ID);
+ neuEreignis:=nil;
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,6)='<type>' then begin
+ delete(S,1,6);
+ S:=leftStr(S,pos('</type>',S)-1);
+ if (S='Jugendweihe') or (S='Confirmation') or (S='Engagement') or
+ (S='Flucht') or (S='Divorce') or (S='Military Service') or
+ (S='Medical Information') or (S='Education') or (S='Unknown') or
+ (S='Cremation') or (S='Residence') or (S='Graduation') or (S='Emigration') then begin
+ Speichern:=false;
+ Continue;
+ end;
+ if (S='Birth') or (S='Geburt') then begin
+ neuEreignis.Art:=eaGeburt;
+ Continue;
+ end;
+ if S='Christening' then begin
+ neuEreignis.Art:=eaTaufe;
+ Continue;
+ end;
+ if S='Marriage' then begin
+ neuEreignis.Art:=eaHochzeit;
+ Continue;
+ end;
+ if S='Death' then begin
+ neuEreignis.Art:=eaTod;
+ Continue;
+ end;
+ if (S='Burial') or (S='Vermißt') then begin
+ neuEreignis.Art:=eaBeerdigung;
+ Continue;
+ end;
+ writeln('Eventtyp: '+s);
+ continue;
+ end;
+ if leftStr(S,9)='<dateval ' then begin
+ delete(S,1,pos('val="',S)+4);
+ if (S[1] in ['0'..'9']) and
+ (S[2] in ['0'..'9']) and
+ (S[3] in ['0'..'9']) and
+ (S[4] in ['0'..'9']) then
+ neuEreignis.Jahr:=strtoint(copy(S,1,4))
+ else
+ neuEreignis.Jahr:=0;
+ continue;
+ end;
+ if leftStr(s,9)='<datestr ' then
+ continue;
+ writeln('Event: '+s);
+ end;
+ 1: begin
+ if S='</person>' then begin
+ if not Speichern then
+ loeschePerson(Personen,neuPerson.ID);
+ neuPerson:=nil;
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,10)='<eventref ' then begin
+ delete(S,1,pos('hlink="',S)+6);
+ S:=leftStr(S,pos('"',S)-1);
+ neuEreignis:=findeEreignis(Ereignisse,S);
+ neuPerson.Ereignisse[neuEreignis.Art]:=neuEreignis;
+ neuEreignis:=nil;
+ continue;
+ end;
+ if leftstr(S,7)='<first>' then begin
+ delete(S,1,pos('>',S));
+ NeuPerson.Vorname:=copy(S,1,pos('</first>',S)-1);
+ continue;
+ end;
+ if leftstr(S,9)='<surname>' then begin
+ delete(S,1,pos('>',S));
+ NeuPerson.Nachname:=copy(S,1,pos('</surname>',S)-1);
+ continue;
+ end;
+ if leftstr(S,17)='<parentin hlink="' then begin
+ delete(S,1,pos('"',S));
+ neuFamilie:=findeFamilie(Familien,leftStr(s,pos('"',s)-1));
+ mergeFamilie(neuPerson.elterIn,neuFamilie);
+ neuFamilie:=nil;
+ continue;
+ end;
+ if (leftStr(s,16)='<childof hlink="') then begin
+ delete(S,1,pos('"',S));
+ if assigned(neuPerson.KindIn) then begin
+ setlength(duplikatKind,length(duplikatKind)+1);
+ duplikatKind[length(duplikatKind)-1]:=neuPerson;
+ setlength(duplikatFamilie,length(duplikatFamilie)+1);
+ duplikatFamilie[length(duplikatFamilie)-1]:=neuPerson.KindIn;
+ end;
+ neuPerson.KindIn:=findeFamilie(Familien,leftStr(s,pos('"',s)-1));
+ continue;
+ end;
+ if (leftStr(s,9)='<country>') or (leftStr(s,8)='<gender>') or
+ (leftStr(s,6)='<name ') or (s='</name>') or (leftStr(s,8)='<region ') or
+ (leftStr(s,6)='<nick>') or (s='<address>') or (s='</address>') or
+ (leftStr(s,6)='<city>') or (leftStr(s,12)='<familynick>') or
+ (leftStr(s,8)='<street>') or (leftStr(s,7)='<title>') or
+ (leftStr(s,6)='<call>') or (leftStr(s,9)='<dateval ') or
+ (leftStr(s,8)='<postal>') or (leftStr(s,7)='<state>') then
+ continue;
+ writeln('Person: '+s);
+ end;
+ 2: begin
+ if S='</family>' then begin
+ if not Speichern then
+ loescheFamilie(Familien,neuFamilie.ID);
+ neuFamilie:=nil;
+ dec(Ebene);
+ continue;
+ end;
+ if leftStr(S,5)='<rel ' then begin
+ delete(S,1,pos('type="',S)+5);
+ S:=leftStr(S,pos('"',S)-1);
+ if S='Married' then begin
+ NeuFamilie.verheiratet:=true;
+ continue;
+ end;
+ if (S='Unmarried') or (S='Unknown') then begin
+ neuFamilie.verheiratet:=false;
+ continue;
+ end;
+ writeln('Familienrelation: '+s);
+ continue;
+ end;
+ if leftStr(S,8)='<father ' then begin
+ delete(S,1,pos('hlink="',S)+6);
+ S:=leftstr(S,pos('"',S)-1);
+ neuFamilie.Eltern[0]:=findePerson(Personen,S);
+ continue;
+ end;
+ if leftStr(S,8)='<mother ' then begin
+ delete(S,1,pos('hlink="',S)+6);
+ S:=leftstr(S,pos('"',S)-1);
+ neuFamilie.Eltern[1]:=findePerson(Personen,S);
+ continue;
+ end;
+ if leftStr(S,10)='<eventref ' then begin
+ delete(S,1,pos('hlink="',S)+6);
+ S:=leftstr(S,pos('"',S)-1);
+ neuEreignis:=findeEreignis(Ereignisse,S);
+ if (neuEreignis.Art=eaHochzeit) and
+ ((not assigned(NeuFamilie.Anfang)) or
+ (NeuFamilie.Anfang.Jahr > neuEreignis.Jahr)) then
+ neuFamilie.Anfang:=neuEreignis;
+ neuEreignis:=nil;
+ continue;
+ end;
+ if leftStr(S,10)='<childref ' then begin
+ delete(S,1,pos('hlink="',S)+6);
+ S:=leftstr(S,pos('"',S)-1);
+ Setlength(NeuFamilie.Kinder,length(NeuFamilie.Kinder)+1);
+ NeuFamilie.Kinder[length(NeuFamilie.Kinder)-1]:=findePerson(Personen,S);
+ continue;
+ end;
+ if (s='</childref>') then
+ continue;
+ writeln('Familie: '+s);
+ end;
+ end{of Case};
+ end;
+ end{of case};
+ end;
+ f.free;
+ result:=Ebene=0;
+ if not result then begin
+ writeln('Korrupte .xml-Datei!');
+ exit;
+ end;
+
+ if length(duplikatKind)>0 then begin
+ writeln('*** Warnung ***');
+ writeln(inttostr(length(duplikatKind)),' Kind-Familien-Beziehungen waren redundant, ich suche mir jetzt die zu den größten Familien aus!');
+ for i:=0 to length(duplikatKind)-1 do begin
+ gefunden:=false;
+ for j:=0 to i-1 do
+ if duplikatKind[i]=duplikatKind[j] then begin
+ gefunden:=true;
+ break;
+ end;
+ if gefunden then continue;
+
+ k:=-1;
+ l:=length(duplikatKind[i].KindIn.Kinder);
+ for j:=0 to length(duplikatKind)-1 do
+ if duplikatKind[j]=duplikatKind[i] then begin
+ if length(duplikatFamilie[j].Kinder)>l then begin
+ k:=j;
+ l:=length(duplikatFamilie[j].Kinder);
+ end;
+ end;
+ if l>=0 then begin
+ duplikatKind[i].KindIn.entferneKind(duplikatKind[i]);
+ duplikatKind[i].KindIn:=duplikatFamilie[k];
+ end;
+ end;
+ setlength(duplikatKind,0);
+ setlength(duplikatFamilie,0);
+ end;
+
+ konsistenzTest(false);
+ writeln('... fertig:');
+end;
+
+procedure TMetaData.generiereFehlendeInfos;
+var
+ i,j: Longint;
+ dummyEreignis: tEreignis;
+ timeout: extended;
+ gefunden: boolean;
+begin
+ writeln('aufhübschen ...');
+ for i:=0 to length(Familien)-1 do
+ for j:=0 to 1 do
+ if not assigned(Familien[i].Eltern[j]) then begin
+ Familien[i].Eltern[j]:=tPerson.create;
+ Familien[i].Eltern[j].ID:=Familien[i].ID+'_automatischer_Elter'+inttostr(j);
+ setlength(Familien[i].Eltern[j].ElterIn,1);
+ Familien[i].Eltern[j].ElterIn[0]:=Familien[i];
+ setlength(Personen,length(Personen)+1);
+ Personen[length(Personen)-1]:=Familien[i].Eltern[j];
+ end;
+ dummyEreignis:=tEreignis.create;
+ dummyEreignis.ID:='<<42-DUMMY-42>>';
+ dummyEreignis.Jahr:=0;
+ dummyEreignis.Art:=eaDummy;
+ setlength(Ereignisse,length(Ereignisse)+1);
+ Ereignisse[length(Ereignisse)-1]:=dummyEreignis;
+ for I:=0 to length(Familien)-1 do
+ if not assigned(Familien[I].Anfang) then
+ Familien[I].Anfang:=dummyEreignis;
+ for I:=0 to length(Personen)-1 do begin
+ if assigned(Personen[I].Ereignisse[eaGeburt]) and not Personen[I].Ereignisse[eaGeburt].istDummy then
+ Personen[I].Anfang:=Personen[I].Ereignisse[eaGeburt]
+ else if assigned(Personen[I].Ereignisse[eaTaufe]) and not Personen[I].Ereignisse[eaTaufe].istDummy then
+ Personen[I].Anfang:=Personen[I].Ereignisse[eaTaufe]
+ else
+ Personen[I].Anfang:=dummyEreignis;
+ if assigned(Personen[I].Ereignisse[eaTod]) and not Personen[I].Ereignisse[eaTod].istDummy then
+ Personen[I].Ende:=Personen[I].Ereignisse[eaTod]
+ else if assigned(Personen[I].Ereignisse[eaBeerdigung]) and not Personen[I].Ereignisse[eaBeerdigung].istDummy then
+ Personen[I].Ende:=Personen[I].Ereignisse[eaBeerdigung]
+ else Personen[I].Ende:=dummyEreignis;
+ Personen[I].P1:=-1;
+ Personen[I].P2:=-1;
+ Personen[I].P3:=-1;
+ end;
+ printStatus(1);
+ timeout:=now+1/24/60/60*3;
+ repeat
+ gefunden:=false;
+ for I:=0 to length(Personen)-1 do // Todesdatum aus Geburtsdatum
+ if Personen[i].Ende.istDummy and
+ not Personen[i].Anfang.istDummy then begin
+ setlength(Ereignisse,length(Ereignisse)+1);
+ Ereignisse[length(Ereignisse)-1]:=tEreignis.create;
+ Ereignisse[length(Ereignisse)-1].Art:=eaSonstiges;
+ Ereignisse[length(Ereignisse)-1].Jahr:=min(Personen[I].Anfang.Jahr+StandardLebensdauer,aktuellesJahr);
+ Ereignisse[length(Ereignisse)-1].ID:=Personen[I].ID+'_automatischer_Tod';
+ Personen[I].Ende:=Ereignisse[length(Ereignisse)-1];
+ gefunden:=true;
+ end;
+ if gefunden then continue;
+ for I:=0 to length(Familien)-1 do // Hochzeitsdatum aus Geburtsdatum der Kinder
+ if Familien[I].Anfang.istDummy and (not gefunden) and
+ (length(Familien[I].Kinder)>0) then
+ for J:=0 to length(Familien[I].Kinder)-1 do
+ if (not Familien[I].Kinder[J].Anfang.istDummy) and
+ (Familien[I].Anfang.istDummy or
+ (Familien[I].Kinder[J].Anfang.Jahr<=Familien[I].Anfang.Jahr)) then begin
+ Familien[I].Anfang:=Familien[I].Kinder[J].Anfang;
+ gefunden:=true;
+ end;
+ if gefunden then continue;
+ for I:=0 to length(Familien)-1 do // Hochzeitsdatum aus Geburtsdatum der Eltern
+ if Familien[I].Anfang.istDummy and not gefunden then begin
+ for J:=0 to 1 do
+ if assigned(Familien[I].Eltern[J]) and (not Familien[I].Eltern[J].Anfang.istDummy) and
+ (Familien[I].Anfang.istDummy or (Familien[I].Eltern[J].Anfang.Jahr>=Familien[I].Anfang.Jahr)) then begin
+ Familien[I].Anfang:=Familien[I].Eltern[J].Anfang;
+ gefunden:=true;
+ end;
+ if gefunden then begin
+ setlength(Ereignisse,length(Ereignisse)+1);
+ Ereignisse[length(Ereignisse)-1]:=tEreignis.create;
+ Ereignisse[length(Ereignisse)-1].ID:=Familien[i].ID+'_automatische_Hochzeit';
+ Ereignisse[length(Ereignisse)-1].Jahr:=min(Familien[i].Anfang.Jahr+StandardHochzeitsalter,aktuellesJahr);
+ Ereignisse[length(Ereignisse)-1].Art:=eaSonstiges;
+ Familien[i].Anfang:=Ereignisse[length(Ereignisse)-1];
+ break;
+ end;
+ end;
+ if gefunden then continue;
+ for I:=0 to length(Personen)-1 do // Geburtsdatum aus Hochzeitsdatum der Eltern
+ if Personen[I].Anfang.istDummy and
+ assigned(Personen[I].KindIn) and
+ not Personen[I].KindIn.Anfang.istDummy then begin
+ Personen[I].Anfang:=Personen[I].KindIn.Anfang;
+ gefunden:=true;
+ break;
+ end;
+ if gefunden then continue;
+ for I:=0 to length(Personen)-1 do // Geburtsdatum aus eigenen Hochzeitsdaten
+ if Personen[I].Anfang.istDummy then begin
+ for J:=0 to length(Personen[I].ElterIn)-1 do
+ if (not Personen[I].ElterIn[J].Anfang.istDummy) and
+ (Personen[I].Anfang.istDummy or
+ (Personen[I].Anfang.Jahr > Personen[I].ElterIn[J].Anfang.Jahr)) then
+ Personen[I].Anfang:=Personen[I].ElterIn[J].Anfang;
+ if not Personen[I].Anfang.istDummy then begin
+ setlength(Ereignisse,length(Ereignisse)+1);
+ Ereignisse[length(Ereignisse)-1]:=TEreignis.create;
+ Ereignisse[length(Ereignisse)-1].Art:=eaSonstiges;
+ Ereignisse[length(Ereignisse)-1].Jahr:=Personen[I].Anfang.Jahr-Standardhochzeitsalter;
+ Ereignisse[length(Ereignisse)-1].ID:=Personen[I].ID+'_automatische_Geburt';
+ Personen[I].Anfang:=Ereignisse[length(Ereignisse)-1];
+ gefunden:=true;
+ break;
+ end;
+ end;
+ if gefunden then continue;
+ for I:=0 to length(Personen)-1 do // Geburtsdatum aus Todesdatum
+ if Personen[I].Anfang.istDummy and
+ not Personen[I].Ende.istDummy then begin
+ setlength(Ereignisse,length(Ereignisse)+1);
+ Ereignisse[length(Ereignisse)-1]:=tEreignis.create;
+ Ereignisse[length(Ereignisse)-1].Art:=eaSonstiges;
+ Ereignisse[length(Ereignisse)-1].Jahr:=Personen[I].Ende.Jahr-StandardLebensdauer;
+ Ereignisse[length(Ereignisse)-1].ID:=Personen[I].ID+'_automatische_Geburt';
+ Personen[I].Anfang:=Ereignisse[length(Ereignisse)-1];
+ gefunden:=true;
+ break;
+ end;
+ until (not gefunden) or (now>=timeout);
+ if gefunden then begin
+ writeln('Zeitüberschreitung erreicht!');
+ halt(1);
+ end;
+
+ gefunden:=false;
+ for i:=0 to length(Personen)-1 do
+ if Personen[i].Anfang.istDummy or Personen[i].Ende.istDummy then begin
+ gefunden:=true;
+ write('*** Warnung *** Dummy gefunden! (');
+ if Personen[i].Anfang.istDummy then write('Geburt');
+ if Personen[i].Ende.istDummy then begin
+ if Personen[i].Anfang.istDummy then write(', ');
+ write('Tod');
+ end;
+ writeln(') '+Personen[i].ID+' '+Personen[i].Vorname+' '+Personen[i].Nachname);
+ if assigned(Personen[i].KindIn) then
+ writeln(' '+inttostr(byte(Personen[i].KindIn.Anfang.istDummy))+' '+inttostr(integer(Personen[i].KindIn.Anfang.Art))+' '+inttostr(Personen[i].KindIn.Anfang.Jahr));
+ writeln(' '+inttostr(length(Personen[i].ElterIn)));
+ for j:=0 to length(Personen[i].ElterIn)-1 do
+ writeln(' '+inttostr(byte(Personen[i].ElterIn[j].Anfang.istDummy))+' '+inttostr(integer(Personen[i].ElterIn[j].Anfang.Art))+' '+inttostr(Personen[i].ElterIn[j].Anfang.Jahr));
+ end;
+ for i:=0 to length(Familien)-1 do
+ if Familien[i].Anfang.istDummy then begin
+ gefunden:=true;
+ writeln('*** Warnung *** Dummy gefunden! (Hochzeit) '+Familien[i].ID);
+ if assigned(Familien[i].Eltern[0]) then writeln(' E '+inttostr(byte(Familien[i].Eltern[0].Anfang.istDummy))+' '+Familien[i].Eltern[0].Vorname+' '+Familien[i].Eltern[0].Nachname);
+ if assigned(Familien[i].Eltern[1]) then writeln(' E '+inttostr(byte(Familien[i].Eltern[0].Anfang.istDummy))+' '+Familien[i].Eltern[1].Vorname+' "'+Familien[i].Eltern[1].Nachname+'"');
+ for j:=0 to length(Familien[i].Kinder)-1 do
+ writeln(' '+inttostr(byte(Familien[i].Kinder[j].Anfang.istDummy))+' '+Familien[i].Kinder[j].Vorname+' '+Familien[i].Kinder[j].Nachname);
+ end;
+
+ if gefunden then halt(1);
+
+ for I:=0 to length(Personen)-1 do
+ if assigned(Personen[I].KindIn) and
+ (Personen[I].KindIn.Anfang.Jahr > Personen[I].Anfang.Jahr) then
+ Personen[I].KindIn.Anfang:=Personen[I].Anfang;
+
+ indizesErzeugen;
+ writeln('... fertig');
+end;
+
+function TMetaData.analysiereInteraktionen: boolean;
+var
+ i,j,k,l: longint;
+ speichern,
+ gefunden: boolean;
+ c: char;
+ Ps: tIntArray;
+ p: tPerson;
+begin
+ writeln('Verknüpfungen und Interaktionen analysieren ...');
+ ParameterLaenge:=0;
+ setlength(Verknuepfungen,0);
+ setlength(MMInteraktionen,0);
+ Setlength(MFInteraktionen,0);
+ setlength(FFInteraktionen,0);
+ setlength(ParameterAttribute,0);
+ for I:=0 to length(Personen)-1 do begin
+ if assigned(Personen[I].KindIn) then begin
+ Personen[I].P3:=ParameterLaenge;
+ if ParameterLaenge>=length(ParameterAttribute) then
+ setlength(ParameterAttribute,ParameterLaenge+1024);
+ ParameterAttribute[ParameterLaenge].istKoordinate:=false;
+ ParameterAttribute[ParameterLaenge].istUnabhaengig:=true;
+ inc(ParameterLaenge);
+ end
+ else begin
+ Personen[I].P1:=ParameterLaenge;
+ Personen[I].P2:=ParameterLaenge+1;
+ if ParameterLaenge>=length(ParameterAttribute)-1 then
+ setlength(ParameterAttribute,ParameterLaenge+1024);
+ ParameterAttribute[ParameterLaenge].istKoordinate:=true;
+ ParameterAttribute[ParameterLaenge].istUnabhaengig:=true;
+ ParameterAttribute[ParameterLaenge+1].istKoordinate:=true;
+ ParameterAttribute[ParameterLaenge+1].istUnabhaengig:=true;
+ ParameterLaenge:=ParameterLaenge+2;
+ end;
+ end;
+
+ repeat
+ gefunden:=false;
+ for I:=0 to length(Personen)-1 do
+ if (Personen[i].P1=-1) and
+ (Personen[i].KindIn.Eltern[0].P1<>-1) and
+ (Personen[i].KindIn.Eltern[1].P1<>-1) then begin
+ Setlength(Verknuepfungen,length(Verknuepfungen)+1);
+ Verknuepfungen[length(Verknuepfungen)-1]:=tVerknuepfung.create;
+ Verknuepfungen[length(Verknuepfungen)-1].outP:=Personen[I];
+ Verknuepfungen[length(Verknuepfungen)-1].Lambda:=Personen[I].P3;
+ for J:=0 to 1 do begin
+ Verknuepfungen[length(Verknuepfungen)-1].Input[J,'x']:=
+ Personen[I].KindIn.Eltern[J].P1;
+ Verknuepfungen[length(Verknuepfungen)-1].Input[J,'y']:=
+ Personen[I].KindIn.Eltern[J].P2;
+ end;
+ if ParameterLaenge>=length(ParameterAttribute)-1 then
+ setlength(ParameterAttribute,ParameterLaenge+1024);
+ ParameterAttribute[ParameterLaenge].istKoordinate:=true;
+ ParameterAttribute[ParameterLaenge].istUnabhaengig:=false;
+ ParameterAttribute[ParameterLaenge+1].istKoordinate:=true;
+ ParameterAttribute[ParameterLaenge+1].istUnabhaengig:=false;
+ Personen[i].P1:=ParameterLaenge;
+ Personen[i].P2:=ParameterLaenge+1;
+ ParameterLaenge:=ParameterLaenge+2;
+ Verknuepfungen[length(Verknuepfungen)-1].Output['x']:=Personen[I].P1;
+ Verknuepfungen[length(Verknuepfungen)-1].Output['y']:=Personen[I].P2;
+ gefunden:=true;
+ end;
+ until not gefunden;
+
+ setlength(ParameterAttribute,ParameterLaenge);
+
+ gefunden:=false;
+ for i:=0 to length(Personen)-1 do
+ if Personen[i].P1=-1 then begin
+ writeln(inttostr(i)+' '+Personen[i].Vorname+' '+Personen[i].Nachname);
+ gefunden:=true;
+ end;
+ if gefunden then begin
+ result:=false;
+ exit;
+ end;
+
+ setlength(Ps,ParameterLaenge);
+ for J:=0 to length(Ps)-1 do begin
+ ParameterAttribute[j].wirdBenutzt:=true;
+ Ps[J]:=Byte(ParameterAttribute[j].istUnabhaengig);
+ end;
+ for I:=0 to length(Verknuepfungen)-1 do begin
+ for J:=I to length(Verknuepfungen)-1 do begin
+ speichern:=Ps[Verknuepfungen[J].Lambda]=1;
+ for K:=0 to 1 do
+ for C:='x' to 'y' do
+ speichern:=speichern and
+ (Ps[Verknuepfungen[J].Input[K,C]]=1);
+ for C:='x' to 'y' do
+ speichern:=speichern and
+ (Ps[Verknuepfungen[J].Output[C]]=0);
+ if speichern then begin
+ for K:=0 to 1 do begin
+ for C:='x' to 'y' do begin
+ L:=Verknuepfungen[J].Input[K,C];
+ Verknuepfungen[J].Input[K,C]:=Verknuepfungen[I].Input[K,C];
+ Verknuepfungen[I].Input[K,C]:=L;
+ end;
+ end;
+ p:=Verknuepfungen[J].outP;
+ Verknuepfungen[J].outP:=Verknuepfungen[I].outP;
+ Verknuepfungen[I].outP:=p;
+ for C:='x' to 'y' do begin
+ L:=Verknuepfungen[J].Output[C];
+ Verknuepfungen[J].Output[C]:=Verknuepfungen[I].Output[C];
+ Verknuepfungen[I].Output[C]:=L;
+ end;
+ L:=Verknuepfungen[J].Lambda;
+ Verknuepfungen[J].Lambda:=Verknuepfungen[I].Lambda;
+ Verknuepfungen[I].Lambda:=L;
+ for C:='x' to 'y' do
+ Ps[Verknuepfungen[I].Output[C]]:=1;
+ break;
+ end;
+ end;
+ if not speichern then begin
+ writeln('Warnung: Keine berechenbare Verknüpfung gefunden!: I=',I);
+ result:=false;
+ exit;
+ end;
+ end;
+ for I:=0 to length(Ps)-1 do
+ if Ps[I]<>1 then
+ begin
+ writeln('Warnung: Nicht alle Parameter wurden berechnet! ',I);
+ result:=false;
+ exit;
+ end;
+ setlength(Ps,0);
+ for I:=0 to length(Personen)-1 do
+ for J:=0 to I-1 do begin
+ K:=min(
+ Personen[I].Ende.Jahr-Personen[J].Anfang.Jahr,
+ Personen[J].Ende.Jahr-Personen[I].Anfang.Jahr)+1+Zusatzueberlapp;
+ if K>0 then begin
+ setlength(MMInteraktionen,length(MMInteraktionen)+1);
+ MMInteraktionen[length(MMInteraktionen)-1]:=tMMInteraktion.create;
+ MMInteraktionen[length(MMInteraktionen)-1].Laenge:=min(K,Ueberlappcutoff);
+ MMInteraktionen[length(MMInteraktionen)-1]._Ps[0]:=Personen[I];
+ MMInteraktionen[length(MMInteraktionen)-1]._Ps[1]:=Personen[J];
+ MMInteraktionen[length(MMInteraktionen)-1].index:=length(MMInteraktionen)-1;
+ end;
+ end;
+ for I:=0 to length(Personen)-1 do
+ for J:=0 to length(Familien)-1 do begin
+ speichern:=Personen[I].KindIn<>Familien[J];
+ for K:=0 to length(Personen[I].ElterIn)-1 do
+ speichern:=speichern and (Personen[I].ElterIn[K]<>Familien[J]);
+ if speichern then begin
+ K:=min(
+ Familien[J].Anfang.Jahr-Personen[I].Anfang.Jahr,
+ Personen[I].Ende.Jahr-Familien[J].Anfang.Jahr)+1+Jahrestoleranz;
+ if K>0 then begin
+ setlength(MFInteraktionen,length(MFInteraktionen)+1);
+ MFInteraktionen[length(MFInteraktionen)-1]:=tMFInteraktion.create;
+ MFInteraktionen[length(MFInteraktionen)-1].Laenge:=min(K,Ueberlappcutoff);
+ MFInteraktionen[length(MFInteraktionen)-1]._P:=Personen[I];
+ MFInteraktionen[length(MFInteraktionen)-1]._F:=Familien[J];
+ MFInteraktionen[length(MFInteraktionen)-1].index:=length(MFInteraktionen)-1;
+ end;
+ end;
+ end;
+ for I:=0 to length(Familien)-1 do
+ for J:=0 to I-1 do begin
+ speichern:=true;
+ for K:=0 to 1 do
+ for L:=0 to 1 do
+ speichern:=speichern and
+ (Familien[I].Eltern[K]<>Familien[J].Eltern[L]);
+ K:=Jahrestoleranz+1-abs(Familien[I].Anfang.Jahr-Familien[J].Anfang.Jahr);
+ if (K>0) and speichern then begin
+ setlength(FFInteraktionen,length(FFInteraktionen)+1);
+ FFInteraktionen[length(FFInteraktionen)-1]:=tFFInteraktion.create;
+ FFInteraktionen[length(FFInteraktionen)-1]._Fs[0]:=Familien[I];
+ FFInteraktionen[length(FFInteraktionen)-1]._Fs[1]:=Familien[J];
+ FFInteraktionen[length(FFInteraktionen)-1].index:=length(FFInteraktionen)-1;
+ end;
+ end;
+ setlength(Tauschfamilien,0);
+ for I:=0 to length(Familien)-1 do
+ if length(Familien[I].Kinder)>=2 then begin
+ setlength(Tauschfamilien,length(Tauschfamilien)+1);
+ Tauschfamilien[length(Tauschfamilien)-1]:=Familien[I];
+ end;
+ if assigned(Sicherung) then begin
+ writeln('... und noch die der Sicherung');
+ result:=Sicherung.analysiereInteraktionen;
+ end
+ else begin
+ writeln('... fertig');
+ result:=true;
+ end;
+end;
+
+function tMetaData.findeKreise: tPointArrayArray; // x: Person, y: Familie
+var Graph: tGraph; // Ecke.x=0 ... Person; Ecke.x=1 ... Familie; Ecke.y=Index;
+ i,j,n: longint;
+ Kreise: tIntArrayArray;
+begin
+ setlength(result,0);
+ Graph:=tGraph.create;
+ setlength(Graph.Ecken,length(Personen)+length(Familien));
+ n:=0;
+ for i:=0 to length(Personen)-1 do begin
+ Graph.Ecken[i].x:=0;
+ Graph.Ecken[i].y:=i;
+ end;
+ for i:=0 to length(Familien)-1 do begin
+ Graph.Ecken[i+length(Personen)].x:=1;
+ Graph.Ecken[i+length(Personen)].y:=i;
+ n:=n+2+length(Familien[i].Kinder);
+ end;
+ setlength(Graph.Kanten,n);
+ n:=0;
+ for i:=0 to length(Familien)-1 do begin
+ for j:=0 to 1 do begin
+ Graph.Kanten[n].x:=i+length(Personen); // die Familie
+ Graph.Kanten[n].y:=Familien[i].Eltern[j].Index; // der Elter
+ inc(n);
+ end;
+ for j:=0 to length(Familien[i].Kinder)-1 do begin
+ Graph.Kanten[n].x:=i+length(Personen); // die Familie
+ Graph.Kanten[n].y:=Familien[i].Kinder[j].Index; // das Kind
+ inc(n);
+ end;
+ end;
+ Kreise:=Graph.findeKreise;
+ setlength(result,length(Kreise));
+ for i:=0 to length(result)-1 do begin
+ setlength(result[i],length(Kreise[i]));
+ for j:=0 to length(Kreise[i])-1 do
+ if Graph.Ecken[Graph.Kanten[Kreise[i,j]].x].x = 0 then begin
+ result[i,j].x:=Graph.Ecken[Graph.Kanten[Kreise[i,j]].x].y;
+ result[i,j].y:=Graph.Ecken[Graph.Kanten[Kreise[i,j]].y].y;
+ end
+ else if Graph.Ecken[Graph.Kanten[Kreise[i,j]].y].x = 0 then begin
+ result[i,j].x:=Graph.Ecken[Graph.Kanten[Kreise[i,j]].y].y;
+ result[i,j].y:=Graph.Ecken[Graph.Kanten[Kreise[i,j]].x].y;
+ end
+ else writeln('Kein Ende der Kante ist eine Person!');
+ end;
+end;
+
+procedure tMetaData.blaetterAbschneiden;
+var
+ i,j,k,cnt: longint;
+ gefunden: boolean;
+begin
+ if assigned(sicherung) or (length(Laubhaufen)<>0) then begin
+ writeln('*** Warnung ***');
+ writeln('Hier waren schon Blätter gesichert, die ich jetzt vernichte.');
+ sicherung.free;
+ setlength(Laubhaufen,0);
+ end;
+
+ sicherung:=tMetaData.create;
+ sicherung.init(self);
+ sicherung.indizesErzeugen;
+
+ for i:=0 to length(ParameterAttribute)-1 do
+ ParameterAttribute[i].wirdBenutzt:=true;
+
+ cnt:=0;
+
+ konsistenzTest(true);
+
+ repeat
+ gefunden:=false;
+ for i:=length(Personen)-1 downto 0 do // Personen entfernen, die keine Eltern (mehr) sind
+ if length(Personen[i].elterIn) = 0 then begin
+ if cnt>=length(Laubhaufen) then
+ setlength(Laubhaufen,length(Laubhaufen)+1024);
+ Laubhaufen[cnt]:=findePerson(sicherung.Personen,pPersonToStr(Personen[i])); // Person sichern
+ sicherung.habePersonGeloescht(Laubhaufen[cnt] as tPerson);
+ inc(cnt);
+
+ loescheAlleVerbindungenZu(Personen[i],nil);
+
+ ParameterAttribute[Personen[i].p1].setzeBenutzt(false); // x,
+ ParameterAttribute[Personen[i].p2].setzeBenutzt(false); // y
+ if assigned(Personen[i].KindIn) then // und ggf.
+ ParameterAttribute[Personen[i].p3].setzeBenutzt(false); // Lambda unbenutzen
+
+ loeschePerson(Personen,pPersonToStr(Personen[i])); // Person löschen
+ gefunden:=true;
+ end;
+
+ for i:=length(Familien)-1 downto 0 do // Familien entfernen, die nur noch höchstens ein relevantes Mitglied haben
+ if byte(assigned(Familien[i].Eltern[0]) and (Familien[i].Eltern[0].anzahlVerbindungen>1)) + // Eltern brauchen mehr als die Verbindung zu
+ byte(assigned(Familien[i].Eltern[1]) and (Familien[i].Eltern[1].anzahlVerbindungen>1)) + // dieser Familie um relevant zu sein,
+ length(Familien[i].Kinder) <= 1 then begin // Kinder müssen dagegen lediglich vorhanden sein
+ if cnt>=length(Laubhaufen) then
+ setlength(Laubhaufen,length(Laubhaufen)+1024);
+ Laubhaufen[cnt]:=findeFamilie(sicherung.Familien,pFamilieToStr(Familien[i])); // Familie sichern
+ sicherung.habeFamilieGeloescht(Laubhaufen[cnt] as tFamilie);
+ inc(cnt);
+
+ for j:=length(Tauschfamilien)-1 downto 0 do
+ if Tauschfamilien[j]=Familien[i] then begin // Familie aus Tauschfamilien löschen
+ for k:=j+1 to length(Tauschfamilien)-1 do
+ Tauschfamilien[k-1]:=Tauschfamilien[k];
+ setlength(Tauschfamilien,length(Tauschfamilien)-1);
+ end;
+
+ for j:=0 to 1 do
+ if assigned(Familien[i].Eltern[j]) and
+ (Familien[i].Eltern[j].anzahlVerbindungen<=1) then begin // irrelevanter Elter
+ sicherung.habePersonGeloescht(findePerson(sicherung.Personen,pPersonToStr(Familien[i].Eltern[j]),false));
+ ParameterAttribute[Familien[i].Eltern[j].p1].setzeBenutzt(false); // x,
+ ParameterAttribute[Familien[i].Eltern[j].p2].setzeBenutzt(false); // y unbenutzen
+
+ loescheAlleVerbindungenZu(Familien[i].Eltern[j],nil);
+ loeschePerson(Personen,pPersonToStr(Familien[i].Eltern[j])); // Elter löschen
+ end;
+
+ // Kinder können per definitionem nicht irrelevant sein, daher muss man auch keine löschen
+
+ if length(Familien[i].Kinder)=1 then begin
+ loescheVerknuepfungenZu(Familien[i].Kinder[0]);
+ ParameterAttribute[Familien[i].Kinder[0].p3].setzeBenutzt(false); // Lambda unbenutzen
+ ParameterAttribute[Familien[i].Kinder[0].p1].setzeUnabhaengig(true); // x,
+ ParameterAttribute[Familien[i].Kinder[0].p2].setzeUnabhaengig(true); // y befreien
+ end;
+
+ loescheAlleVerbindungenZu(nil,Familien[i]);
+
+ loescheFamilie(Familien,pFamilieToStr(Familien[i])); // Familie löschen
+ gefunden:=true;
+ end;
+ until not gefunden;
+ setlength(Laubhaufen,cnt);
+ arraysAufraeumen;
+end;
+
+procedure tMetaData.letztesBlattWiederAnkleben(out vkn: tVerknuepfung; out p: tPerson);
+var
+ i,j: longint;
+ gefunden: boolean;
+ sp1,sp2: tPerson;
+ sf: tFamilie;
+begin
+ if (not assigned(sicherung)) or (length(Laubhaufen)=0) then begin
+ writeln('*** Fehler ***');
+ writeln('Ich habe keine Blätter mehr übrig.');
+ halt;
+ end;
+
+ p:=nil;
+ sp1:=nil;
+ sp2:=nil;
+ sf:=nil;
+ vkn:=nil;
+
+ if Laubhaufen[length(Laubhaufen)-1] is tPerson then begin // diese Person ist (zur Zeit) nur ein Kind und kann einfach eingefügt werden
+ write('k');
+ setlength(Personen,length(Personen)+1);
+ Personen[length(Personen)-1]:=tPerson.create;
+ Personen[length(Personen)-1].init(Laubhaufen[length(Laubhaufen)-1],Ereignisse,Familien,false); // Person wird kopiert, aber zugehörige Familien werden nicht auch noch erzeugt!
+ sicherung.habePersonHinzugefuegt(Laubhaufen[length(Laubhaufen)-1] as tPerson);
+ sp1:=Laubhaufen[length(Laubhaufen)-1] as tPerson;
+ Personen[length(Personen)-1].index:=length(Personen)-1;
+ p:=Personen[length(Personen)-1];
+ Parameterattribute[p.p1].setzeBenutzt(true);
+ Parameterattribute[p.p2].setzeBenutzt(true);
+
+ if not (assigned(p.KindIn) and assigned(p.KindIn.Eltern[0]) and assigned(p.KindIn.Eltern[1])) then begin
+ writeln('*** Fehler ***');
+ writeln('Als Kind einzufügende Person hat hier nicht beide Eltern!');
+ halt;
+ end;
+
+ gefunden:=false;
+ for i:=0 to length(sicherung.Verknuepfungen)-1 do
+ if sicherung.Verknuepfungen[i].outP=Laubhaufen[length(Laubhaufen)-1] then begin
+ if gefunden then begin
+ writeln('*** Fehler ***');
+ writeln('Als Kind einzufügende Person wird durch mehr als eine Verknüpfung berechnet!');
+ halt;
+ end;
+ setlength(Verknuepfungen,length(Verknuepfungen)+1); // die neue Verknuepfung wird einfach hinten angestellt
+ Verknuepfungen[length(Verknuepfungen)-1]:=strToTVerknuepfung(Personen,tVerknuepfungToStr(sicherung.Verknuepfungen[i]));
+ Verknuepfungen[length(Verknuepfungen)-1].index:=length(Verknuepfungen)-1;
+ vkn:=Verknuepfungen[length(Verknuepfungen)-1];
+ Parameterattribute[vkn.Lambda].setzeBenutzt(true);
+ gefunden:=true;
+ end;
+ if not gefunden then begin
+ writeln('*** Fehler ***');
+ writeln('Als Kind einzufügende Person wird durch keine Verknüpfung berechnet!');
+ halt;
+ end;
+ setlength(Laubhaufen,length(Laubhaufen)-1);
+ end
+ else if Laubhaufen[length(Laubhaufen)-1] is tFamilie then begin // Familie inkl. Elter(n) einfügen (keine neuen Kinder!)
+ write('f');
+ j:=-1;
+ for i:=0 to 1 do
+ if findePerson(Personen,pPersonToStr((Laubhaufen[length(Laubhaufen)-1] as tFamilie).Eltern[i]),false)<>nil then begin
+ if j<>-1 then begin
+ writeln('*** Fehler ***');
+ writeln('Beide Eltern der neuen Familie waren schon vorhanden!');
+ halt;
+ end;
+ j:=i;
+ end;
+ for i:=0 to 1 do
+ if i<>j then begin
+ setlength(Personen,length(Personen)+1);
+ Personen[length(Personen)-1]:=tPerson.create;
+ Personen[length(Personen)-1].init((Laubhaufen[length(Laubhaufen)-1] as tFamilie).Eltern[i],Ereignisse,Familien,false); // neuer Elter wird kopiert, aber zugehörige Familien werden nicht auch noch erzeugt!
+ Personen[length(Personen)-1].index:=length(Personen)-1;
+ sicherung.habePersonHinzugefuegt((Laubhaufen[length(Laubhaufen)-1] as tFamilie).Eltern[i]);
+ sp2:=sp1;
+ p:=Personen[length(Personen)-1];
+ sp1:=(Laubhaufen[length(Laubhaufen)-1] as tFamilie).Eltern[i];
+ Parameterattribute[p.p1].setzeBenutzt(true);
+ Parameterattribute[p.p2].setzeBenutzt(true);
+ end;
+
+ setlength(Familien,length(Familien)+1);
+ Familien[length(Familien)-1]:=tFamilie.create;
+ Familien[length(Familien)-1].init(Laubhaufen[length(Laubhaufen)-1],Ereignisse,Personen,false); // Familie wird kopiert, aber Angehörige (insbesondere die Kinder) werden nicht auch noch erzeugt!
+ Familien[length(Familien)-1].index:=length(Familien)-1;
+ sf:=Laubhaufen[length(Laubhaufen)-1] as tFamilie;
+ sicherung.habeFamilieHinzugefuegt(sf);
+
+ if (j<>-1) and (length(Familien[length(Familien)-1].Kinder)<>0) then begin
+ writeln('*** Fehler ***');
+ writeln('Die neu eingefügte Familie hat schon ein Elter und ein Kind!');
+ halt;
+ end;
+ if (j=-1) and (length(Familien[length(Familien)-1].Kinder)<>1) then begin
+ writeln('*** Fehler ***');
+ writeln('Die neu eingefügte Familie hat noch kein Kind obwohl beide Eltern neu sind!');
+ halt;
+ end;
+
+ for i:=0 to length(sicherung.Tauschfamilien)-1 do
+ if sicherung.Tauschfamilien[i]=Laubhaufen[length(Laubhaufen)-1] then begin // Tauschfamilie rücksichern
+ setlength(Tauschfamilien,length(Tauschfamilien)+1);
+ Tauschfamilien[length(Tauschfamilien)-1]:=Familien[length(Familien)-1];
+ end;
+
+ if j=-1 then begin // beide Eltern sind neu, dann wird auch die Verknüpfung zurückgesichert!
+ write('E');
+ gefunden:=false;
+ for i:=0 to length(sicherung.Verknuepfungen)-1 do
+ if (sicherung.Verknuepfungen[i].outP.KindIn=Laubhaufen[length(Laubhaufen)-1]) and // die Verknüpfung bezieht sich auf die Familie
+ sicherung.istPersonAuchDrueber(sicherung.Verknuepfungen[i].outP) then begin // und das berechnete Kind ist schon zurückgesichert
+ if gefunden then begin
+ writeln('*** Fehler ***');
+ writeln('Die neue Familie bringt mehr als eine Verknüpfung mit!');
+ halt;
+ end;
+
+ setlength(Verknuepfungen,length(Verknuepfungen)+1); // die neue Verknuepfung wird einfach vorne angestellt
+ for j:=length(Verknuepfungen)-1 downto 1 do begin
+ Verknuepfungen[j]:=Verknuepfungen[j-1];
+ Verknuepfungen[j].index:=j;
+ end;
+ Verknuepfungen[0]:=strToTVerknuepfung(Personen,tVerknuepfungToStr(sicherung.Verknuepfungen[i]));
+ Verknuepfungen[0].index:=0;
+ vkn:=Verknuepfungen[0];
+ Parameterattribute[vkn.Lambda].setzeBenutzt(true);
+ ParameterAttribute[vkn.Output['x']].setzeUnabhaengig(false); // x,
+ ParameterAttribute[vkn.Output['y']].setzeUnabhaengig(false); // y abhängig machen
+ // Die restlichen Parameter werden als benutzt markiert, wenn die entsprechenden Personen eingefügt werden.
+
+ gefunden:=true;
+ end;
+ if not gefunden then begin
+ writeln('*** Fehler ***');
+ writeln('Beide Eltern sind neu, aber es gibt keine passende Verknüpfung!');
+ halt;
+ end;
+ p:=nil;
+
+ j:=-1;
+ end;
+
+ setlength(Laubhaufen,length(Laubhaufen)-1);
+ end
+ else begin
+ writeln('*** Fehler ***');
+ writeln('Das wieder einzufügende Blatt ist weder eine Person noch eine Familie!');
+ halt;
+ end;
+
+ if assigned(sp1) then begin
+ for i:=0 to length(sp1.inMMInteraktion)-1 do
+ if sicherung.istPersonAuchDrueber(sp1.inMMInteraktion[i]._Ps[0]) and // beide Personen sind
+ sicherung.istPersonAuchDrueber(sp1.inMMInteraktion[i]._Ps[1]) then begin // auch hier vorhanden
+ setlength(MMInteraktionen,length(MMInteraktionen)+1);
+ MMInteraktionen[length(MMInteraktionen)-1]:=ImportMMInteraktion(Personen,tMMInteraktionToStr(sp1.inMMInteraktion[i])); // Interaktion erzeugen
+ end;
+ for i:=0 to length(sp1.inMFInteraktion)-1 do
+ if sicherung.istFamilieAuchDrueber(sp1.inMFInteraktion[i]._F) then begin // Familie hier vorhanden
+ setlength(MFInteraktionen,length(MFInteraktionen)+1);
+ MFInteraktionen[length(MFInteraktionen)-1]:=ImportMFInteraktion(Personen,Familien,tMFInteraktionToStr(sp1.inMFInteraktion[i]));
+ end;
+ end;
+
+ if assigned(sp2) and (sp1<>sp2) then begin
+ for i:=0 to length(sp2.inMMInteraktion)-1 do
+ if sicherung.istPersonAuchDrueber(sp2.inMMInteraktion[i]._Ps[0]) and // beide Personen sind
+ sicherung.istPersonAuchDrueber(sp2.inMMInteraktion[i]._Ps[1]) and // auch hier vorhanden und
+ (sp2.inMMInteraktion[i]._Ps[0]<>sp1) and // beide Personen sind
+ (sp2.inMMInteraktion[i]._Ps[1]<>sp1) then begin // nicht sp1 (sonst wurde die MMInteraktion oben schon rückgesichert)
+ setlength(MMInteraktionen,length(MMInteraktionen)+1);
+ MMInteraktionen[length(MMInteraktionen)-1]:=ImportMMInteraktion(Personen,tMMInteraktionToStr(sp2.inMMInteraktion[i])); // Interaktion erzeugen
+ end;
+ for i:=0 to length(sp2.inMFInteraktion)-1 do
+ if sicherung.istFamilieAuchDrueber(sp2.inMFInteraktion[i]._F) then begin // Familie hier vorhanden
+ setlength(MFInteraktionen,length(MFInteraktionen)+1);
+ MFInteraktionen[length(MFInteraktionen)-1]:=ImportMFInteraktion(Personen,Familien,tMFInteraktionToStr(sp2.inMFInteraktion[i]));
+ end;
+ end;
+
+ if assigned(sf) then begin
+ for i:=0 to length(sf.inMFInteraktion)-1 do
+ if sicherung.istPersonAuchDrueber(sf.inMFInteraktion[i]._P) and // Familie hier vorhanden
+ (sf.inMFInteraktion[i]._P<>sp1) and // und Person weder sp1
+ (sf.inMFInteraktion[i]._P<>sp2) then begin // noch sp2 (sonst wurde die MFInteraktion oben schon rückgesichert)
+ setlength(MFInteraktionen,length(MFInteraktionen)+1);
+ MFInteraktionen[length(MFInteraktionen)-1]:=ImportMFInteraktion(Personen,Familien,tMFInteraktionToStr(sf.inMFInteraktion[i]));
+ end;
+ for i:=0 to length(sf.inFFInteraktion)-1 do
+ if sicherung.istFamilieAuchDrueber(sf.inFFInteraktion[i]._Fs[0]) and // beide Familienda sind
+ sicherung.istFamilieAuchDrueber(sf.inFFInteraktion[i]._Fs[1]) then begin // auch hier vorhanden
+ setlength(FFInteraktionen,length(FFInteraktionen)+1);
+ FFInteraktionen[length(FFInteraktionen)-1]:=ImportFFInteraktion(Familien,tFFInteraktionToStr(sf.inFFInteraktion[i]));
+ end;
+ end;
+
+ if length(Laubhaufen)=0 then begin
+ pruefeAufGleichheit(sicherung);
+ sicherung.free;
+ sicherung:=nil;
+ end;
+end;
+
+procedure tMetaData.nurGroeszteZusammenhangskomponente;
+var
+ i,j,k,l: longint;
+ zhks: array of tZusammenhangskomponente;
+ gefunden: boolean;
+begin
+ setlength(Zhks,0);
+ for i:=0 to length(Personen)-1 do begin
+ k:=-1;
+ j:=0;
+ while j<length(Zhks) do begin
+ if Zhks[j].grenztAn(Personen[i]) then begin
+ if k=-1 then begin
+ k:=j;
+ inc(j);
+ continue;
+ end;
+ Zhks[k].verschmelzeMit(Zhks[j]);
+ Zhks[j].free;
+ for l:=j+1 to length(Zhks)-1 do
+ Zhks[l-1]:=Zhks[l];
+ setlength(Zhks,length(Zhks)-1);
+ end;
+ inc(j);
+ end;
+ if k=-1 then begin
+ setlength(Zhks,length(Zhks)+1);
+ Zhks[length(Zhks)-1]:=tZusammenhangskomponente.create;
+ k:=length(Zhks)-1;
+ end;
+ Zhks[k].UmfeldEinfuegen(Familien,Personen[i]);
+ end;
+ if length(Zhks)=1 then begin
+ Zhks[0].free;
+ setlength(Zhks,0);
+ exit;
+ end;
+ writeln('*** Warnung ***');
+ writeln(inttostr(length(Zhks))+' Zusammenhangskomponenten gefunden. ('+inttostr(length(Familien))+' Familien und '+inttostr(length(Personen))+' Personen)');
+ j:=0;
+ k:=-1;
+ for i:=0 to length(Zhks)-1 do begin
+ write(' '+inttostr(length(Zhks[i].Familien)));
+ if length(Zhks[i].Familien)>j then begin
+ j:=length(Zhks[i].Familien);
+ k:=i;
+ end;
+ end;
+ writeln;
+ writeln('Da nehme ich doch die '+inttostr(k+1)+'. mit '+inttostr(j)+' Familien!');
+ for i:=length(Personen)-1 downto 0 do begin // überflüssige Personen löschen
+ if not Zhks[k].grenztAn(Personen[i]) then begin
+ Personen[i].free;
+ for j:=i+1 to length(Personen)-1 do
+ Personen[j-1]:=Personen[j];
+ setlength(Personen,length(Personen)-1);
+ end;
+ end;
+ for i:=length(Familien)-1 downto 0 do begin
+ gefunden:=false;
+ for j:=0 to length(Zhks[k].Familien)-1 do
+ gefunden:=gefunden or (Zhks[k].Familien[j]=Familien[i]);
+ if not gefunden then begin
+ Familien[i].free;
+ for j:=i+1 to length(Familien)-1 do
+ Familien[j-1]:=Familien[j];
+ setlength(Familien,length(Familien)-1);
+ end;
+ end;
+ writeln(inttostr(length(Personen))+' Personen und '+inttostr(length(Familien))+' Familien sind übrig.');
+ writeln('***');
+ for i:=0 to length(Zhks)-1 do
+ Zhks[i].free;
+ setlength(Zhks,0);
+end;
+
+procedure tMetaData.konsistenzTest(mitIndizes: boolean);
+var
+ i,j,k,anz: longint;
+begin
+ if assigned(sicherung) then begin
+ for i:=0 to length(sicherung.Personen)-1 do
+ if sicherung.istPersonAuchDrueber(sicherung.Personen[i]) xor
+ (findePerson(Personen,pPersonToStr(sicherung.Personen[i]),false)<>nil) then begin
+ write('Person '''+tPersonToStr(sicherung.Personen[i])+''' ist in Sicherung fälschlicherweise als ''');
+ if not sicherung.istPersonAuchDrueber(sicherung.Personen[i]) then
+ write('nicht-');
+ writeln('auchdrüber'' markiert!');
+ halt;
+ end;
+ for i:=0 to length(sicherung.Familien)-1 do
+ if sicherung.istFamilieAuchDrueber(sicherung.Familien[i]) xor
+ (findeFamilie(Familien,pFamilieToStr(sicherung.Familien[i]),false)<>nil) then begin
+ write('Familie '''+tFamilieToStr(sicherung.Familien[i])+''' ist in Sicherung fälschlicherweise als ''');
+ if not sicherung.istFamilieAuchDrueber(sicherung.Familien[i]) then
+ write('nicht-');
+ writeln('auchdrüber'' markiert!');
+ halt;
+ end;
+ end;
+ for i:=0 to length(Verknuepfungen)-1 do begin
+ if mitIndizes and (Verknuepfungen[i].index<>i) then begin
+ writeln('Verknüpfung an Stelle '+inttostr(i)+' hat Index '+inttostr(Verknuepfungen[i].index)+'.');
+ halt;
+ end;
+ if assigned(Verknuepfungen[i].outP) then begin
+ if (Verknuepfungen[i].outP.p1<>Verknuepfungen[i].Output['x']) or
+ (Verknuepfungen[i].outP.p2<>Verknuepfungen[i].Output['y']) or
+ (Verknuepfungen[i].outP.p3<>Verknuepfungen[i].lambda) or
+ (Verknuepfungen[i].outP.KindIn.Eltern[0].p1<>Verknuepfungen[i].Input[0,'x']) or
+ (Verknuepfungen[i].outP.KindIn.Eltern[0].p2<>Verknuepfungen[i].Input[0,'y']) or
+ (Verknuepfungen[i].outP.KindIn.Eltern[1].p1<>Verknuepfungen[i].Input[1,'x']) or
+ (Verknuepfungen[i].outP.KindIn.Eltern[1].p2<>Verknuepfungen[i].Input[1,'y']) then begin
+ writeln('Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' hat inkonsistente Parametereinträge!');
+ halt;
+ end;
+ if (not Parameterattribute[Verknuepfungen[i].outP.p1].wirdBenutzt) or
+ (not Parameterattribute[Verknuepfungen[i].outP.p2].wirdBenutzt) or
+ (not Parameterattribute[Verknuepfungen[i].outP.p3].wirdBenutzt) or
+ (not Parameterattribute[Verknuepfungen[i].outP.p1].istKoordinate) or
+ (not Parameterattribute[Verknuepfungen[i].outP.p2].istKoordinate) or
+ Parameterattribute[Verknuepfungen[i].outP.p3].istKoordinate or
+ Parameterattribute[Verknuepfungen[i].outP.p1].istUnabhaengig or
+ Parameterattribute[Verknuepfungen[i].outP.p2].istUnabhaengig or
+ (not Parameterattribute[Verknuepfungen[i].outP.p3].istUnabhaengig) then begin
+ writeln('Parameter zu Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' haben falsche Attribute: '+
+ Parameterattribute[Verknuepfungen[i].outP.p1].toChar+
+ Parameterattribute[Verknuepfungen[i].outP.p2].toChar+
+ Parameterattribute[Verknuepfungen[i].outP.p3].toChar+'!');
+ halt;
+ end;
+ anz:=0;
+ for j:=0 to length(Verknuepfungen[i].outP.outputIn)-1 do
+ if Verknuepfungen[i].outP.outputIn[j]=Verknuepfungen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' behauptet fälschlicherweise, Person '''+tPersonToStr(Verknuepfungen[i].outP)+''' zu berechnen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' ist mehrfach in Person '''+tPersonToStr(Verknuepfungen[i].outP)+''' als Quelle verzeichnet!');
+ halt;
+ end;
+ for k:=0 to 1 do begin
+ anz:=0;
+ for j:=0 to length(Verknuepfungen[i].outP.KindIn.Eltern[k].inputIn)-1 do
+ if Verknuepfungen[i].outP.KindIn.Eltern[k].inputIn[j]=Verknuepfungen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' behauptet fälschlicherweise, von Person '''+tPersonToStr(Verknuepfungen[i].outP.KindIn.Eltern[k])+''' abzuhängen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Verknüpfung '''+tVerknuepfungToStr(Verknuepfungen[i])+''' ist mehrfach in Person '''+tPersonToStr(Verknuepfungen[i].outP.KindIn.Eltern[k])+''' als Abhängigkeit verzeichnet!');
+ halt;
+ end;
+ end;
+ end;
+ end;
+ for i:=0 to length(MMInteraktionen)-1 do begin
+ if mitIndizes and (MMInteraktionen[i].Index<>i) then begin
+ writeln('MMInteraktion an Stelle '+inttostr(i)+' hat Index '+inttostr(MMInteraktionen[i].Index)+'.');
+ halt;
+ end;
+ for k:=0 to 1 do begin
+ anz:=0;
+ for j:=0 to length(MMInteraktionen[i]._Ps[k].inMMInteraktion)-1 do
+ if MMInteraktionen[i]._Ps[k].inMMInteraktion[j]=MMInteraktionen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('MMInteraktion '''+tMMInteraktionToStr(MMInteraktionen[i])+''' behauptet fälschlicherweise, von Person '''+MMInteraktionen[i]._Ps[k].ID+''' abzuhängen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('MMInteraktion '''+tMMInteraktionToStr(MMInteraktionen[i])+''' ist mehrfach in Person '''+MMInteraktionen[i]._Ps[k].ID+''' als Abhängigkeit verzeichnet!');
+ halt;
+ end;
+ end;
+ end;
+ for i:=0 to length(MFInteraktionen)-1 do begin
+ if mitIndizes and (MFInteraktionen[i].Index<>i) then begin
+ writeln('MFInteraktion an Stelle '+inttostr(i)+' hat Index '+inttostr(MFInteraktionen[i].Index)+'.');
+ halt;
+ end;
+ anz:=0;
+ for j:=0 to length(MFInteraktionen[i]._P.inMFInteraktion)-1 do
+ if MFInteraktionen[i]._P.inMFInteraktion[j]=MFInteraktionen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('MFInteraktion '''+tMFInteraktionToStr(MFInteraktionen[i])+''' behauptet fälschlicherweise, von Person '''+MFInteraktionen[i]._P.ID+''' abzuhängen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('MFInteraktion '''+tMFInteraktionToStr(MFInteraktionen[i])+''' ist mehrfach in Person '''+MFInteraktionen[i]._P.ID+''' als Abhängigkeit verzeichnet!');
+ halt;
+ end;
+ anz:=0;
+ for j:=0 to length(MFInteraktionen[i]._F.inMFInteraktion)-1 do
+ if MFInteraktionen[i]._F.inMFInteraktion[j]=MFInteraktionen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('MFInteraktion '''+tMFInteraktionToStr(MFInteraktionen[i])+''' behauptet fälschlicherweise, von Familie '''+MFInteraktionen[i]._F.ID+''' abzuhängen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('MFInteraktion '''+tMFInteraktionToStr(MFInteraktionen[i])+''' ist mehrfach in Familie '''+MFInteraktionen[i]._F.ID+''' als Abhängigkeit verzeichnet!');
+ halt;
+ end;
+ end;
+ for i:=0 to length(FFInteraktionen)-1 do begin
+ if mitIndizes and (FFInteraktionen[i].Index<>i) then begin
+ writeln('FFInteraktion an Stelle '+inttostr(i)+' hat Index '+inttostr(FFInteraktionen[i].Index)+'.');
+ halt;
+ end;
+ for k:=0 to 1 do begin
+ anz:=0;
+ for j:=0 to length(FFInteraktionen[i]._Fs[k].inFFInteraktion)-1 do
+ if FFInteraktionen[i]._Fs[k].inFFInteraktion[j]=FFInteraktionen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('FFInteraktion '''+tFFInteraktionToStr(FFInteraktionen[i])+''' behauptet fälschlicherweise, von Familie '''+FFInteraktionen[i]._Fs[k].ID+''' abzuhängen!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('FFInteraktion '''+tFFInteraktionToStr(FFInteraktionen[i])+''' ist mehrfach in Familie '''+FFInteraktionen[i]._Fs[k].ID+''' als Abhängigkeit verzeichnet!');
+ halt;
+ end;
+ end;
+ end;
+ for i:=0 to length(Personen)-1 do begin
+ for j:=i+1 to length(Personen)-1 do
+ if Personen[i].id=Personen[j].id then begin
+ writeln('Ich habe zwei Personen mit gleicher ID gefungen: '''+tPersonToStr(Personen[i])+''' und '''+tPersonToStr(Personen[j])+'''!');
+ halt;
+ end;
+ if mitIndizes and (Personen[i].Index<>i) then begin
+ writeln('Person an Stelle '+inttostr(i)+' hat Index '+inttostr(Personen[i].Index)+'.');
+ halt;
+ end;
+ if assigned(Personen[i].KindIn) then begin
+ anz:=0;
+ for j:=0 to length(Personen[i].KindIn.Kinder)-1 do
+ if Personen[i].KindIn.Kinder[j]=Personen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Kind '''+Personen[i].ID+''' behauptet fälschlicherweise, zu Familie '''+Personen[i].KindIn.ID+''' zu gehören!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Kind '''+Personen[i].ID+''' ist mehrfach in Familie '''+Personen[i].KindIn.ID+'''!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Personen[i].ElterIn)-1 do begin
+ anz:=0;
+ for k:=0 to 1 do
+ if Personen[i].ElterIn[j].Eltern[k]=Personen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Elter '''+Personen[i].ID+''' behauptet fälschlicherweise, zu Familie '''+Personen[i].ElterIn[j].ID+''' zu gehören!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Elter '''+Personen[i].ID+''' ist mehrfach Elter in Familie '''+Personen[i].ElterIn[j].ID+'''!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Personen[i].inputIn)-1 do begin
+ anz:=0;
+ for k:=0 to 1 do
+ if Personen[i].inputIn[j].outP.kindIn.Eltern[k]=Personen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Person '''+Personen[i].ID+''' behauptet fälschlicherweise, Input zu Verknüpfung '''+tVerknuepfungToStr(Personen[i].inputIn[j])+''' zu sein!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Person '''+Personen[i].ID+''' ist mehrfach als Input zu Verknüpfung '''+tVerknuepfungToStr(Personen[i].inputIn[j])+''' verzeichnet!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Personen[i].outputIn)-1 do begin
+ if Personen[i].outputIn[j].outP<>Personen[i] then begin
+ writeln('Person '''+Personen[i].ID+''' behauptet fälschlicherweise, Output von Verknüpfung '''+tVerknuepfungToStr(Personen[i].outputIn[j])+''' zu sein!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Personen[i].inMMInteraktion)-1 do begin
+ anz:=0;
+ for k:=0 to 1 do
+ if Personen[i].inMMInteraktion[j]._Ps[k]=Personen[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Person '''+Personen[i].ID+''' behauptet fälschlicherweise, in MMInteraktion '''+tMMInteraktionToStr(Personen[i].inMMInteraktion[j])+''' zu sein!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Person '''+Personen[i].ID+''' ist mehrfach in MMInteraktion '''+tMMInteraktionToStr(Personen[i].inMMInteraktion[j])+''' verzeichnet!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Personen[i].inMFInteraktion)-1 do begin
+ if Personen[i].inMFInteraktion[j]._P<>Personen[i] then begin
+ writeln('Person '''+Personen[i].ID+''' behauptet fälschlicherweise, in MFInteraktion '''+tMFInteraktionToStr(Personen[i].inMFInteraktion[j])+''' zu sein!');
+ halt;
+ end;
+ end;
+ end;
+ for i:=0 to length(Familien)-1 do begin
+ for j:=i+1 to length(Familien)-1 do
+ if Familien[i].id=Familien[j].id then begin
+ writeln('Ich habe zwei Familien mit gleicher ID gefungen: '''+tFamilieToStr(Familien[i])+''' und '''+tFamilieToStr(Familien[j])+'''!');
+ halt;
+ end;
+ if mitIndizes and (Familien[i].Index<>i) then begin
+ writeln('Familie an Stelle '+inttostr(i)+' hat Index '+inttostr(Familien[i].Index)+'.');
+ halt;
+ end;
+ for j:=0 to length(Familien[i].Kinder)-1 do
+ if Familien[i].Kinder[j].KindIn<>Familien[i] then begin
+ writeln('Kind '''+Familien[i].Kinder[j].ID+''' behauptet fälschlicherweise, nicht zu Familie '''+Familien[i].ID+''' zu gehören!');
+ halt;
+ end;
+ for j:=0 to length(Familien[i].Eltern)-1 do
+ if assigned(Familien[i].Eltern[j]) then begin
+ anz:=0;
+ for k:=0 to length(Familien[i].Eltern[j].ElterIn)-1 do
+ if Familien[i].Eltern[j].ElterIn[k]=Familien[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Elter '''+Familien[i].Eltern[j].ID+''' behauptet fälschlicherweise, nicht zu Familie '''+Familien[i].ID+''' zu gehören!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Elter '''+Familien[i].Eltern[j].ID+''' ist mehrfach in Familie '''+Familien[i].ID+'''!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Familien[i].inMFInteraktion)-1 do begin
+ if Familien[i].inMFInteraktion[j]._F<>Familien[i] then begin
+ writeln('Familie '''+Familien[i].ID+''' behauptet fälschlicherweise, in MFInteraktion '''+tMFInteraktionToStr(Familien[i].inMFInteraktion[j])+''' zu sein!');
+ halt;
+ end;
+ end;
+ for j:=0 to length(Familien[i].inFFInteraktion)-1 do begin
+ anz:=0;
+ for k:=0 to 1 do
+ if Familien[i].inFFInteraktion[j]._Fs[k]=Familien[i] then
+ inc(anz);
+ if anz=0 then begin
+ writeln('Familie '''+Familien[i].ID+''' behauptet fälschlicherweise, in FFInteraktion '''+tFFInteraktionToStr(Familien[i].inFFInteraktion[j])+''' zu sein!');
+ halt;
+ end;
+ if anz>1 then begin
+ writeln('Familie '''+Familien[i].ID+''' ist mehrfach in FFInteraktion '''+tFFInteraktionToStr(Familien[i].inFFInteraktion[j])+''' verzeichnet!');
+ halt;
+ end;
+ end;
+ if assigned(Familien[i].Eltern[0]) and assigned(Familien[i].Eltern[1]) then
+ for j:=i+1 to length(Familien)-1 do
+ if ((Familien[i].Eltern[0]=Familien[j].Eltern[0]) and (Familien[i].Eltern[1]=Familien[j].Eltern[1])) or
+ ((Familien[i].Eltern[0]=Familien[j].Eltern[1]) and (Familien[i].Eltern[1]=Familien[j].Eltern[0])) then begin
+ writeln('Es gibt hier zwei Familien zwischen jeweils den gleichen Eltern:');
+ writeln(' '+Familien[i].ID+' und '+Familien[j].ID);
+ writeln(' zwischen '+Familien[i].Eltern[0].ID+' und '+Familien[i].Eltern[1].ID);
+ halt;
+ end;
+ end;
+end;
+
+procedure tMetaData.pruefeAufGleichheit(vgl: tMetaData);
+var
+ i,j,cnt: longint;
+ p2p: tIntArray;
+ fehler: boolean;
+ MMarr,vMMarr: tMMInteraktionArray;
+ MFarr,vMFarr: tMFInteraktionArray;
+ FFarr,vFFarr: tFFInteraktionArray;
+ Vkarr,vVkarr: tVerknuepfungArray;
+begin
+ fehler:=false;
+ if ParameterLaenge<>vgl.ParameterLaenge then begin
+ writeln('*** Fehler ***');
+ writeln('''ParameterLaenge'' ist unterschiedlich ('+inttostr(ParameterLaenge)+' vs. '+inttostr(vgl.ParameterLaenge)+')');
+ fehler:=true;
+ end;
+
+ setlength(p2p,ParameterLaenge);
+ for i:=0 to length(p2p)-1 do
+ p2p[i]:=-1;
+
+ if length(Ereignisse)<>length(vgl.Ereignisse) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele Ereignisse ('+inttostr(length(Ereignisse))+' vs. '+inttostr(length(vgl.Ereignisse))+')');
+ fehler:=true;
+ end
+ else
+ for i:=0 to length(Ereignisse)-1 do begin
+ cnt:=0;
+ for j:=0 to length(vgl.Ereignisse)-1 do
+ if Ereignisse[i].istGleich(vgl.Ereignisse[j]) then
+ inc(cnt);
+ if cnt<>1 then begin
+ writeln('*** Fehler ***');
+ write('Ereignis '''+tEreignisToStr(Ereignisse[i])+''' gibt es ');
+ if cnt=0 then writeln('nicht.')
+ else writeln('mehrfach.');
+ fehler:=true;
+ end;
+ end;
+
+ write('.');
+
+ if length(Personen)<>length(vgl.Personen) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele Personen ('+inttostr(length(Personen))+' vs. '+inttostr(length(vgl.Personen))+')');
+ fehler:=true;
+ end
+ else
+ for i:=0 to length(Personen)-1 do begin
+ if ((Personen[i].p1<>-1) and (p2p[Personen[i].p1]<>-1)) or
+ ((Personen[i].p2<>-1) and (p2p[Personen[i].p2]<>-1)) or
+ ((Personen[i].p3<>-1) and (p2p[Personen[i].p3]<>-1)) then begin
+ writeln('*** Fehler ***');
+ writeln('Parameter doppelt referenziert!');
+ fehler:=true;
+ continue;
+ end;
+ cnt:=0;
+ for j:=0 to length(vgl.Personen)-1 do
+ if Personen[i].istGleich(vgl.Personen[j]) then begin
+ if vgl.Personen[j].p1<>-1 then
+ p2p[vgl.Personen[j].p1]:=Personen[i].p1;
+ if vgl.Personen[j].p2<>-1 then
+ p2p[vgl.Personen[j].p2]:=Personen[i].p2;
+ if vgl.Personen[j].p3<>-1 then
+ p2p[vgl.Personen[j].p3]:=Personen[i].p3;
+ inc(cnt);
+ end;
+ if cnt<>1 then begin
+ writeln('*** Fehler ***');
+ write('Person '''+tPersonToStr(Personen[i])+''' gibt es ');
+ if cnt=0 then writeln('nicht.')
+ else writeln('mehrfach.');
+ fehler:=true;
+ end;
+ end;
+
+ write('.');
+
+ if length(Familien)<>length(vgl.Familien) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele Familien ('+inttostr(length(Familien))+' vs. '+inttostr(length(vgl.Familien))+')');
+ fehler:=true;
+ end
+ else
+ for i:=0 to length(Familien)-1 do begin
+ cnt:=0;
+ for j:=0 to length(vgl.Familien)-1 do
+ if Familien[i].istGleich(vgl.Familien[j]) then
+ inc(cnt);
+ if cnt<>1 then begin
+ writeln('*** Fehler ***');
+ write('Familie '''+tFamilieToStr(Familien[i])+''' gibt es ');
+ if cnt=0 then writeln('nicht.')
+ else writeln('mehrfach.');
+ fehler:=true;
+ end;
+ end;
+
+ write('.');
+
+ if length(Verknuepfungen)<>length(vgl.Verknuepfungen) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele Verknuepfungen ('+inttostr(length(Verknuepfungen))+' vs. '+inttostr(length(vgl.Verknuepfungen))+')');
+ fehler:=true;
+ end
+ else begin
+ Vkarr:=sortiere(Verknuepfungen);
+ vVkarr:=sortiere(vgl.Verknuepfungen);
+ for i:=0 to length(Vkarr)-1 do
+ if not Vkarr[i].istGleich(vVkarr[i],p2p) then begin
+ writeln('*** Fehler ***');
+ write('Verknuepfungen unterscheiden sich ('+inttostr(cmpstr(sortstringfromobject(Vkarr[i]),sortstringfromobject(vVkarr[i])))+')!');
+ break;
+ end;
+ end;
+
+ write('.');
+
+ if length(MMInteraktionen)<>length(vgl.MMInteraktionen) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele MMInteraktionen ('+inttostr(length(MMInteraktionen))+' vs. '+inttostr(length(vgl.MMInteraktionen))+')');
+ fehler:=true;
+ end
+ else begin
+ MMarr:=sortiere(MMInteraktionen);
+ vMMarr:=sortiere(vgl.MMInteraktionen);
+ for i:=0 to length(MMarr)-1 do
+ if not MMarr[i].istGleich(vMMarr[i]) then begin
+ writeln('*** Fehler ***');
+ write('MMInteraktionen unterscheiden sich ('+inttostr(cmpstr(sortstringfromobject(MMarr[i]),sortstringfromobject(vMMarr[i])))+')!');
+ break;
+ end;
+ end;
+
+ write('.');
+
+ if length(MFInteraktionen)<>length(vgl.MFInteraktionen) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele MFInteraktionen ('+inttostr(length(MFInteraktionen))+' vs. '+inttostr(length(vgl.MFInteraktionen))+')');
+ fehler:=true;
+ end
+ else begin
+ MFarr:=sortiere(MFInteraktionen);
+ vMFarr:=sortiere(vgl.MFInteraktionen);
+ for i:=0 to length(MFarr)-1 do
+ if not MFarr[i].istGleich(vMFarr[i]) then begin
+ writeln('*** Fehler ***');
+ write('MFInteraktionen unterscheiden sich ('+inttostr(cmpstr(sortstringfromobject(MFarr[i]),sortstringfromobject(vMFarr[i])))+')!');
+ break;
+ end;
+ end;
+
+ write('.');
+
+ if length(FFInteraktionen)<>length(vgl.FFInteraktionen) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele FFInteraktionen ('+inttostr(length(FFInteraktionen))+' vs. '+inttostr(length(vgl.FFInteraktionen))+')');
+ fehler:=true;
+ end
+ else begin
+ FFarr:=sortiere(FFInteraktionen);
+ vFFarr:=sortiere(vgl.FFInteraktionen);
+ for i:=0 to length(FFarr)-1 do
+ if not FFarr[i].istGleich(vFFarr[i]) then begin
+ writeln('*** Fehler ***');
+ write('FFInteraktionen unterscheiden sich ('+inttostr(cmpstr(sortstringfromobject(FFarr[i]),sortstringfromobject(vFFarr[i])))+')!');
+ break;
+ end;
+ end;
+
+ write('.');
+
+ if length(ParameterAttribute)<>length(vgl.ParameterAttribute) then begin
+ writeln('*** Fehler ***');
+ writeln('''ParameterAttribute'' ist unterschiedlich lang ('+inttostr(length(ParameterAttribute))+' vs. '+inttostr(length(vgl.ParameterAttribute))+')');
+ fehler:=true;
+ end
+ else
+ for i:=0 to length(ParameterAttribute)-1 do begin
+ if p2p[i]=-1 then begin
+ writeln('*** Fehler ***');
+ write('Parameterübersetzung unvollständig!');
+ fehler:=true;
+ continue;
+ end;
+ if ParameterAttribute[p2p[i]].istUnabhaengig<>vgl.ParameterAttribute[i].istUnabhaengig then begin
+ writeln('*** Fehler ***');
+ writeln('Parameter '+inttostr(p2p[i])+' bzw. '+inttostr(i)+' ist ein Mal unabhängig und ein Mal nicht!');
+ fehler:=true;
+ end;
+ if ParameterAttribute[p2p[i]].istKoordinate<>vgl.ParameterAttribute[i].istKoordinate then begin
+ writeln('*** Fehler ***');
+ writeln('Parameter '+inttostr(p2p[i])+' bzw. '+inttostr(i)+' ist ein Mal eine Koordinate und ein Mal nicht!');
+ fehler:=true;
+ end;
+ if ParameterAttribute[p2p[i]].wirdBenutzt<>vgl.ParameterAttribute[i].wirdBenutzt then begin
+ writeln('*** Fehler ***');
+ writeln('Parameter '+inttostr(p2p[i])+' bzw. '+inttostr(i)+' wird ein Mal benutzt und ein Mal nicht!');
+ fehler:=true;
+ end;
+ end;
+
+ write('.');
+
+ if length(Tauschfamilien)<>length(vgl.Tauschfamilien) then begin
+ writeln('*** Fehler ***');
+ writeln('Unterschiedlich viele Tauschfamilien ('+inttostr(length(Tauschfamilien))+' vs. '+inttostr(length(vgl.Tauschfamilien))+')');
+ fehler:=true;
+ end
+ else
+ for i:=0 to length(Tauschfamilien)-1 do begin
+ cnt:=0;
+ for j:=0 to length(vgl.Tauschfamilien)-1 do
+ if Tauschfamilien[i].istGleich(vgl.Tauschfamilien[j]) then
+ inc(cnt);
+ if cnt<>1 then begin
+ writeln('*** Fehler ***');
+ write('Tauschfamilien '''+tFamilieToStr(Tauschfamilien[i])+''' gibt es ');
+ if cnt=0 then writeln('nicht.')
+ else writeln('mehrfach.');
+ fehler:=true;
+ end;
+ end;
+ writeln;
+ if fehler then halt;
+end;
+
+procedure tMetaData.habePersonGeloescht(p: tPerson);
+begin
+ if not assigned(p) then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Person ist NIL!');
+ halt;
+ end;
+ if Personen[p.index]<>p then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Person hat falschen Index!');
+ halt;
+ end;
+ if not personAuchDrueber[p.index] then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Person war schon gelöscht!');
+ halt;
+ end;
+ personAuchDrueber[p.index]:=false;
+end;
+
+procedure tMetaData.habeFamilieGeloescht(f: tFamilie);
+begin
+ if not assigned(f) then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Familie ist NIL!');
+ halt;
+ end;
+ if Familien[f.index]<>f then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Familie hat falschen Index!');
+ halt;
+ end;
+ if not familieAuchDrueber[f.index] then begin
+ writeln('*** Fehler ***');
+ writeln('Gelöschte Familie war schon gelöscht!');
+ halt;
+ end;
+ familieAuchDrueber[f.index]:=false;
+end;
+
+procedure tMetaData.habePersonHinzugefuegt(p: tPerson);
+begin
+ if not assigned(p) then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Person ist NIL!');
+ halt;
+ end;
+ if Personen[p.index]<>p then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Person hat falschen Index!');
+ halt;
+ end;
+ if personAuchDrueber[p.index] then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Person war schon hinzugefügt!');
+ halt;
+ end;
+ personAuchDrueber[p.index]:=true;
+end;
+
+procedure tMetaData.habeFamilieHinzugefuegt(f: tFamilie);
+begin
+ if not assigned(f) then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Familie ist NIL!');
+ halt;
+ end;
+ if Familien[f.index]<>f then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Familie hat falschen Index!');
+ halt;
+ end;
+ if familieAuchDrueber[f.index] then begin
+ writeln('*** Fehler ***');
+ writeln('Hinzugefügte Familie war schon hinzugefügt!');
+ halt;
+ end;
+ familieAuchDrueber[f.index]:=true;
+end;
+
+function tMetaData.istPersonAuchDrueber(p: tPerson): boolean;
+begin
+ if not assigned(p) then begin
+ writeln('*** Fehler ***');
+ writeln('Person ist NIL!');
+ halt;
+ end;
+ if Personen[p.index]<>p then begin
+ writeln('*** Fehler ***');
+ writeln('Person hat falschen Index!');
+ halt;
+ end;
+ result:=personAuchDrueber[p.index];
+end;
+
+function tMetaData.istFamilieAuchDrueber(f: tFamilie): boolean;
+begin
+ if not assigned(f) then begin
+ writeln('*** Fehler ***');
+ writeln('Famlie ist NIL!');
+ halt;
+ end;
+ if Familien[f.index]<>f then begin
+ writeln('*** Fehler ***');
+ writeln('Familie hat falschen Index!');
+ halt;
+ end;
+ result:=familieAuchDrueber[f.index];
+end;
+
+procedure tMetaData.indizesErzeugen;
+var i: longint;
+begin
+ for i:=0 to length(Personen)-1 do
+ Personen[i].index:=i;
+ for i:=0 to length(Familien)-1 do
+ Familien[i].index:=i;
+ for i:=0 to length(Verknuepfungen)-1 do
+ Verknuepfungen[i].index:=i;
+ for i:=0 to length(MMInteraktionen)-1 do
+ MMInteraktionen[i].index:=i;
+ for i:=0 to length(MFInteraktionen)-1 do
+ MFInteraktionen[i].index:=i;
+ for i:=0 to length(FFInteraktionen)-1 do
+ FFInteraktionen[i].index:=i;
+end;
+
+procedure tMetaData.loescheVerknuepfungenZu(p: tPerson);
+var
+ i,ind: longint;
+begin
+ for i:=length(p.outputIn)-1 downto 0 do begin
+ ind:=p.outputIn[i].index;
+ p.outputIn[i].free;
+ Verknuepfungen[ind]:=nil;
+ end;
+end;
+
+procedure tMetaData.loescheAlleVerbindungenZu(p: tPerson; f: tFamilie);
+var
+ i,j,ind: longint;
+begin
+ if assigned(p) then begin
+ loescheVerknuepfungenZu(p);
+ for i:=length(p.inputIn)-1 downto 0 do begin
+ ind:=p.inputIn[i].index;
+ p.inputIn[i].free;
+ Verknuepfungen[ind]:=nil;
+ end;
+ for i:=length(p.inMMInteraktion)-1 downto 0 do begin
+ ind:=p.inMMInteraktion[i].index;
+ p.inMMInteraktion[i].free;
+ MMInteraktionen[ind]:=nil;
+ end;
+ for i:=length(p.inMFInteraktion)-1 downto 0 do begin
+ ind:=p.inMFInteraktion[i].index;
+ p.inMFInteraktion[i].free;
+ MFInteraktionen[ind]:=nil;
+ end;
+ end;
+ if assigned(f) then begin
+ for i:=length(f.inMFInteraktion)-1 downto 0 do begin
+ ind:=f.inMFInteraktion[i].index;
+ f.inMFInteraktion[i].free;
+ MFInteraktionen[ind]:=nil;
+ end;
+ for i:=length(f.inFFInteraktion)-1 downto 0 do begin
+ ind:=f.inFFInteraktion[i].index;
+ f.inFFInteraktion[i].free;
+ FFInteraktionen[ind]:=nil;
+ end;
+ for i:=length(Tauschfamilien)-1 downto 0 do
+ if Tauschfamilien[i]=f then begin
+ for j:=i+1 to length(Tauschfamilien)-1 do
+ Tauschfamilien[j-1]:=Tauschfamilien[j];
+ setlength(Tauschfamilien,length(Tauschfamilien)-1);
+ end;
+ end;
+end;
+
+procedure tMetaData.arraysAufraeumen;
+var
+ i,j: longint;
+begin
+ j:=0;
+ for i:=0 to length(Verknuepfungen)-1 do
+ if Verknuepfungen[i]<>nil then begin
+ Verknuepfungen[j]:=Verknuepfungen[i];
+ Verknuepfungen[j].index:=j;
+ inc(j);
+ end;
+ setlength(Verknuepfungen,j);
+ j:=0;
+ for i:=0 to length(MMInteraktionen)-1 do
+ if MMInteraktionen[i]<>nil then begin
+ MMInteraktionen[j]:=MMInteraktionen[i];
+ MMInteraktionen[j].index:=j;
+ inc(j);
+ end;
+ setlength(MMInteraktionen,j);
+ j:=0;
+ for i:=0 to length(MFInteraktionen)-1 do
+ if MFInteraktionen[i]<>nil then begin
+ MFInteraktionen[j]:=MFInteraktionen[i];
+ MFInteraktionen[j].index:=j;
+ inc(j);
+ end;
+ setlength(MFInteraktionen,j);
+ j:=0;
+ for i:=0 to length(FFInteraktionen)-1 do
+ if FFInteraktionen[i]<>nil then begin
+ FFInteraktionen[j]:=FFInteraktionen[i];
+ FFInteraktionen[j].index:=j;
+ inc(j);
+ end;
+ setlength(FFInteraktionen,j);
+end;
+
+function tMetaData.anzUnabhaengig: longint;
+var
+ i: longint;
+begin
+ result:=0;
+ for i:=0 to length(ParameterAttribute)-1 do
+ result:=result+byte(ParameterAttribute[i].istUnabhaengig);
+end;
+
+function tMetaData.anzUnbenutzt: longint;
+var
+ i: longint;
+begin
+ result:=0;
+ for i:=0 to length(ParameterAttribute)-1 do
+ result:=result+byte(not ParameterAttribute[i].wirdBenutzt);
+end;
+
+// tParameterSimplex ***********************************************************
+constructor tParameterSimplex.create;
+begin
+ inherited create;
+ dim:=0;
+ fillchar(Ecken,sizeof(Ecken),#0);
+ setlength(Ecken,0);
+ fillchar(Energien,sizeof(Energien),#0);
+ setlength(Energien,0);
+ md:=nil;
+ letzteSchwerpunktberechnung:=0;
+ letzteSchwerpunktabweichung:=-1;
+end;
+
+destructor tParameterSimplex.destroy;
+begin
+ setlength(Ecken,0);
+ setlength(Energien,0);
+end;
+
+function tParameterSimplex.besserAls(a,b: longint): longint; // -1: a schlechter als b; 0: gleich gut; 1: a besser als b
+begin
+ result:=besserAls(a,b,false);
+end;
+
+function tParameterSimplex.besserAls(a,b: longint; hart: boolean): longint;
+begin
+ result:=besserAls(Kreuzungens[a],Energien[a],b);
+ if hart and (result=0) then begin
+ if a>b then begin
+ result:=-1;
+ exit;
+ end;
+ if a<b then begin
+ result:=1;
+ exit;
+ end;
+ end;
+end;
+
+function tParameterSimplex.besserAls(aKrz: longint; aEnerg: extended; b: longint): longint;
+begin
+ if aKrz>Kreuzungens[b] then begin
+ result:=-1;
+ exit;
+ end;
+ if aKrz<Kreuzungens[b] then begin
+ result:=1;
+ exit;
+ end;
+ if aEnerg>Energien[b] then begin
+ result:=-1;
+ exit;
+ end;
+ if aEnerg<Energien[b] then begin
+ result:=1;
+ exit;
+ end;
+ result:=0;
+end;
+
+procedure tParameterSimplex.ordnen;
+var i,j,lb,b: longint;
+begin
+ lb:=-1;
+ for i:=0 to dim do begin
+ b:=-1;
+ for j:=0 to dim do
+ if ((lb=-1) or (besserAls(lb,j,true)>0)) and
+ ((b=-1) or (besserAls(b,j,true)<0)) then
+ b:=j;
+ if b=-1 then begin
+ writeln('Nach '+inttostr(i+1)+' von '+inttostr(dim+1)+' Schritten ist kein Element mehr zu finden! ... seltsam!');
+ halt(1);
+ end;
+ Reihenfolge[i]:=b;
+ lb:=b;
+ end;
+end;
+
+function tParameterSimplex.einsortieren(wen,Luecke: longint): longint;
+var i,j,k: longint;
+begin
+ for i:=Luecke to dim-1 do
+ Reihenfolge[i]:=Reihenfolge[i+1];
+ i:=-1;
+ j:=dim;
+ while i<j-1 do begin // Bisektion
+ k:=(i+j) div 2;
+ if besserAls(wen,Reihenfolge[k],true)>0 then
+ j:=k
+ else
+ i:=k;
+ end;
+ if i<>j-1 then begin
+ writeln('Bisektion ist fehlgeschlagen ('+inttostr(i)+','+inttostr(j)+')');
+ halt(1);
+ end;
+ for i:=dim-1 downto j do
+ Reihenfolge[i+1]:=Reihenfolge[i];
+ Reihenfolge[j]:=wen;
+ result:=Luecke-j; // wie viele Plätze wurden gut gemacht?
+ j:=0;
+ for i:=0 to dim-1 do
+ if besserAls(Reihenfolge[i],Reihenfolge[i+1],true)<>1 then begin
+ j:=1;
+ write(i,' ');
+ end;
+ if j=1 then begin
+ writeln;
+ writeln('Fehler beim Einsortieren!');
+ halt;
+ end;
+end;
+
+function tParameterSimplex.normalisiere(i: longint): boolean;
+begin
+ result:=normalisiere(Ecken[i]);
+ if result then
+ berechneSchwerpunkt;
+end;
+
+function tParameterSimplex.normalisiere(ps: tExtendedArray): boolean;
+var
+ i: longint;
+ ma,mi: extended;
+begin
+ ma:=1;
+ mi:=0;
+ for i:=0 to length(ps)-1 do begin
+ ma:=max(ma,ps[i]);
+ mi:=min(mi,ps[i]);
+ end;
+ result:=(ma>1) or (mi<0);
+ if not result then exit;
+(* writeln;
+ writeln(mi,' .. ',ma);
+ for i:=0 to length(ps)-1 do
+ if (ps[i]=mi) or (ps[i]=ma) then
+ writeln(' '+inttostr(i)+' '+inttostr(byte(md.Koordinate[i]))); *)
+ ma:=1/max(epsilon,ma-mi);
+ for i:=0 to length(ps)-1 do
+ ps[i]:=(ps[i]-mi)*ma;
+end;
+
+procedure tParameterSimplex.berechneEnergien(mt: longint);
+begin
+ berechneEnergien(mt,false);
+end;
+
+procedure tParameterSimplex.berechneEnergien(mt: longint; ParameterBerechnen: boolean);
+var i: longint;
+ fertig: boolean;
+ ets: array of tEnergieThread;
+begin
+ setlength(ets,mt);
+ for i:=0 to mt-1 do
+ ets[i]:=
+ tEnergieThread.create(
+ self,
+ round( i /mt*(dim+1)),
+ round((i+1)/mt*(dim+1) - 1),
+ ParameterBerechnen);
+ repeat
+ fertig:=true;
+ for i:=0 to mt-1 do
+ fertig:=fertig and ets[i].fertig;
+ if not fertig then
+ sleep(100);
+ until fertig;
+ for i:=0 to mt-1 do
+ ets[i].free;
+end;
+
+function tParameterSimplex.berechneSchwerpunkt: extended;
+var
+ i,j: longint;
+ sp: tExtendedArray;
+begin
+ if dim<=1 then exit;
+ setlength(sp,dim);
+ for i:=0 to dim-1 do
+ sp[i]:=0;
+ for i:=0 to dim do
+ for j:=0 to dim-1 do
+ sp[j]:=sp[j]+Ecken[i][j];
+ for i:=0 to dim-1 do
+ sp[i]:=sp[i]/dim;
+ if length(Schwerpunkt)<>dim then begin
+ result:=-1;
+ setlength(Schwerpunkt,dim);
+ for i:=0 to dim-1 do
+ Schwerpunkt[i]:=sp[i];
+ end
+ else begin
+ result:=0;
+ for i:=0 to dim-1 do begin
+ result:=result+sqr(sp[i]-Schwerpunkt[i]);
+ Schwerpunkt[i]:=sp[i];
+ end;
+ end;
+ setlength(sp,0);
+ letzteSchwerpunktberechnung:=0;
+ letzteSchwerpunktabweichung:=result;
+end;
+
+procedure tParameterSimplex.init(ps: tExtendedArray; mt: longint);
+var i,j: longint;
+begin
+ if not assigned(md) then exit;
+ if md.ParameterLaenge<>length(ps) then exit;
+
+ for i:=0 to length(Ecken)-1 do
+ setlength(Ecken[i],0);
+ dim:=md.anzUnabhaengig;
+ pdim:=md.ParameterLaenge;
+ writeln('Der Simplex hat '+inttostr(dim+1)+' Ecken mit je '+inttostr(pdim)+' Parametern (davon '+inttostr(dim)+' unabhängige).');
+ setlength(Ecken,dim+1);
+ setlength(Energien,dim+1);
+ setlength(Kreuzungens,dim+1);
+ setlength(Kreuzungs,dim+1);
+ setlength(Reihenfolge,dim+1);
+ for i:=0 to length(Ecken)-1 do begin
+ setlength(Ecken[i],pdim);
+ Energien[i]:=-1;
+ Kreuzungens[i]:=0;
+ Kreuzungs[i]:=-1;
+ Reihenfolge[i]:=i;
+ end;
+
+ for i:=0 to pdim-1 do
+ Ecken[0,i]:=min(1,max(0,ps[i]));
+ for i:=1 to dim do begin
+ for j:=0 to dim-1 do
+ Ecken[i,j]:=Ecken[0,j] + (2*byte(Ecken[0,j]<0.5)-1)*(1e-15 + byte(MD.ParameterAttribute[MD.UnabIndizes[j]].istKoordinate)*1e-6)*byte(i-1 = j);
+ for j:=dim to pdim-1 do
+ Ecken[i,j]:=nan;
+ end;
+ for i:=0 to dim do
+ for j:=0 to dim-1 do
+ if (Ecken[i,j]<0) or (Ecken[i,j]>1) then begin
+ writeln('*** Fehler *** '+inttostr(i)+';'+inttostr(j)+': '+myfloattostr(Ecken[i,j]));
+ halt;
+ end;
+ berechneEnergien(mt,true);
+ berechneSchwerpunkt;
+ ordnen;
+end;
+
+procedure tParameterSimplex.outit(var ps: tExtendedArray);
+var
+ i: longint;
+begin
+ if length(ps)<>pdim then begin
+ writeln('Warnung: Anzahl der Parameter hat nicht gepasst, wurde angepasst!');
+ setlength(ps,pdim);
+ end;
+ for i:=0 to pdim-1 do
+ ps[i]:=Ecken[Reihenfolge[0],i];
+end;
+
+function tParameterSimplex.simplexSchritt(f,f1,f2,f3: extended; offset: longint): tSchrittErgebnis;
+var
+ np: tExtendedArray;
+begin
+ setlength(np,pdim);
+ result:=simplexSchritt(np,f,f1,f2,f3,offset);
+ setlength(np,0);
+end;
+
+function tParameterSimplex.simplexSchritt(var np: tExtendedArray; f,f1,f2,f3: extended; offset: longint): tSchrittErgebnis;
+var i,lu,krzgn,krz,aKrzgn: longint;
+ energ,aEnerg,fx,fs,fak: extended;
+ spBerechnen: byte;
+begin
+ if length(np)<>pdim then begin
+ writeln('Warnung: Arraylange musste angepasst werden!');
+ setlength(np,pdim);
+ for i:=0 to pdim-1 do
+ np[i]:=0;
+ end;
+ lu:=dim-offset;
+ offset:=Reihenfolge[lu];
+ aEnerg:=energien[offset];
+ aKrzgn:=Kreuzungens[offset];
+
+ fx:=(dim*f+1)/(dim-1);
+ fs:=(1+f)*dim/(dim-1);
+ for i:=0 to dim-1 do // X' = S * (1+f) dim / (dim-1) - X * (dim f + 1)/(dim - 1)
+ np[i]:=Schwerpunkt[i]*fs - Ecken[offset,i]*fx;
+
+ spBerechnen:=$3*byte(normalisiere(np)) xor $1;
+
+ md.berechneAbhaengigeVariable(np{$IFDEF detaillierteZeitanalyse}, true{$ENDIF});
+ energ:=md.Energie(np,krzgn,krz{$IFDEF detaillierteZeitanalyse}, true{$ENDIF});
+
+ if besserAls(krzgn,energ,offset)<0 then fak:=f1 // verschlechtert
+ else if besserAls(krzgn,energ,Reihenfolge[0])<0 then fak:=f2 // nicht der beste
+ else fak:=f3; // der beste
+
+ // X' = S (1+f) dim / (dim-1) - X * (dim f + 1)/(dim - 1)
+ fx:=(dim*fak+1)/(dim-1);
+ for i:=0 to dim-1 do
+ Ecken[offset,i]:=Schwerpunkt[i]*fs - Ecken[offset,i]*fx;
+
+ spBerechnen:=(spBerechnen shl 2) or byte(not normalisiere(offset));
+ berechneAbhaengigeVariable(offset{$IFDEF detaillierteZeitanalyse}, true{$ENDIF});
+ berechneEnergie(offset{$IFDEF detaillierteZeitanalyse}, true{$ENDIF});
+ result.faktorNeutralisiert:=besserAls(krzgn,energ,offset)>0; // mit großem Faktor verschlechtert
+ if result.faktorNeutralisiert then begin
+ fak:=f; // wird für die korrekte Schwerpunktverschiebung gebraucht
+ spBerechnen:=spBerechnen shr 1;
+ for i:=0 to pdim-1 do
+ Ecken[offset,i]:=
+ np[i];
+ Energien[offset]:=energ;
+ Kreuzungens[offset]:=krzgn;
+ Kreuzungs[offset]:=krz;
+ end;
+
+ if odd(spBerechnen shr 1) then
+ berechneSchwerpunkt // writeln('('+inttostr(letzteSchwerpunktberechnung)+') .Schwerpunktabweichung: '+myfloattostr(berechneSchwerpunkt))
+ else if odd(spBerechnen) then begin
+ // S' = S + (X'-X)/dim
+ // X'-X = X' * (1 + (dim - 1)/(dim f + 1)) - S * (1+f) dim / (dim f + 1)
+ fx:=1 + (dim-1)/(dim*fak+1);
+ fs:=(1+fak)*dim/(dim*fak+1);
+ for i:=0 to dim-1 do
+ Schwerpunkt[i]:=fs*Schwerpunkt[i] + fx*Ecken[offset,i];
+ inc(letzteSchwerpunktberechnung);
+ if (letzteSchwerpunktabweichung<=0) or
+ (letzteSchwerpunktberechnung*letzteSchwerpunktabweichung>1) or
+ (letzteSchwerpunktberechnung>100) then
+ berechneSchwerpunkt;//writeln('('+inttostr(letzteSchwerpunktberechnung)+') Schwerpunktabweichung: '+myfloattostr(berechneSchwerpunkt));
+ end;
+
+ result.besserAlsVorher:=besserAls(aKrzgn,aEnerg,offset)<0;
+// Energien[offset]:=md.Energie(Ecken[offset],Kreuzungens[offset],Kreuzungs[offset]);
+ result.Platzveraenderung:=einsortieren(offset,lu);
+end;
+
+procedure tParameterSimplex.berechneEnergie(i: longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+begin
+ Energien[i]:=md.Energie(Ecken[i],Kreuzungens[i],Kreuzungs[i]{$IFDEF detaillierteZeitanalyse},mainThread{$ENDIF});
+end;
+
+procedure tParameterSimplex.berechneAbhaengigeVariable(i: longint{$IFDEF detaillierteZeitanalyse}; mainThread: boolean{$ENDIF});
+begin
+ md.berechneAbhaengigeVariable(Ecken[i]{$IFDEF detaillierteZeitanalyse},mainThread{$ENDIF});
+end;
+
+function tParameterSimplex.minKreuzungen: longint;
+begin
+ result:=Kreuzungens[Reihenfolge[0]];
+end;
+
+function tParameterSimplex.maxKreuzungen: longint;
+begin
+ result:=Kreuzungens[Reihenfolge[dim]];
+end;
+
+function tParameterSimplex.minEnergie: extended;
+begin
+ result:=Energien[Reihenfolge[0]];
+end;
+
+function tParameterSimplex.maxEnergie: extended;
+begin
+ result:=Energien[Reihenfolge[dim]];
+end;
+
+procedure tParameterSimplex.printHistogramm;
+var i: longint;
+ hist: tIntArray;
+begin
+ setlength(hist,Kreuzungens[Reihenfolge[dim]]-Kreuzungens[Reihenfolge[0]]+1);
+ for i:=0 to length(hist)-1 do
+ hist[i]:=0;
+ for i:=0 to length(Kreuzungens)-1 do
+ inc(hist[Kreuzungens[i]-Kreuzungens[Reihenfolge[0]]]);
+ for i:=0 to length(hist)-1 do
+ writeln(Kreuzungens[Reihenfolge[0]]+i,': ',hist[i]);
+end;
+
+function tParameterSimplex.mittlereKantenlaenge: extended;
+var
+ mat: array of tExtendedArray;
+ i,j: longint;
+begin
+ setlength(mat,dim);
+ for i:=0 to dim-1 do begin
+ setlength(mat[i],dim);
+ for j:=0 to dim-1 do
+ mat[i,j]:=Ecken[i+1,j]-Ecken[0,j];
+ end;
+ result:=rootDet(mat);
+ for i:=0 to length(mat)-1 do
+ setlength(mat[i],0);
+ setlength(mat,0);
+end;
+
+procedure tParameterSimplex.printSpur(nam: string; von,nach: longint);
+var
+ ps,step: tExtendedArray;
+ i,j,krzgn: longint;
+ ener,dx: extended;
+ f: textfile;
+const
+ Schritte = 10000;
+begin
+ if fileexists(nam) then begin
+ writeln('*** Fehler ***');
+ writeln(' Datei '''+nam+''' existiert bereits!');
+ halt;
+ end;
+ setlength(ps,pdim);
+ setlength(step,dim);
+ dx:=0;
+ for i:=0 to dim-1 do begin
+ step[i]:=(Ecken[nach,i]-Ecken[von,i])/(Schritte-1);
+ dx:=dx+sqr(step[i]);
+ end;
+
+ dx:=sqrt(dx);
+
+ for i:=0 to pdim-1 do
+ ps[i]:=0;
+
+ assignfile(f,nam);
+ rewrite(f);
+ for i:=0 to Schritte-1 do begin
+ for j:=0 to dim-1 do
+ ps[j]:=Ecken[von,j]+i*step[j];
+ md.berechneAbhaengigeVariable(ps);
+ ener:=md.Energie(ps,krzgn,j);
+ writeln(f,inttostr(i)+#9+inttostr(krzgn)+#9+myfloattostr(ener)+#9+myfloattostr(i*dx));
+ end;
+ closefile(f);
+end;
+
+// ******************************** TStabile ****************************************************
+
+procedure TStabile.setzeFamilie(Fam: tFamilie; x,y,dist,lambda: extended; var P: tExtendedArray);
+var Rtg,Rx,Ry: extended;
+begin
+ Rtg:=random*2*pi;
+ Rx:=dist*cos(Rtg);
+ Ry:=dist*sin(Rtg);
+ P[Fam.Eltern[0].P1]:=x+Rx*Lambda;
+ P[Fam.Eltern[0].P2]:=y+Ry*Lambda;
+ P[Fam.Eltern[1].P1]:=x+Rx*(1-Lambda);
+ P[Fam.Eltern[1].P2]:=y+Ry*(1-Lambda);
+end;
+
+constructor TStabile.create;
+begin
+ create(nil);
+end;
+
+constructor TStabile.create(MetaData: TMetaData);
+begin
+ inherited create;
+ NotAus:=TNotAus.create;
+ if assigned(MetaData) then
+ MD:=MetaData
+ else
+ MD:=TMetaData.create;
+ setlength(Parameter,MD.ParameterLaenge);
+ Schritte:=0;
+ Laufzeit:=0;
+ stepsize:=minSchrittweite;
+end;
+
+destructor TStabile.destroy;
+begin
+ Setlength(Parameter,0);
+ MD.free;
+ NotAus.destroy;
+ inherited destroy;
+end;
+
+procedure TStabile.printStatus(Level: Longint);
+var
+ I,J,K: Longint;
+ laeng,kuerz,tmp: Extended;
+begin
+ if (Level<0) or (Level>9) then
+ begin
+ writeln('Illegales Argument für Funktionsaufruf von TStabile.printStatus!');
+ exit;
+ end;
+ if not assigned(MD) then
+ begin
+ writeln('Keine Metadaten vorhanden!');
+ exit;
+ end;
+ if (Level=3) and not NotAus.Stati[Level] then dec(Level);
+ if not NotAus.Stati[Level] then exit;
+ case Level of
+ 0..4: MD.printStatus(Level);
+ 5:
+ begin
+ Laeng:=-1;
+ Kuerz:=2;
+ J:=0;
+ K:=0;
+ for I:=0 to length(MD.Familien)-1 do
+ begin
+ tmp:=
+ sqr(
+ Parameter[MD.Familien[I].Eltern[0].P1] -
+ Parameter[MD.Familien[I].Eltern[1].P1]) +
+ sqr(
+ Parameter[MD.Familien[I].Eltern[0].P2] -
+ Parameter[MD.Familien[I].Eltern[1].P2]);
+ if tmp>Laeng then
+ begin
+ Laeng:=tmp;
+ J:=I;
+ end;
+ if tmp<Kuerz then
+ begin
+ Kuerz:=tmp;
+ K:=I;
+ end;
+ end;
+ write(
+ inttostr(Level)+') '+'Längste Beziehung: '+myfloattostr(sqrt(Laeng))+' ');
+ write(MD.Familien[J].Eltern[0].Vorname);
+ write(' und ');
+ write(MD.Familien[J].Eltern[1].Vorname);
+ write(' ');
+ writeln('"'+MD.Familien[J].Eltern[1].Nachname+'"');
+ writeln(MD.Familien[J].Eltern[0].Nachname);
+ write(
+ inttostr(Level)+') '+'Kürzeste Beziehung: '+myfloattostr(sqrt(Kuerz))+' ');
+ write(MD.Familien[K].Eltern[0].Vorname);
+ write(' und ');
+ write(MD.Familien[K].Eltern[1].Vorname);
+ write(' ');
+ writeln('"'+MD.Familien[K].Eltern[1].Nachname+'"');
+ writeln(MD.Familien[K].Eltern[0].Nachname);
+ end;
+ 7:
+ writeln(inttostr(Level)+') '+inttostr(Schritte)+' '+myfloattostr(Energie)+' '+inttostr(Kreuzungen)+' Kreuzungen');
+ end{of case};
+end;
+
+procedure TStabile.assignMetaData(MetaData: TMetaData);
+begin
+ MD:=MetaData;
+ Setlength(Parameter,MD.ParameterLaenge);
+end;
+
+function TStabile.ladeXML(Datei: String): boolean;
+(*var
+ i,j: longint; *)
+begin
+ result:=MD.ladeXML(Datei);
+ md.konsistenzTest(false);
+(*
+ for i:=length(MD.Familien)-1 downto 1 do begin
+ MD.Familien[length(MD.Familien)-1].free;
+ setlength(MD.Familien,length(MD.Familien)-1);
+ MD.konsistenztest;
+ end;
+
+ writeln(inttostr(length(MD.Familien))+' '+inttostr(length(MD.Personen)));
+
+ for i:=length(MD.Personen)-1 downto 0 do
+ if (not assigned(MD.Personen[i].KindIn)) and
+ (length(MD.Personen[i].ElterIn)=0) then begin
+ MD.Personen[i].Free;
+ for j:=i+1 to length(MD.Personen)-1 do
+ MD.Personen[j-1]:=MD.Personen[j];
+ setlength(MD.Personen,length(MD.Personen)-1);
+ end;
+
+ writeln(inttostr(length(MD.Familien))+' '+inttostr(length(MD.Personen))); *)
+
+
+(* writeln(inttostr(length(MD.Familien))+' '+inttostr(length(MD.Personen)));
+ for i:=0 to 39 do begin
+ MD.Familien[length(MD.Familien)-1].free;
+ setlength(MD.Familien,length(MD.Familien)-1);
+ MD.konsistenztest;
+ MD.blaetterAbschneiden;
+ MD.konsistenztest;
+ MD.nurGroeszteZusammenhangskomponente;
+ MD.konsistenztest;
+ writeln(inttostr(length(MD.Familien))+' '+inttostr(length(MD.Personen)));
+ end; *)
+end;
+
+procedure TStabile.generiereFehlendeInfos;
+begin
+ md.generiereFehlendeInfos;
+ md.konsistenzTest(true);
+end;
+
+procedure TStabile.nurGroeszteZusammenhangskomponente;
+begin
+ md.nurGroeszteZusammenhangskomponente;
+ md.konsistenzTest(false);
+end;
+
+procedure TStabile.blaetterAbschneiden;
+begin
+ writeln('Blätter abschneiden ('+inttostr(md.anzUnabhaengig)+' bzw. '+inttostr(md.ParameterLaenge)+') ...');
+ md.indizesErzeugen;
+ md.konsistenzTest(true);
+ md.blaetterAbschneiden;
+ md.konsistenzTest(true);
+ writeln('... fertig ('+inttostr(md.anzUnabhaengig)+' bzw. '+inttostr(md.ParameterLaenge)+')');
+end;
+
+function TStabile.analysiereInteraktionen: boolean;
+begin
+ result:=MD.analysiereInteraktionen;
+ if result then
+ setlength(Parameter,MD.ParameterLaenge);
+end;
+
+function TStabile.LadeVonDatei(Datei: String): boolean;
+var
+ f: tmyStringList;
+ s: String;
+ i,j: longint;
+begin
+ result:=false;
+ writeln('Lade von '''+Datei+''' ...');
+ f:=tMyStringList.create;
+ if copy(Datei,length(Datei)-3,4)='.txt' then
+ f.loadFromFile(Datei)
+ else
+ f.loadFromGz(Datei);
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if s<>'Stabile-Zwischenzustand (menschenlesbar, aber nicht unbedingt menschenverstehbar)' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,9)<>'Schritte ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,9);
+ Schritte:=strtoint(s);
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,9)<>'stepsize ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,9);
+ stepsize:=mystrtofloat(s);
+ for i:=0 to 9 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftstr(s,9)<>'Stati['+inttostr(i)+'] ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,9);
+ NotAus.Stati[i]:=s='1';
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,9)<>'Laufzeit ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,9);
+ Laufzeit:=mystrtofloat(s);
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,19)<>'length(Ereignisse) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,19);
+ j:=strtoint(s);
+ for i:=0 to j-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Ereignisse['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Ereignisse['+inttostr(i)+'] '));
+ ImportEreignis(s,MD.Ereignisse);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,17)<>'length(Personen) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,17);
+ j:=strtoint(s);
+ for i:=0 to j-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Personen['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Personen['+inttostr(i)+'] '));
+ ImportPerson(s,MD.Personen,MD.Ereignisse,MD.Familien);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,17)<>'length(Familien) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,17);
+ j:=strtoint(s);
+ for i:=0 to j-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Familien['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Familien['+inttostr(i)+'] '));
+ ImportFamilie(s,MD.Personen,MD.Ereignisse,MD.Familien);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,12)<>'Unabhaengig ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,12);
+ MD.ParameterLaenge:=length(s);
+ setlength(MD.ParameterAttribute,MD.ParameterLaenge);
+ for i:=0 to length(MD.ParameterAttribute)-1 do
+ MD.ParameterAttribute[i].fromChar(s[i+1]);
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,18)<>'length(Parameter) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,18);
+ if length(MD.Parameterattribute)<>strtoint(s) then begin
+ writeln('Inkonsistenz in Datei '''+Datei+''': Parameterlänge ('+s+') unterscheidet sich von Anzahl der Parameterattribute ('+inttostr(length(MD.Parameterattribute))+')!');
+ f.free;
+ exit;
+ end;
+ setlength(Parameter,MD.ParameterLaenge);
+ for i:=0 to length(Parameter)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Parameter['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Parameter['+inttostr(i)+'] '));
+ Parameter[i]:=mystrtofloat(s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,23)<>'length(Verknuepfungen) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,23);
+ setlength(MD.Verknuepfungen,strtoint(s));
+ for i:=0 to length(MD.Verknuepfungen)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Verknuepfungen['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Verknuepfungen['+inttostr(i)+'] '));
+ MD.Verknuepfungen[i]:=strToTVerknuepfung(MD.Personen,s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,24)<>'length(MMInteraktionen) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,24);
+ setlength(MD.MMInteraktionen,strtoint(s));
+ for i:=0 to length(MD.MMInteraktionen)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('MMInteraktionen['+inttostr(i)+'] ',S)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('MMInteraktionen['+inttostr(i)+'] '));
+ MD.MMInteraktionen[i]:=importMMInteraktion(MD.Personen,s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,24)<>'length(MFInteraktionen) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,24);
+ setlength(MD.MFInteraktionen,strtoint(s));
+ for i:=0 to length(MD.MFInteraktionen)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('MFInteraktionen['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(S,1,length('MFInteraktionen['+inttostr(i)+'] '));
+ MD.MFInteraktionen[i]:=importMFInteraktion(MD.Personen,MD.Familien,s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,24)<>'length(FFInteraktionen) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,24);
+ setlength(MD.FFInteraktionen,strtoint(s));
+ for i:=0 to length(MD.FFInteraktionen)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('FFInteraktionen['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('FFInteraktionen['+inttostr(i)+'] '));
+ MD.FFInteraktionen[i]:=importFFInteraktion(MD.Familien,s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if leftStr(s,23)<>'length(Tauschfamilien) ' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,23);
+ setlength(MD.Tauschfamilien,strtoint(s));
+ for i:=0 to length(MD.Tauschfamilien)-1 do begin
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if pos('Tauschfamilien['+inttostr(i)+'] ',s)<>1 then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ delete(s,1,length('Tauschfamilien['+inttostr(i)+'] '));
+ MD.Tauschfamilien[i]:=findeFamilie(MD.Familien,s);
+ end;
+ if not f.readln(s) then begin
+ writeln('Unerwartetes Dateiende in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if s<>'Ende' then begin
+ writeln('Syntaxfehler in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+ if not f.eof then begin
+ writeln('Zu viele Daten in '''+Datei+'''!');
+ f.free;
+ exit;
+ end;
+
+ f.free;
+
+ writeln('... fertig');
+
+ MD.berechneAbhaengigeVariable(Parameter{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ Energie:=MD.Energie(Parameter,Kreuzungen,i{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ printStatus(7);
+ result:=true;
+end;
+
+function TStabile.SpeichereInDatei(Datei: String): boolean;
+var
+ f: tMyStringList;
+ i: longint;
+ s: string;
+begin
+ result:=not fileexists(Datei);
+ if not result then exit;
+ printStatus(7);
+ write('Speichere in '''+Datei+''' ...');
+ f:=tMyStringList.create;
+ f.add('Stabile-Zwischenzustand (menschenlesbar, aber nicht unbedingt menschenverstehbar)');
+ f.add('Schritte '+inttostr(Schritte));
+ f.add('stepsize '+myfloattostr(stepsize));
+ for I:=0 to 9 do
+ f.add('Stati['+inttostr(I)+'] '+inttostr(byte(NotAus.Stati[I])));
+ write('.');
+ f.add('Laufzeit '+myfloattostr(Laufzeit));
+ f.add('length(Ereignisse) '+inttostr(length(MD.Ereignisse)));
+ for I:=0 to length(MD.Ereignisse)-1 do
+ f.add('Ereignisse['+inttostr(I)+'] '+TEreignisToStr(MD.Ereignisse[I]));
+ write('.');
+ f.add('length(Personen) '+inttostr(length(MD.Personen)));
+ for I:=0 to length(MD.Personen)-1 do
+ f.add('Personen['+inttostr(I)+'] '+TPersonToStr(MD.Personen[I]));
+ write('.');
+ f.add('length(Familien) '+inttostr(length(MD.Familien)));
+ for I:=0 to length(MD.Familien)-1 do
+ f.add('Familien['+inttostr(I)+'] '+TFamilieToStr(MD.Familien[I]));
+ write('.');
+ setlength(s,length(MD.ParameterAttribute));
+ for I:=0 to length(MD.ParameterAttribute)-1 do
+ s[I+1]:=MD.ParameterAttribute[I].toChar;
+ write('.');
+ f.add('Unabhaengig '+s);
+ f.add('length(Parameter) '+inttostr(length(Parameter)));
+ for I:=0 to length(Parameter)-1 do
+ f.add('Parameter['+inttostr(I)+'] '+myfloattostr(Parameter[I]));
+ write('.');
+ f.add('length(Verknuepfungen) '+inttostr(length(MD.Verknuepfungen)));
+ for I:=0 to length(MD.Verknuepfungen)-1 do
+ f.add('Verknuepfungen['+inttostr(I)+'] '+TVerknuepfungToStr(MD.Verknuepfungen[I]));
+ write('.');
+ f.add('length(MMInteraktionen) '+inttostr(length(MD.MMInteraktionen)));
+ for I:=0 to length(MD.MMInteraktionen)-1 do
+ f.add('MMInteraktionen['+inttostr(I)+'] '+TMMInteraktionToStr(MD.MMInteraktionen[I]));
+ write('.');
+ f.add('length(MFInteraktionen) '+inttostr(length(MD.MFInteraktionen)));
+ for I:=0 to length(MD.MFInteraktionen)-1 do
+ f.add('MFInteraktionen['+inttostr(I)+'] '+TMFInteraktionToStr(MD.MFInteraktionen[I]));
+ write('.');
+ f.add('length(FFInteraktionen) '+inttostr(length(MD.FFInteraktionen)));
+ for I:=0 to length(MD.FFInteraktionen)-1 do
+ f.add('FFInteraktionen['+inttostr(I)+'] '+TFFInteraktionToStr(MD.FFInteraktionen[I]));
+ write('.');
+ f.add('length(Tauschfamilien) '+inttostr(length(MD.Tauschfamilien)));
+ for I:=0 to length(MD.Tauschfamilien)-1 do
+ f.add('Tauschfamilien['+inttostr(I)+'] '+PFamilieToStr(MD.Tauschfamilien[I]));
+ write('.');
+ f.add('Ende');
+ f.saveToGz(Datei);
+ writeln(' fertig');
+end;
+
+procedure TStabile.Initialisiere(Anzahl: Longint; Art: string);
+var
+ werDran,extraZufall: tIntArray; // werDran[wannDran[i].x] = i und
+ // wannDran[werDran[j]].x = j
+ wannDran: t4DPointArray; // 2 ^ -wannDran[i].y ist die eigene Sollbeziehungslänge;
+ // wannDrann[i].z ... abhängig von wem?;
+ // wannDran[i].u ...
+ // 0: als Vater abhängig, \
+ // 1: als Mutter abhängig, --> 0 & 1 können _innerhalb_ einer Familie getauscht sein
+ // 2: als Mann abhängig,
+ // 3: als Frau abhängig,
+ // 4: als Nachfahr abhängig
+ //Kreise: array of tPointArray; // x: Person, y: Familie
+ i,j,k,l,m,n,Luecken,Wurzel: longint;
+ Timer: tTimer;
+ gefunden,fertig: boolean;
+ its: array of tStabileInitThread;
+begin
+ Timer:=tTimer.create;
+ Timer.Start;
+ writeln('Initialisiere Parametersatz ...');
+
+ for k:=0 to length(MD.Personen)-1 do
+ MD.Personen[k].Index:=k;
+ for k:=0 to length(MD.Familien)-1 do
+ MD.Familien[k].Index:=k;
+ for k:=0 to length(MD.Ereignisse)-1 do
+ MD.Ereignisse[k].Index:=k;
+
+ if length(Art)=0 then Art:='i';
+ Schritte:=-1;
+ stepsize:=minSchrittweite;
+ setlength(Parameter,MD.ParameterLaenge);
+ Energie:=0;
+ Kreuzungen:=0;
+ for i:=1 to length(Art) do begin
+ if NotAus.istZuende then break;
+ case Art[i] of
+ 'b': begin
+ if (i=1) or (Art[i]<>Art[i-1]) then writeln(' - auf Bäume optimiert:');
+ Wurzel:=-1;
+ Luecken:=length(MD.Personen);
+ for j:=0 to length(MD.Personen)-1 do begin
+ for k:=0 to length(Parameter)-1 do
+ Parameter[k]:=-1;
+ Parameter[MD.Personen[j].P1]:=1;
+ Parameter[MD.Personen[j].P2]:=1;
+ for k:=length(MD.Verknuepfungen)-1 downto 0 do
+ if Parameter[MD.Verknuepfungen[k].Output['x']]>0 then begin
+ Parameter[MD.Verknuepfungen[k].Input[0,'x']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[0,'y']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[1,'x']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[1,'y']]:=1;
+ end;
+ for k:=0 to length(MD.Verknuepfungen)-1 do
+ if (Parameter[MD.Verknuepfungen[k].Input[0,'x']]>0) or
+ (Parameter[MD.Verknuepfungen[k].Input[1,'x']]>0) then begin
+ Parameter[MD.Verknuepfungen[k].Output['x']]:=1;
+ Parameter[MD.Verknuepfungen[k].Output['y']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[0,'x']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[0,'y']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[1,'x']]:=1;
+ Parameter[MD.Verknuepfungen[k].Input[1,'y']]:=1;
+ end;
+ l:=0;
+ for k:=0 to length(MD.Personen)-1 do
+ if Parameter[MD.Personen[k].P1]<0 then
+ inc(l);
+ if (Wurzel=-1) or (l<Luecken) then begin
+ Wurzel:=j;
+ Luecken:=l;
+ end;
+ end;
+ writeln(' ('+
+ MD.Personen[Wurzel].Vorname+' '+
+ MD.Personen[Wurzel].Nachname+
+ ', Lücken: '+inttostr(Luecken)+')');
+(* if Art[i]='i' then begin
+ writeln('Kreise suchen ...');
+ Kreise:=md.findeKreise;
+ writeln('... und '+inttostr(length(Kreise))+' Kreise gefunden!');
+ for j:=0 to length(Kreise)-1 do
+ write(length(Kreise[j]),' ');
+ if length(Kreise)>0 then begin
+ writeln;
+ j:=20;
+ while (not keypressed) and (j>0) do begin
+ sleep(100);
+ dec(j);
+ end;
+ if keypressed then
+ case readkey of
+ #27,'q': halt;
+ #13: begin
+ for j:=0 to length(Kreise)-1 do begin
+ writeln;
+ for k:=0 to length(Kreise[j])-1 do
+ writeln(md.Personen[Kreise[j,k].x].Vorname+' '+md.Personen[Kreise[j,k].x].Nachname+' ('+inttostr(Kreise[j,k].x)+')<--->('+inttostr(Kreise[j,k].y)+') Familie '+md.Familien[Kreise[j,k].y].Eltern[0].Nachname+' ('+md.Familien[Kreise[j,k].y].Eltern[1].Nachname+')');
+ if readkey in [#27,'q'] then halt;
+ end;
+ halt;
+ end;
+ end{of case};
+ end;
+ end; *)
+
+ // Es folgt die Initialisierung von wannDran, werDran und extraZufall
+
+ setlength(extraZufall,0);
+ setlength(werDran,length(MD.Personen));
+ setlength(wannDran,length(MD.Personen));
+ for k:=0 to length(werDran)-1 do begin
+ werDran[k]:=-1;
+ wannDran[k].x:=-1;
+ wannDran[k].y:=-1;
+ wannDran[k].z:=-1;
+ wannDran[k].u:=-1;
+ end;
+ werDran[0]:=Wurzel;
+ wannDran[Wurzel].x:=0;
+ wannDran[Wurzel].y:=2;
+ wannDran[Wurzel].z:=-1;
+ wannDran[Wurzel].u:=-1;
+
+ m:=1;
+ while (m<length(wannDran)) and not NotAus.istZuende do begin // Zweierpotenzen verteilen
+ gefunden:=false;
+ for k:=0 to length(MD.Familien)-1 do // von den Nachfahren zu den Vorfahren
+ with MD.Familien[k] do
+ if (wannDran[Eltern[0].Index].x=-1) and
+ (wannDran[Eltern[1].Index].x=-1) then // beide Elternteile sind noch nicht dran gewesen
+ for l:=0 to length(Kinder)-1 do
+ if wannDran[Kinder[l].Index].x<>-1 then begin // dieses Kind war schon dran
+ if (wannDran[Eltern[0].Index].x<>-1) and
+ (wannDran[Eltern[1].Index].x<>-1) then begin // ein anderes Kind hat die Eltern schon fixiert (relativ selten)
+ if j=1 then
+ writeln('doppelt bestimmt: '+Eltern[0].Vorname+' '+Eltern[0].Nachname+' und '+Eltern[1].Vorname+' '+Eltern[1].Nachname+' -> ['+inttostr(Kinder[l].Index)+'] '+inttostr(wannDran[Kinder[l].Index].x));
+ setlength(extraZufall,length(extraZufall)+1);
+ extraZufall[length(extraZufall)-1]:=Kinder[l].P3;
+ continue;
+ end;
+ for n:=0 to 1 do begin
+ wannDran[Eltern[n].Index].x:=m;
+ wannDran[Eltern[n].Index].y:=wannDran[Kinder[l].Index].y+1; // 1/2 so lang wie das Kind
+ wannDran[Eltern[n].Index].z:=Kinder[l].Index;
+ wannDran[Eltern[n].Index].u:=n;
+ werDran[m]:=Eltern[n].Index;
+ inc(m);
+ end;
+ gefunden:=true;
+ end;
+ if gefunden then continue; // Solange von den Nachfahren zu den Vorfahren was gefunden wurde, wird da auch noch mal gesucht!
+ for k:=0 to length(MD.Familien)-1 do // von den Vorfahren zu den Nachfahren
+ with MD.Familien[k] do
+ if (wannDran[Eltern[0].Index].x<>-1) and
+ (wannDran[Eltern[1].Index].x<>-1) then begin // beide Elternteile sind schon dran gewesen
+ for l:=0 to length(Kinder)-1 do
+ if wannDran[Kinder[l].Index].x=-1 then begin // dieses Kind war noch nicht dran
+ wannDran[Kinder[l].Index].x:=m;
+ wannDran[Kinder[l].Index].y:=max(wannDran[Eltern[0].Index].y,wannDran[Eltern[1].Index].y);
+ wannDran[Kinder[l].Index].z:=k; // nur hier indiziert .z die Familie !!! (ansonsten Personen)
+ wannDran[Kinder[l].Index].u:=4;
+ werDran[m]:=Kinder[l].Index;
+ inc(m);
+ gefunden:=true;
+ break;
+ end;
+ if gefunden then break;
+ end;
+ if gefunden then continue; // Solange von den Vorfahren zu den Nachfahren was gefunden wurde, wird noch mal gesucht!
+ n:=-1;
+ for k:=0 to length(MD.Familien)-1 do // von Partner zu Partner
+ with MD.Familien[k] do
+ if ((wannDran[Eltern[0].Index].x<>-1) xor
+ (wannDran[Eltern[1].Index].x<>-1)) and // genau ein Elternteil schon dran gewesen
+ ((n=-1) or
+ (MD.Familien[n].Anfang.Jahr > Anfang.Jahr)) then // Familie ist älter
+ n:=k;
+ if n<>-1 then
+ with MD.Familien[n] do begin
+ if (wannDran[Eltern[0].Index].x=-1) then begin // Vater noch nicht dran gewesen
+ wannDran[Eltern[0].Index].x:=m;
+ wannDran[Eltern[0].Index].y:=wannDran[Eltern[1].Index].y+1; // 1/2 so lang wie die andere Ehe der Frau
+ wannDran[Eltern[0].Index].z:=Eltern[1].Index;
+ wannDran[Eltern[0].Index].u:=2;
+ werDran[m]:=Eltern[0].Index;
+ gefunden:=true;
+ inc(m);
+ end;
+ if wannDran[Eltern[1].Index].x=-1 then begin // Mutter noch nicht dran gewesen
+ wannDran[Eltern[1].Index].x:=m;
+ wannDran[Eltern[1].Index].y:=wannDran[Eltern[0].Index].y+1; // 1/2 so lang wie die andere Ehe des Mannes
+ wannDran[Eltern[1].Index].z:=Eltern[0].Index;
+ wannDran[Eltern[1].Index].u:=3;
+ werDran[m]:=Eltern[1].Index;
+ gefunden:=true;
+ inc(m);
+ end;
+ end;
+ if gefunden then continue;
+ writeln('*** Fehler *** Manche Personen gehören nicht in die Zusammenhangskomponente der Wurzel!'); // sollte nicht passieren, wurde in ladeXML ggf. korrigiert!
+ for k:=0 to length(MD.Familien)-1 do
+ with MD.Familien[k] do begin
+ gefunden:=false;
+ if (wannDran[Eltern[0].Index].x=-1) or
+ (wannDran[Eltern[1].Index].x=-1) then gefunden:=true;
+ for l:=0 to length(Kinder)-1 do
+ if wannDran[Kinder[l].Index].x=-1 then gefunden:=true;
+ if gefunden then begin
+ writeln('ID: '+ID);
+ writeln(' '+inttostr(wannDran[Eltern[0].Index].x)+' '+Eltern[0].Vorname+' '+Eltern[0].Nachname+' '+inttostr(Eltern[0].Anfang.Jahr));
+ writeln(' '+inttostr(wannDran[Eltern[0].Index].x)+' '+Eltern[1].Vorname+' '+Eltern[1].Nachname+' '+inttostr(Eltern[1].Anfang.Jahr));
+ writeln(' '+inttostr(length(Kinder))+' Kinder');
+ for l:=0 to length(Kinder)-1 do
+ with Kinder[l] do
+ writeln(' '+inttostr(l)+' '+inttostr(wannDran[Index].x)+' '+' '+Vorname+' '+Nachname+' '+inttostr(Anfang.Jahr));
+ writeln;
+ end;
+ end;
+ halt;
+ end;
+
+ for k:=0 to length(wannDran)-1 do
+ if werDran[wannDran[k].x]<>k then begin
+ writeln('Fehler: werDran[wannDran['+inttostr(k)+'].x]<>'+inttostr(k));
+ halt;
+ end;
+ for k:=0 to length(werDran)-1 do
+ if wannDran[werDran[k]].x<>k then begin
+ writeln('Fehler: wannDran[werDran['+inttostr(k)+']].x<>'+inttostr(k));
+ halt;
+ end;
+ end;
+ 'M': if (i=1) or (Art[i]<>Art[i-1]) then writeln(' - zufällig:');
+ else begin
+ writeln('Den Parameter '''+Art[i]+''' kenne ich nicht!');
+ exit;
+ end;
+ end{of Case};
+
+ setlength(its,max(2,momentanFreieCpus-1));
+ for j:=0 to length(its)-1 do
+ its[j]:=tStabileInitThread.create(self,werDran,extraZufall,wannDran,Art[i],(Anzahl div length(its)) + (Anzahl mod length(its))*byte(j=length(its)));
+
+ for j:=0 to length(its)-1 do
+ its[j].suspended:=false;
+
+ repeat
+ sleep(10);
+ fertig:=true;
+ for j:=0 to length(its)-1 do
+ fertig:=fertig and its[j].fertig;
+ until fertig;
+
+ if not NotAus.istZuende then begin
+ k:=0;
+ for j:=1 to length(its)-1 do
+ if (its[j].Kreuzungen<its[k].Kreuzungen) or
+ ((its[j].Kreuzungen=its[k].Kreuzungen) and
+ (its[j].Energie<its[k].Energie)) then
+ k:=j;
+
+ Energie:=its[k].Energie;
+ Kreuzungen:=its[k].Kreuzungen;
+ for j:=0 to length(Parameter)-1 do
+ Parameter[j]:=its[k].Parameter[j];
+ end;
+
+ for j:=0 to length(its)-1 do
+ its[j].free;
+ setlength(its,0);
+ end;
+ writeln('... fertig');
+ Laufzeit:=Laufzeit+Timer.gibZeit;
+ Timer.free;
+end;
+
+procedure TStabile.optimiere;
+var
+ Timer: TTimer;
+ i,j,k,NKreuzung,Kreuzung,NK: longint;
+ c: char;
+ NP,Richtung: TExtendedArray;
+ abhaengiges: TBooleanArray;
+ Perm: TIntArray;
+ Ax,Ay,Rx,Ry,tmp,sz,gesamtSchritt: extended;
+ echtePermutation,wasGefunden,TauschenErlauben: boolean;
+begin
+ Timer:=tTimer.create;
+ Timer.Start;
+ writeln('Starte Optimierung ...');
+ setlength(abhaengiges,MD.ParameterLaenge);
+ setlength(NP,MD.ParameterLaenge);
+ setlength(Richtung,MD.ParameterLaenge);
+ TauschenErlauben:=true;
+ Kreuzung:=-1;
+ NKreuzung:=-1;
+ while not NotAus.istZuende do
+ begin
+ inc(Schritte);
+ stepsize:=max(minSchrittweite,stepsize/power(schrittweitenmultiplikator,sollABAnteil));
+ for c:='a' to 'f' do
+ begin
+ if NotAus.istZuende then break;
+ case c of
+ 'a':
+ begin
+ for I:=0 to length(NP)-1 do
+ if random*SchrittweitenSchwelle < stepSize then
+ NP[I]:=min(1,max(0,Parameter[I]+max(stepsize,SchrittweitenSchwelle)*(random-0.5)));
+ end;
+ 'b':
+ begin
+ for I:=0 to length(NP)-1 do
+ begin
+ tmp:=NP[I]-Parameter[I];
+ NP[I]:=min(1,max(0,Parameter[I]-tmp));
+ end;
+ end;
+ 'c'..'f':
+ begin
+ if (Kreuzungen=0) or not TauschenErlauben then continue;
+ for I:=0 to length(NP)-1 do
+ abhaengiges[I]:=false;
+ for I:=0 to 1 do begin
+ abhaengiges[MD.FFInteraktionen[Kreuzung]._Fs[I].Eltern[WenTauschen[ord(C)-ord('c'),I]].P1]:=true;
+ abhaengiges[MD.FFInteraktionen[Kreuzung]._Fs[I].Eltern[WenTauschen[ord(C)-ord('c'),I]].P2]:=true;
+ end;
+ repeat
+ wasGefunden:=false;
+ for I:=0 to length(MD.Verknuepfungen)-1 do
+ if (abhaengiges[MD.Verknuepfungen[I].Output['x']] or
+ abhaengiges[MD.Verknuepfungen[I].Output['y']]) and
+ not abhaengiges[MD.Verknuepfungen[I].Input[0,'x']] then begin
+ wasGefunden:=true;
+ abhaengiges[MD.Verknuepfungen[I].Input[0,'x']]:=true;
+ abhaengiges[MD.Verknuepfungen[I].Input[0,'y']]:=true;
+ abhaengiges[MD.Verknuepfungen[I].Input[1,'x']]:=true;
+ abhaengiges[MD.Verknuepfungen[I].Input[1,'y']]:=true;
+ end;
+ until not wasGefunden;
+ Ax:=
+ (Parameter[MD.FFInteraktionen[Kreuzung]._Fs[0].Eltern[WenTauschen[ord(C)-ord('c'),0]].P1]+
+ Parameter[MD.FFInteraktionen[Kreuzung]._Fs[1].Eltern[WenTauschen[ord(C)-ord('c'),1]].P1]);
+ Ay:=
+ (Parameter[MD.FFInteraktionen[Kreuzung]._Fs[0].Eltern[WenTauschen[ord(C)-ord('c'),0]].P2]+
+ Parameter[MD.FFInteraktionen[Kreuzung]._Fs[1].Eltern[WenTauschen[ord(C)-ord('c'),1]].P2]);
+ Rx:=
+ (Parameter[MD.FFInteraktionen[Kreuzung]._Fs[0].Eltern[WenTauschen[ord(C)-ord('c'),0]].P2]-
+ Parameter[MD.FFInteraktionen[Kreuzung]._Fs[1].Eltern[WenTauschen[ord(C)-ord('c'),1]].P2]);
+ Ry:=
+ (Parameter[MD.FFInteraktionen[Kreuzung]._Fs[1].Eltern[WenTauschen[ord(C)-ord('c'),1]].P1]-
+ Parameter[MD.FFInteraktionen[Kreuzung]._Fs[0].Eltern[WenTauschen[ord(C)-ord('c'),0]].P1]);
+ tmp:=sqrt(sqr(Rx)+sqr(Ry));
+ Rx:=Rx/max(epsilon,tmp);
+ Ry:=Ry/max(epsilon,tmp);
+ for I:=0 to length(Parameter)-1 do
+ NP[I]:=Parameter[I];
+ for I:=0 to length(MD.Personen)-1 do
+ if abhaengiges[MD.Personen[I].P1] then begin
+ tmp:=(Rx * (Ax - NP[MD.Personen[I].P1]) + Ry * (Ay - NP[MD.Personen[I].P2]));
+ NP[MD.Personen[I].P1]:=
+ NP[MD.Personen[I].P1] + Rx * tmp;
+ NP[MD.Personen[I].P2]:=
+ NP[MD.Personen[I].P2] + Ry * tmp; // eine Spiegelung an der Geraden durch A[x,y], senkrecht zu R[x,y]
+(* tmp:=
+ Ax
+ + 2*((NP[MD.Personen[I].P1]-Ax)*Rx + (NP[MD.Personen[I].P2]-Ay)*Ry)*Rx
+ - (NP[MD.Personen[I].P1]-Ax);
+ NP[MD.Personen[I].P2]:=
+ Ay
+ + 2*((NP[MD.Personen[I].P1]-Ax)*Rx + (NP[MD.Personen[I].P2]-Ay)*Ry)*Ry
+ - (NP[MD.Personen[I].P2]-Ay); *)
+ NP[MD.Personen[I].P1]:=tmp;
+// NP[MD.Personen[I].P1]:=min(1,max(0,NP[MD.Personen[I].P1]));
+// NP[MD.Personen[I].P2]:=min(1,max(0,NP[MD.Personen[I].P2]));
+ if (NP[MD.Personen[I].P1]<0) or (NP[MD.Personen[I].P1]>1) or
+ (NP[MD.Personen[I].P2]<0) or (NP[MD.Personen[I].P2]>1) then begin
+ ax:=NP[MD.Personen[I].P1];
+ ay:=NP[MD.Personen[I].P2];
+ rx:=ax;
+ ry:=ay;
+ for j:=0 to length(MD.Personen)-1 do
+ if MD.Parameterattribute[MD.Personen[j].P1].istUnabhaengig then begin
+ ax:=min(ax,NP[MD.Personen[j].P1]);
+ ay:=min(ay,NP[MD.Personen[j].P2]);
+ rx:=max(rx,NP[MD.Personen[j].P1]);
+ ry:=max(ry,NP[MD.Personen[j].P2]);
+ end;
+ rx:=1/max(rx-ax,epsilon);
+ ry:=1/max(ry-ay,epsilon);
+ for j:=0 to length(MD.Personen)-1 do begin
+ NP[MD.Personen[j].P1]:=(NP[MD.Personen[j].P1]-ax)*rx;
+ NP[MD.Personen[j].P2]:=(NP[MD.Personen[j].P2]-ay)*ry;
+ end;
+ end;
+ abhaengiges[MD.Personen[I].P1]:=false;
+ abhaengiges[MD.Personen[I].P2]:=false;
+ end;
+ end;
+ 'g'..'z':
+ begin
+ TauschenErlauben:=Kreuzungen>100;
+ if length(MD.Tauschfamilien)=0 then break;
+ for I:=0 to length(Parameter)-1 do
+ NP[I]:=Parameter[I];
+ I:=Random(length(MD.Tauschfamilien));
+ if odd(ord(c)-ord('g')) then
+ begin //nur zwei permutieren
+ J:=random(length(MD.Tauschfamilien[I].Kinder));
+ K:=random(length(MD.Tauschfamilien[I].Kinder)-1);
+ K:=K+Byte(K>=J);
+ NP[MD.Personen[J].P3]:=Parameter[MD.Personen[K].P3];
+ NP[MD.Personen[K].P3]:=Parameter[MD.Personen[J].P3];
+ echtePermutation:=false;
+ end
+ else
+ begin //beliebige Permutation
+ Perm:=Permutation(length(MD.Tauschfamilien[I].Kinder));
+ J:=0;
+ for K:=0 to length(Perm)-1 do
+ J:=J+Byte(Perm[K]<>K);
+ echtePermutation:=J>2;
+ for K:=0 to length(Perm)-1 do
+ NP[MD.Tauschfamilien[I].Kinder[Perm[K]].P3]:=
+ Parameter[MD.Tauschfamilien[I].Kinder[K].P3];
+ end;
+ end;
+ end{of case};
+ MD.berechneAbhaengigeVariable(NP{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ tmp:=MD.Energie(NP,NK,NKreuzung{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ if Kreuzung<0 then
+ Kreuzung:=NKreuzung;
+ if (c in ['a'..'b']) and NotAus.Stati[6] then
+ writeln('6) '+c+' ',tmp,' ',NK,' Kreuzungen (',stepsize,')');
+ if
+ (Kreuzungen>NK) or
+ ((tmp<Energie) and
+ (Kreuzungen=NK)) then
+ begin
+ TauschenErlauben:=true;
+ Energie:=tmp;
+ Kreuzungen:=NK;
+ Kreuzung:=NKreuzung;
+ if (c<='b') and ((exp(Kreuzungen)-1)*random<=Byte(Kreuzungen<4)) then
+ begin
+ for I:=0 to length(Parameter)-1 do
+ begin
+ Richtung[I]:=NP[I]-Parameter[I];
+ Parameter[I]:=NP[I];
+ end;
+ sz:=1;
+ j:=0;
+ gesamtSchritt:=1;
+ repeat
+ for I:=0 to length(Parameter)-1 do
+ NP[I]:=Parameter[I]+sz*Richtung[I];
+ MD.berechneAbhaengigeVariable(NP{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ tmp:=MD.Energie(NP,NK,NKreuzung{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ if
+ (Kreuzungen>NK) or
+ ((tmp<Energie) and
+ (Kreuzungen=NK)) then
+ begin
+ inc(j);
+ TauschenErlauben:=true;
+ Energie:=tmp;
+ Kreuzungen:=NK;
+ Kreuzung:=NKreuzung;
+ for I:=0 to length(Parameter)-1 do
+ Parameter[I]:=NP[I];
+ gesamtSchritt:=gesamtSchritt+sz;
+ sz:=sz*1.2;
+ end
+ else
+ sz:=-sz/1.05;
+ until (abs(sz)<0.1) or NotAus.istZuende;
+ if NotAus.Stati[8] then
+ begin
+ write('8) '+inttostr(j)+' fach optimiert, insgesamt Faktor '+myfloattostr(gesamtSchritt)+' ');
+ j:=0;
+ for I:=0 to length(Richtung)-1 do
+ j:=j+Byte(Richtung[I]<>0);
+ writeln(inttostr(j)+'/'+inttostr(MD.ParameterLaenge)+' Parameter variiert');
+ end;
+ end
+ else
+ begin
+ for I:=0 to length(Parameter)-1 do
+ Parameter[I]:=NP[I];
+ end;
+ if NotAus.Stati[7] then
+ begin
+ write(char(ord(c)+(ord('A')-ord('a'))*Byte((c>='g') and echtePermutation)));
+ printStatus(7);
+ end;
+ printStatus(5);
+ if C<='b' then
+ stepsize:=min(0.5,stepsize*schrittweitenmultiplikator);
+ NotAus.istZuende;
+ break;
+ end;
+ if NotAus.istZuende then break;
+ end;
+ end;
+ Laufzeit:=Laufzeit+Timer.gibZeit;
+ Timer.free;
+end;
+
+procedure tStabile.downHillSimplex;
+var
+ Timer: tTimer;
+ off,tol,i,cnt,aPos: longint;
+ c: char;
+ erg: tSchrittErgebnis;
+ np: tExtendedArray;
+ mi,ma: extended;
+ Simplex: tParameterSimplex;
+const
+ startCnt = 100;
+begin
+ if notAus.istZuende then exit;
+ Timer:=tTimer.create;
+ Timer.Start;
+
+ writeln('Unabhängige Parameter normieren ...');
+ mi:=1;
+ ma:=0;
+ for i:=0 to md.ParameterLaenge-1 do
+ if md.Parameterattribute[i].istKoordinate and md.Parameterattribute[i].istUnabhaengig then begin
+ mi:=min(mi,Parameter[i]);
+ ma:=max(ma,Parameter[i]);
+ end;
+ ma:=0.5/(ma-mi);
+ mi:=mi - 0.25/ma;
+ for i:=0 to md.ParameterLaenge-1 do
+ if md.Parameterattribute[i].istKoordinate and md.Parameterattribute[i].istUnabhaengig then
+ Parameter[i]:=(Parameter[i]-mi)*ma;
+ writeln('... fertig');
+
+ writeln('Simplex initialisieren ...');
+ Simplex:=tParameterSimplex.create;
+ Simplex.md:=md;
+ Simplex.init(Parameter,max(1,momentanFreieCpus-1));
+ writeln('... fertig');
+ Simplex.printHistogramm;
+
+ cnt:=0;
+ off:=0;
+ c:='-';
+ tol:=10;
+ setlength(np,Simplex.pDim);
+ while not NotAus.istZuende do begin
+
+(* if Simplex.maxKreuzungen-Simplex.minKreuzungen>2 then begin
+ Simplex.printSpur('test.txt',Simplex.Reihenfolge[length(Simplex.Reihenfolge)-1],Simplex.Reihenfolge[0]);
+ Simplex.printHistogramm;
+ halt;
+ end; *)
+
+ aPos:=Simplex.Reihenfolge[Simplex.dim-off];
+ erg:=Simplex.SimplexSchritt(np,1,-0.2,1.1,1.25,off);
+ if (false and (cnt<=0.9*startCnt) and erg.besserAlsVorher) or (cnt<-startCnt) then begin
+ write(c+' '+inttostr(aPos)+'. Ecke ('+inttostr(off+1)+'. von hinten) ver');
+ if erg.besserAlsVorher then write('bess')
+ else write('schlecht');
+ write('ert');
+ if erg.Platzveraenderung<>0 then write(' ('+inttostr(erg.Platzveraenderung)+' Plätze)');
+ if erg.faktorNeutralisiert then write(' (Faktor neutralisiert)');
+ writeln(' '+inttostr(Simplex.minKreuzungen)+'..'+inttostr(Simplex.maxKreuzungen)+' Kreuzungen, Energie: '+myfloattostr(Simplex.minEnergie)+'..'+myfloattostr(Simplex.maxEnergie)+' Kantenlänge: '+myfloattostr(Simplex.mittlereKantenlaenge));
+ Simplex.printHistogramm;
+ cnt:=startCnt;
+ end;
+ dec(cnt);
+ case NotAus.lastKey of
+ 'v': begin
+ writeln('mittlere Simplex-Kantenlänge: '+myfloattostr(Simplex.mittlereKantenlaenge));
+ NotAus.lastKey:=#0;
+ end;
+ {$IFDEF detaillierteZeitanalyse}
+ 't': begin
+ writeln('Zeiten: ');
+ md.printTimer(' ');
+ NotAus.lastKey:=#0;
+ end;
+ {$ENDIF}
+ 'a': begin
+ cpuUtilization;
+ NotAus.lastKey:=#0;
+ write('Soll ich den Simplex neu an der beseten Ecke ausrichten? (j/n) ');
+ c:=readkey;
+ while not (c in ['j','J','n','N']) do begin
+ writeln;
+ writeln(''''+c+''' verstehe ich nicht, aber ich wiederhole die Frage gerne noch einmal:');
+ write('Soll ich den Simplex neu an der beseten Ecke ausrichten? (j/n) ');
+ c:=readkey;
+ end;
+ writeln;
+ if c in ['j','J'] then begin
+ writeln('Neu ausrichten ...');
+ Simplex.outit(Parameter);
+ Simplex.init(Parameter,max(1,momentanFreieCpus-1));
+ writeln('... fertig');
+ Simplex.printHistogramm;
+ end;
+ end;
+ 'm': begin
+ NotAus.lastKey:=#0;
+ writeln('belegter Speicher: '+inttostr(belegterSpeicher)+' kB');
+ end;
+ end{of case};
+ if (erg.Platzveraenderung>0) or (off>Simplex.dim-2) then begin // Platz gut gemacht, wir arbeiten uns von unten wieder hoch
+ tol:=10;
+ off:=0;
+ end
+ else if erg.Platzveraenderung<0 then // Platz verloren, wir füllen die Toleranz neu
+ tol:=10
+ else if erg.besserAlsVorher then begin // verbessert, aber kein Platz gut gemacht, Toleranz wird decrementiert
+ dec(tol);
+ if tol<=0 then begin
+ tol:=10;
+ inc(off);
+ end;
+ end
+ else begin // verschlechtert ohne Platzverlust, wir optimieren am nächsten rum
+ tol:=10;
+ inc(off);
+ end;
+ case c of
+ '-': c:='/';
+ '/': c:='|';
+ '|': c:='\';
+ '\': c:='-';
+ end;
+ end;
+ setlength(np,0);
+ Simplex.outit(Parameter); // Fortschritt auf Stabile übertragen
+
+ Simplex.free;
+ Laufzeit:=Laufzeit+Timer.gibZeit;
+ Timer.free;
+end;
+
+procedure tStabile.gradientenOptimierung;
+var
+ Timer: tTimer;
+ Gradient,step,alt,ganzAlt,semiAlt: tExtendedArray;
+ mi,ma,aEner,ener,gaEner,phi,tmp: extended;
+ i,aKrzgn,krzgn,gaKrzgn,
+ ocnt,cnt,gut,schlecht: longint;
+ vkn: tVerknuepfung;
+ modus,baMod: byte; // 0 = nur Eltern[0] einzufügen; 1 = nur Eltern[1] einzufügen; 2 = beide Eltern einzufügen; 3 = Kind einzufügen
+ neuP: tPerson;
+ neuF: tFamilie;
+(*
+ j: longint;
+ f: textfile; *)
+begin
+ if notAus.istZuende then exit;
+ Timer:=tTimer.create;
+ Timer.Start;
+
+ writeln('Unabhängige Parameter normieren ...');
+ mi:=1;
+ ma:=0;
+ for i:=0 to md.ParameterLaenge-1 do
+ if md.Parameterattribute[i].istKoordinate and
+ md.Parameterattribute[i].wirdBenutzt then begin
+ mi:=min(mi,Parameter[i]);
+ ma:=max(ma,Parameter[i]);
+ end;
+ ma:=0.5/(ma-mi);
+ mi:=mi - 0.25/ma;
+ for i:=0 to md.ParameterLaenge-1 do
+ if md.Parameterattribute[i].istKoordinate and
+ md.Parameterattribute[i].wirdBenutzt then
+ Parameter[i]:=(Parameter[i]-mi)*ma;
+ writeln('... fertig');
+
+ setlength(step,md.ParameterLaenge);
+ setlength(Gradient,md.ParameterLaenge);
+ setlength(alt,md.ParameterLaenge);
+
+ md.berechneAbhaengigeVariable(Parameter);
+ aEner:=md.Energie(Parameter,aKrzgn,i);
+
+ gaEner:=aEner;
+ gaKrzgn:=aKrzgn;
+ setlength(ganzAlt,length(Parameter));
+ setlength(semiAlt,length(Parameter));
+ for i:=0 to length(ganzAlt)-1 do begin
+ ganzAlt[i]:=Parameter[i];
+ semiAlt[i]:=Parameter[i];
+ end;
+
+(* md.Gradient(Parameter,Gradient);
+ md.GradientenRueckPropagation(Parameter,Gradient);
+
+ assignfile(f,'test.txt');
+ rewrite(f);
+ for i:=0 to md.Unabhaengig-1 do begin
+ if i<>0 then write(f,#9);
+ write(f,myfloattostr(Parameter[i]));
+ end;
+ writeln(f);
+ for i:=0 to md.Unabhaengig-1 do begin
+ if i<>0 then write(f,#9);
+ write(f,myfloattostr(Gradient[i]));
+ end;
+ writeln(f);
+ setlength(Gradient,length(Parameter));
+ for i:=-1 to md.Unabhaengig-1 do begin
+ for j:=0 to md.Unabhaengig-1 do
+ Gradient[j]:=Parameter[j]+1e-10*byte(i=j);
+ md.berechneAbhaengigeVariable(Gradient);
+ ener:=md.Energie(Gradient,krzgn,j);
+ write(f,myfloattostr(ener));
+ for j:=0 to md.Unabhaengig-1 do
+ write(f,#9+myfloattostr(Gradient[j]));
+ writeln(f);
+ end;
+
+ closefile(f);
+
+ halt; *)
+
+ baMod:=0;
+
+ repeat
+
+ cnt:=100;
+ gut:=0;
+ schlecht:=0;
+ ocnt:=3;
+
+ if baMod=1 then write('-');
+
+ while (not NotAus.istZuende) and ((baMod=2) or (aKrzgn>0) or (ocnt>0)) do begin
+ if (baMod=1) and
+ (aKrzgn>0) then write('!');
+
+ if baMod<=1 then begin
+ if aKrzgn=0 then
+ dec(ocnt)
+ else
+ ocnt:=3;
+ end;
+
+ md.Gradient(Parameter,Gradient);
+ md.GradientenRueckPropagation(Parameter,Gradient);
+
+ ma:=0;
+ for i:=0 to md.ParameterLaenge-1 do
+ if md.Parameterattribute[i].istUnabhaengig then
+ ma:=ma + sqr(Gradient[i]);
+ ma:=-stepsize/sqrt(ma);
+ tmp:=2*stepsize/(1+99*byte(baMod<>2));
+
+ for i:=0 to md.ParameterLaenge-1 do begin
+ alt[i]:=Parameter[i];
+ if md.Parameterattribute[i].istUnabhaengig then begin
+ step[i]:=Gradient[i]*ma + tmp*(random-0.5);
+ Parameter[i]:=min(1,max(0,Parameter[i]+step[i]));
+ end;
+ end;
+
+ md.berechneAbhaengigeVariable(Parameter);
+ ener:=md.Energie(Parameter,Krzgn,i);
+
+ if (krzgn>aKrzgn) or ((krzgn=aKrzgn) and (ener>aEner)) then begin
+ inc(schlecht);
+ if (0.5*stepsize<minSchrittweite) and
+ ((krzgn=0) or (baMod=2)) then begin
+ write('X');
+ aEner:=ener;
+ aKrzgn:=krzgn;
+ if stepsize=minSchrittweite then
+ break;
+ stepsize:=minSchrittweite;
+ end
+ else
+ for i:=0 to md.ParameterLaenge-1 do
+ Parameter[i]:=alt[i];
+ stepsize:=max(stepsize*0.5,minSchrittweite);
+ end
+ else begin
+ inc(gut);
+ stepsize:=min(stepsize*1.2,0.5);
+ aEner:=ener;
+ aKrzgn:=krzgn;
+ end;
+ dec(cnt);
+ if cnt<0 then begin
+ tmp:=0;
+ for i:=0 to length(ganzAlt)-1 do
+ tmp:=tmp+sqr(ganzAlt[i]-Parameter[i]);
+ write(' '+inttostr(aKrzgn)+' & '+myfloattostr(aEner)+' ('+myfloattostr(stepsize)+' '+inttostr(gut)+'/'+inttostr(schlecht)+' = '+myfloattostr(gut/(gut+schlecht))+') '+inttostr(gaKrzgn-aKrzgn)+' & '+myfloattostr(gaEner-aEner)+' <- '+myfloattostr(sqrt(tmp))+' / ');
+ tmp:=0;
+ for i:=0 to length(semiAlt)-1 do begin
+ tmp:=tmp+sqr(semiAlt[i]-Parameter[i]);
+ semiAlt[i]:=Parameter[i];
+ end;
+ writeln(myfloattostr(sqrt(tmp)));
+ gut:=0;
+ schlecht:=0;
+ cnt:=100;
+ end;
+ end;
+
+ if baMod=1 then begin
+ writeln(inttostr(aKrzgn)+' & '+myfloattostr(aEner)+' ('+myfloattostr(stepsize)+' '+inttostr(gut)+'/'+inttostr(schlecht)+' = '+myfloattostr(gut/(gut+schlecht))+')');
+ writeln(' '+inttostr(length(md.Laubhaufen))+' '+inttostr(md.anzUnbenutzt)+'/'+inttostr(md.ParameterLaenge));
+ end;
+
+ if NotAus.istZuende then continue;
+
+ if baMod=0 then begin
+ writeln('Alle Kreuzungen entfernt, füge den Rest wieder ein ...');
+ inc(baMod);
+ end;
+ if (baMod=1) and
+ ((not assigned(md.sicherung)) or
+ (length(md.Laubhaufen)=0)) then begin
+ writeln('Ursprünglicher Graph wieder hergestellt, optimiere noch weiter ...');
+ inc(baMod);
+ end;
+
+ if baMod=1 then begin
+ md.letztesBlattWiederAnkleben(vkn,neuP);
+
+ if not (assigned(vkn) or assigned(neuP)) then begin
+ writeln('*** Fehler ***');
+ writeln('Beim Einfügen des Blattes weder Person noch Verknüpfung zurückgegeben!');
+ halt;
+ end;
+
+ neuF:=nil;
+ if assigned(vkn) then begin
+ if assigned(neuP) then modus:=3 // Kind (=neuP) einzufügen
+ else begin
+ modus:=2; // beide Eltern einzufügen
+ neuP:=vkn.outP; // das Kind der Verknüpfung merken
+ end;
+ end
+ else begin
+ neuF:=neuP.elterVonFamilie(0);
+ if neuF<>nil then modus:=0
+ else begin
+ neuF:=neuP.elterVonFamilie(1);
+ if neuF<>nil then modus:=1
+ else begin
+ writeln('*** Fehler ***');
+ writeln('Verknüfpung nicht zugewiesen, aber Person ist auch kein Elter einer bekannten Familie!');
+ halt;
+ end;
+ end;
+ end;
+
+ case modus of
+ 0,1: begin
+ mi:=1;
+ if assigned(neuF.Eltern[1-modus].KindIn) then // minimale Familienlänge der Familie finden, in der neuF.Eltern[1-modus] Kind ist
+ mi:=min(mi,QAbstand(Parameter,neuF.Eltern[1-modus].KindIn.Eltern[0],neuF.Eltern[1-modus].KindIn.Eltern[1]));
+ for i:=0 to length(neuF.Eltern[1-modus].ElterIn)-1 do // minimale Familienlänge der Familie finden, in der neuF.Elter[1-modus] Elter ist
+ if neuF.Eltern[1-modus].ElterIn[i]<>neuF then // und die nicht selbst die neue Familie ist
+ mi:=min(mi,QAbstand(Parameter,neuF.Eltern[1-modus].ElterIn[i].Eltern[0],neuF.Eltern[1-modus].ElterIn[i].Eltern[1]));
+ mi:=sqrt(mi);
+ end;
+ 2: begin
+ mi:=1;
+ for i:=0 to length(neuP.ElterIn)-1 do // minimale Familienlänge der Kindfamilien finden
+ mi:=min(mi,QAbstand(Parameter,neuP.ElterIn[i].Eltern[0],neuP.ElterIn[i].Eltern[1]));
+ mi:=sqrt(mi);
+ end;
+ end{of case};
+
+ cnt:=100;
+
+ repeat
+ dec(cnt);
+ if cnt<0 then begin
+ cnt:=100;
+ write('-');
+ end;
+ case modus of
+ 0,1: begin
+ phi:=2*pi*random; // der Winkel der neuen Familie
+ ma:=(0.1+0.8*random)*mi; // die Länge der neuen Familie
+ Parameter[neuP.p1]:=Parameter[neuF.Eltern[1-modus].p1] + ma*cos(phi);
+ Parameter[neuP.p2]:=Parameter[neuF.Eltern[1-modus].p2] + ma*sin(phi);
+ end;
+ 2: begin
+ phi:=2*pi*random; // der Winkel der neuen Familie
+ Parameter[vkn.Lambda]:=0.1+0.8*random; // Lambda des alten Kindes in der neuen Familie
+ ma:=(0.1+0.8*random)*mi; // die Länge der neuen Familie
+ Parameter[vkn.input[0,'x']]:=
+ Parameter[vkn.output['x']] - ma*Parameter[vkn.Lambda]*cos(phi);
+ Parameter[vkn.input[0,'y']]:=
+ Parameter[vkn.output['y']] - ma*Parameter[vkn.Lambda]*sin(phi);
+
+ Parameter[vkn.input[1,'x']]:=
+ Parameter[vkn.output['x']] - ma*(Parameter[vkn.Lambda]-1)*cos(phi);
+ Parameter[vkn.input[1,'y']]:=
+ Parameter[vkn.output['y']] - ma*(Parameter[vkn.Lambda]-1)*sin(phi);
+ end;
+ 3:
+ Parameter[vkn.Lambda]:=0.1+0.8*random; // Lambda des neuen Kindes
+ end{of case};
+
+ md.berechneAbhaengigeVariable(Parameter);
+ md.Energie(Parameter,aKrzgn,i);
+ until (aKrzgn=0) or NotAus.istZuende;
+ end;
+
+ until NotAus.istZuende;
+
+ setlength(gradient,0);
+ setlength(alt,0);
+ setlength(step,0);
+ Laufzeit:=Laufzeit+Timer.gibZeit;
+ Timer.free;
+end;
+
+// tEnergieThread **************************************************************
+
+constructor tEnergieThread.create(s: tParameterSimplex; von,bis: longint; psBerechnen: boolean);
+begin
+ inherited create(true);
+ _s:=s;
+ _von:=von;
+ _bis:=bis;
+ bp:=psBerechnen;
+ fertig:=false;
+ freeonterminate:=false;
+ suspended:=false;
+end;
+
+destructor tEnergieThread.destroy;
+begin
+ inherited destroy;
+end;
+
+procedure tEnergieThread.execute;
+var i: longint;
+begin
+ for i:=_von to _bis do begin
+ if bp then
+ _s.berechneAbhaengigeVariable(i{$IFDEF detaillierteZeitanalyse},false{$ENDIF});
+ _s.berechneEnergie(i{$IFDEF detaillierteZeitanalyse},false{$ENDIF});
+ if (_bis-i) mod ((_bis-_von) div 10) = 0 then
+ write('.');
+ end;
+ fertig:=true;
+end;
+
+
+// tStabileInitThread **********************************************************
+
+constructor tStabileInitThread.create(s: tStabile; werDran,extraZufall: tIntArray; wannDran: t4DPointArray; art: char; anzahl: longint);
+begin
+ inherited create(true);
+ _s:=s;
+ setlength(_werDran,length(werDran));
+ if length(_werDran)>0 then
+ move(werDran[0],_werDran[0],length(_werDran)*sizeof(_werDran[0]));
+ setlength(_wannDran,length(wannDran));
+ if length(_wannDran)>0 then
+ move(wannDran[0],_wannDran[0],length(_wannDran)*sizeof(_wannDran[0]));
+ setlength(_extraZufall,length(extraZufall));
+ if length(_extraZufall)>0 then
+ move(extraZufall[0],_extraZufall[0],length(_extraZufall)*sizeof(_extraZufall[0]));
+ _art:=art;
+ _anzahl:=anzahl;
+ _mt:=tMersenneTwister.Create;
+ _mt.init(random(high(longword)));
+ Kreuzungen:=-1;
+ Energie:=-1;
+ setlength(Parameter,length(_s.Parameter));
+ fertig:=false
+end;
+
+destructor tStabileInitThread.destroy;
+begin
+ _s:=nil;
+ _mt.free;
+ setlength(_werDran,0);
+ setlength(_wannDran,0);
+ setlength(_extraZufall,0);
+ inherited destroy;
+end;
+
+procedure tStabileInitThread.execute;
+var
+ i,j,k,l,m,NK,zufallMerker: longint;
+ NP: TExtendedArray;
+ tmp,Ax,Ay,Rx,Ry: extended;
+begin
+ setlength(NP,_s.MD.ParameterLaenge);
+
+ for j:=0 to length(NP)-1 do
+ NP[j]:=-1;
+
+ for i:=1 to max(1,_Anzahl) do begin
+ zufallMerker:=0;
+ case _Art of
+ 'b': begin
+ if _s.NotAus.istZuende then break;
+ for j:=0 to length(_extraZufall)-1 do
+ NP[_extraZufall[j]]:=_mt.random;
+ for j:=0 to length(_werDran)-1 do
+ case _wannDran[_werDran[j]].u of
+ -1: begin // die Wurzel
+ NP[_s.MD.Personen[_werDran[j]].P1]:=0.5+0.01*_mt.random;
+ NP[_s.MD.Personen[_werDran[j]].P2]:=0.5+0.01*_mt.random;
+ end;
+ 0,1: begin // als +/- Vorfahr abhängig,
+ if _wannDran[_werDran[j]].u=0 then
+ zufallMerker:=2*_mt.random(2)-1 // + oder -
+ else
+ zufallMerker:=-zufallMerker; // - oder +
+
+ NP[_s.MD.Personen[_werDran[j]].P1]:=NP[_s.MD.Personen[_wannDran[_werDran[j]].z].P1] + zufallMerker*power(2,-(_wannDran[_werDran[j]].y div 2)-1)*byte(odd(_wannDran[_werDran[j]].y));
+ NP[_s.MD.Personen[_werDran[j]].P2]:=NP[_s.MD.Personen[_wannDran[_werDran[j]].z].P2] + zufallMerker*power(2,-(_wannDran[_werDran[j]].y div 2)-1)*byte(not odd(_wannDran[_werDran[j]].y));
+ NP[_s.MD.Personen[_wannDran[_werDran[j]].z].P3]:=0.5+0.01*_mt.random;
+ end;
+ 2,3: begin // als Mann/Frau abhängig,
+ tmp:=_mt.random*2*pi;
+ NP[_s.MD.Personen[_werDran[j]].P1]:=NP[_s.MD.Personen[_wannDran[_werDran[j]].z].P1] - power(2,-(_wannDran[_werDran[j]].y div 2)-1)*cos(tmp);
+ NP[_s.MD.Personen[_werDran[j]].P2]:=NP[_s.MD.Personen[_wannDran[_werDran[j]].z].P2] - power(2,-(_wannDran[_werDran[j]].y div 2)-1)*sin(tmp);
+ end;
+ 4: begin // als Nachfahr abhängig
+ NP[_s.MD.Personen[_werDran[j]].P3]:=_mt.random;
+ NP[_s.MD.Personen[_werDran[j]].P1]:=NP[_s.MD.Familien[_wannDran[_werDran[j]].z].Eltern[0].P1] * (1 - NP[_s.MD.Personen[_werDran[j]].P3])
+ + NP[_s.MD.Familien[_wannDran[_werDran[j]].z].Eltern[1].P1] * NP[_s.MD.Personen[_werDran[j]].P3];
+ NP[_s.MD.Personen[_werDran[j]].P2]:=NP[_s.MD.Familien[_wannDran[_werDran[j]].z].Eltern[0].P2] * (1 - NP[_s.MD.Personen[_werDran[j]].P3])
+ + NP[_s.MD.Familien[_wannDran[_werDran[j]].z].Eltern[1].P2] * NP[_s.MD.Personen[_werDran[j]].P3];
+ end;
+ end{of case};
+ k:=0;
+ for j:=0 to length(NP)-1 do
+ if (NP[j]<-0.5) and _s.MD.Parameterattribute[j].wirdBenutzt then begin
+ for l:=0 to length(_s.MD.Personen)-1 do begin
+ if (_s.MD.Personen[l].p1=j) then
+ writeln(inttostr(_wannDran[l].x)+' Personen['+inttostr(l)+'].P1 = '+myfloattostr(NP[j])+' '+inttostr(_wannDran[l].u));
+ if (_s.MD.Personen[l].p2=j) then
+ writeln(inttostr(_wannDran[l].x)+' Personen['+inttostr(l)+'].P2 = '+myfloattostr(NP[j])+' '+inttostr(_wannDran[l].u));
+ if (_s.MD.Personen[l].p3=j) then begin
+ writeln(inttostr(_wannDran[l].x)+' Personen['+inttostr(l)+'].P3 = '+myfloattostr(NP[j])+' '+inttostr(_wannDran[l].u));
+ writeln(' '+inttostr(byte(assigned(_s.MD.Personen[l].KindIn))));
+ if assigned(_s.MD.Personen[l].KindIn) then
+ writeln(' ['+inttostr(_s.MD.Personen[l].KindIn.Eltern[0].Index)+'] '+
+ inttostr(_wannDran[_s.MD.Personen[l].KindIn.Eltern[0].Index].x)+' '+
+ inttostr(_wannDran[_s.MD.Personen[l].KindIn.Eltern[0].Index].u)+' ['+
+ inttostr(_s.MD.Personen[l].KindIn.Eltern[1].Index)+'] '+
+ inttostr(_wannDran[_s.MD.Personen[l].KindIn.Eltern[1].Index].x)+' '+
+ inttostr(_wannDran[_s.MD.Personen[l].KindIn.Eltern[1].Index].u));
+ for m:=0 to length(_wannDran)-1 do
+ if _wannDran[m].z=l then
+ writeln(' <- ['+inttostr(m)+'] '+inttostr(_wannDran[m].x)+' '+inttostr(_wannDran[m].u));
+ end;
+ end;
+ inc(k);
+ end;
+ if k>0 then begin // es gibt ungesetzte Parameter
+ writeln('Irgendwie sind '+inttostr(k)+' benutzte von insgesamt '+inttostr(_s.MD.ParameterLaenge)+' Parametern (davon '+inttostr(_s.MD.anzUnbenutzt)+' planmäßig unbenutzt) ungesetzt ...');
+ halt(1);
+ end;
+ end;
+ 'M':
+ for j:=0 to _s.MD.ParameterLaenge-1 do
+ if _s.MD.Parameterattribute[j].istUnabhaengig then
+ NP[j]:=_mt.random;
+ end{of Case};
+ _s.MD.berechneAbhaengigeVariable(NP{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ Ax:=NP[_s.MD.Personen[0].P1];
+ Ay:=NP[_s.MD.Personen[0].P2];
+ Rx:=Ax;
+ Ry:=Ay;
+ for j:=1 to length(_s.MD.Personen)-1 do begin
+ Ax:=min(Ax,NP[_s.MD.Personen[j].P1]);
+ Ay:=min(Ay,NP[_s.MD.Personen[j].P2]);
+ Rx:=max(Rx,NP[_s.MD.Personen[j].P1]);
+ Ry:=max(Ry,NP[_s.MD.Personen[j].P2]);
+ end;
+ Rx:=1/max(epsilon,Rx-Ax);
+ Ry:=1/max(epsilon,Ry-Ay);
+ for j:=0 to length(_s.MD.Personen)-1 do begin
+ NP[_s.MD.Personen[j].P1]:=
+ (NP[_s.MD.Personen[j].P1]-Ax)*Rx;
+ NP[_s.MD.Personen[j].P2]:=
+ (NP[_s.MD.Personen[j].P2]-Ay)*Ry;
+ end;
+ _s.MD.berechneAbhaengigeVariable(NP{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ tmp:=_s.MD.Energie(NP,NK,j{$IFDEF detaillierteZeitanalyse},true{$ENDIF});
+ if (i=1) or
+ (Kreuzungen>NK) or
+ ((tmp<Energie) and
+ (Kreuzungen=NK)) then begin
+ Energie:=tmp;
+ Kreuzungen:=NK;
+ for j:=0 to length(Parameter)-1 do
+ Parameter[j]:=NP[j];
+ end;
+ if _s.NotAus.istZuende then break;
+ end;
+
+ fertig:=true;
+end;
+
+end.
diff --git a/make b/make
new file mode 100755
index 0000000..8f6fa96
--- /dev/null
+++ b/make
@@ -0,0 +1,3 @@
+#!/bin/bash
+
+fpc -MObjFPC -Scghi -Cirot -O3 -g -gl -vewnhi -Filib/x86_64-linux -Fl/opt/gnome/lib -Fu/usr/lib/lazarus/lcl/units/x86_64-linux/gtk2 -Fu/usr/lib/lazarus/lcl/units/x86_64-linux -Fu/usr/lib/lazarus/components/lazutils/lib/x86_64-linux -Fu/usr/lib/lazarus/packager/units/x86_64-linux -Fu. -FUlib/x86_64-linux -dLCL -dLCLgtk2 stabile.lpr
diff --git a/stabile.lpi b/stabile.lpi
new file mode 100644
index 0000000..6befb4e
--- /dev/null
+++ b/stabile.lpi
@@ -0,0 +1,93 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+ <ProjectOptions>
+ <Version Value="9"/>
+ <General>
+ <Flags>
+ <MainUnitHasCreateFormStatements Value="False"/>
+ <MainUnitHasTitleStatement Value="False"/>
+ </Flags>
+ <SessionStorage Value="InProjectDir"/>
+ <MainUnit Value="0"/>
+ <Title Value="stabile"/>
+ <UseAppBundle Value="False"/>
+ <ResourceType Value="res"/>
+ </General>
+ <i18n>
+ <EnableI18N LFM="False"/>
+ </i18n>
+ <VersionInfo>
+ <StringTable ProductVersion=""/>
+ </VersionInfo>
+ <BuildModes Count="1">
+ <Item1 Name="Default" Default="True"/>
+ </BuildModes>
+ <PublishOptions>
+ <Version Value="2"/>
+ </PublishOptions>
+ <RunParams>
+ <local>
+ <FormatVersion Value="1"/>
+ </local>
+ </RunParams>
+ <Units Count="4">
+ <Unit0>
+ <Filename Value="stabile.lpr"/>
+ <IsPartOfProject Value="True"/>
+ </Unit0>
+ <Unit1>
+ <Filename Value="grampsmath.pas"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="grampsmath"/>
+ </Unit1>
+ <Unit2>
+ <Filename Value="energiefunktion.inc"/>
+ <IsPartOfProject Value="True"/>
+ </Unit2>
+ <Unit3>
+ <Filename Value="lowlevelunit.pas"/>
+ <IsPartOfProject Value="True"/>
+ </Unit3>
+ </Units>
+ </ProjectOptions>
+ <CompilerOptions>
+ <Version Value="11"/>
+ <Target>
+ <Filename Value="stabile"/>
+ </Target>
+ <SearchPaths>
+ <IncludeFiles Value="$(ProjOutDir)"/>
+ <OtherUnitFiles Value="../units"/>
+ <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+ </SearchPaths>
+ <CodeGeneration>
+ <Checks>
+ <IOChecks Value="True"/>
+ <RangeChecks Value="True"/>
+ <OverflowChecks Value="True"/>
+ <StackChecks Value="True"/>
+ </Checks>
+ <VerifyObjMethodCallValidity Value="True"/>
+ </CodeGeneration>
+ <Linking>
+ <Options>
+ <Win32>
+ <GraphicApplication Value="True"/>
+ </Win32>
+ </Options>
+ </Linking>
+ </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/stabile.lpr b/stabile.lpr
new file mode 100644
index 0000000..b65017e
--- /dev/null
+++ b/stabile.lpr
@@ -0,0 +1,95 @@
+program stabile;
+
+uses grampsunit, sysutils, crt, grampstypen, grampsmath, matheunit;
+
+var
+ S: String;
+ c: char;
+ Stb: TStabile;
+
+procedure Status(Level: Longint);
+begin
+ case Level of
+ 0:
+ writeln('Fehler: obiger Fehler!');
+ 2:
+ writeln('Fehler: Korrupte Zwischenstand-Datei!');
+ else begin
+ writeln('Verwendung: '+Paramstr(0)+' (e|E)[bM]* input.xml/input.gramps');
+ writeln('oder: '+Paramstr(0)+' l Zwischenzustand.txt');
+ end;
+ end{of case};
+ if Assigned(Stb) then Stb.destroy;
+ halt;
+end;
+
+begin
+ if GetEnvironmentVariable('randseed')<>'' then
+ randseed:=strtoint(GetEnvironmentVariable('randseed'));
+
+ if (Paramcount<>2) or
+ (length(Paramstr(1))<1) or
+ ((length(Paramstr(1))<>1) and
+ (leftStr(Paramstr(1),1)='l')) then Status(1);
+ case Paramstr(1)[1] of
+ 'e','E': begin // aus gramps-xml lesen
+ if ((rightStr(Paramstr(2),4)<>'.xml') and
+ (rightStr(Paramstr(2),7)<>'.gramps')) or
+ not fileexists(Paramstr(2)) then Status(1);
+ Stb:=TStabile.create;
+ if not Stb.LadeXML(Paramstr(2)) then begin
+ Stb.destroy;
+ halt;
+ end;
+ Stb.printStatus(0);
+ Stb.generiereFehlendeInfos;
+ Stb.printStatus(1);
+
+ if (length(Paramstr(1))=1) or (pos('b',Paramstr(1))>0) or (pos('i',Paramstr(1))>0) then
+ Stb.nurGroeszteZusammenhangskomponente;
+
+ Stb.printStatus(2);
+ if not Stb.analysiereInteraktionen then begin
+ Stb.destroy;
+ halt;
+ end;
+ Stb.printStatus(3);
+
+ if Paramstr(1)[1]='E' then
+ Stb.blaetterAbschneiden;
+
+ Stb.Initialisiere(10000,rightStr(Paramstr(1),length(Paramstr(1))-1));
+ end;
+ 'l': begin // aus Zwischenstandsdatei einlesen
+ if Paramcount<>2 then Status(1);
+ if not fileexists(Paramstr(2)) then Status(1);
+ Stb:=TStabile.create;
+ if not Stb.LadeVonDatei(Paramstr(2)) then Status(2);
+ Stb.printStatus(4);
+ end;
+ end{of Case};
+// Stb.optimiere;
+// Stb.downHillSimplex;
+ Stb.gradientenOptimierung;
+ writeln('Du hattest '+myTimeToStr(Stb.Zeit)+' Geduld.');
+ write('Möchtest du den Fortschritt speichern? (j/n) ');
+ c:=readkey;
+ while not (c in ['j','J','n','N']) do begin
+ writeln;
+ writeln(''''+c+''' verstehe ich nicht, aber ich wiederhole die Frage gerne noch einmal:');
+ write('Möchtest du den Fortschritt speichern? (j/n) ');
+ c:=readkey;
+ end;
+ writeln;
+ if c in ['j','J'] then begin
+ writeln('Und wohin?');
+ readln(S);
+ while not Stb.SpeichereInDatei(S) do begin
+ writeln('Die Datei '''+S+''' existiert bereits, nimm bitte eine andere!');
+ readln(S);
+ end;
+ end;
+ writeln;
+ Stb.destroy;
+end.
+
diff --git a/stabile.lps b/stabile.lps
new file mode 100644
index 0000000..5a27a08
--- /dev/null
+++ b/stabile.lps
@@ -0,0 +1,194 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+ <ProjectSession>
+ <Version Value="9"/>
+ <BuildModes Active="Default"/>
+ <Units Count="6">
+ <Unit0>
+ <Filename Value="stabile.lpr"/>
+ <IsPartOfProject Value="True"/>
+ <CursorPos X="67" Y="3"/>
+ <UsageCount Value="200"/>
+ <Loaded Value="True"/>
+ </Unit0>
+ <Unit1>
+ <Filename Value="grampsmath.pas"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="grampsmath"/>
+ <IsVisibleTab Value="True"/>
+ <EditorIndex Value="3"/>
+ <CursorPos X="48" Y="12"/>
+ <UsageCount Value="128"/>
+ <Loaded Value="True"/>
+ </Unit1>
+ <Unit2>
+ <Filename Value="energiefunktion.inc"/>
+ <IsPartOfProject Value="True"/>
+ <EditorIndex Value="2"/>
+ <TopLine Value="150"/>
+ <CursorPos X="31" Y="185"/>
+ <UsageCount Value="107"/>
+ <Loaded Value="True"/>
+ </Unit2>
+ <Unit3>
+ <Filename Value="lowlevelunit.pas"/>
+ <IsPartOfProject Value="True"/>
+ <EditorIndex Value="-1"/>
+ <TopLine Value="57"/>
+ <CursorPos X="43" Y="97"/>
+ <UsageCount Value="25"/>
+ </Unit3>
+ <Unit4>
+ <Filename Value="grampsunit.pas"/>
+ <UnitName Value="grampsunit"/>
+ <EditorIndex Value="1"/>
+ <CursorPos X="116" Y="7"/>
+ <UsageCount Value="98"/>
+ <Bookmarks Count="9">
+ <Item0 Y="595" ID="1"/>
+ <Item1 X="24" Y="3952" ID="3"/>
+ <Item2 Y="2620" ID="2"/>
+ <Item3 Y="3524" ID="4"/>
+ <Item4 X="31" Y="4028" ID="5"/>
+ <Item5 Y="3024" ID="6"/>
+ <Item6 X="40" Y="2871" ID="9"/>
+ <Item7 Y="2782" ID="7"/>
+ <Item8 X="44" Y="1465" ID="8"/>
+ </Bookmarks>
+ <Loaded Value="True"/>
+ </Unit4>
+ <Unit5>
+ <Filename Value="grampstypen.pas"/>
+ <UnitName Value="grampstypen"/>
+ <EditorIndex Value="4"/>
+ <CursorPos X="20" Y="5"/>
+ <UsageCount Value="98"/>
+ <Bookmarks Count="1">
+ <Item0 Y="1798"/>
+ </Bookmarks>
+ <Loaded Value="True"/>
+ </Unit5>
+ </Units>
+ <JumpHistory Count="30" HistoryIndex="29">
+ <Position1>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="271" Column="18" TopLine="238"/>
+ </Position1>
+ <Position2>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="272" Column="19" TopLine="239"/>
+ </Position2>
+ <Position3>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1872" Column="58" TopLine="1833"/>
+ </Position3>
+ <Position4>
+ <Filename Value="grampstypen.pas"/>
+ </Position4>
+ <Position5>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="210" Column="13" TopLine="177"/>
+ </Position5>
+ <Position6>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="224" Column="41" TopLine="191"/>
+ </Position6>
+ <Position7>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1806" Column="15" TopLine="1773"/>
+ </Position7>
+ <Position8>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1827" Column="29" TopLine="1808"/>
+ </Position8>
+ <Position9>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1874" Column="11" TopLine="1852"/>
+ </Position9>
+ <Position10>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1837" Column="32" TopLine="1807"/>
+ </Position10>
+ <Position11>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1884" Column="24" TopLine="1850"/>
+ </Position11>
+ <Position12>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="2192" Column="20" TopLine="2177"/>
+ </Position12>
+ <Position13>
+ <Filename Value="stabile.lpr"/>
+ <Caret Line="28" Column="13" TopLine="7"/>
+ </Position13>
+ <Position14>
+ <Filename Value="stabile.lpr"/>
+ <Caret Line="3" Column="56"/>
+ </Position14>
+ <Position15>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="1867" Column="29" TopLine="1828"/>
+ </Position15>
+ <Position16>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="5" Column="13"/>
+ </Position16>
+ <Position17>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="375" Column="4" TopLine="355"/>
+ </Position17>
+ <Position18>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="5" Column="23"/>
+ </Position18>
+ <Position19>
+ <Filename Value="grampstypen.pas"/>
+ <Caret Line="11" Column="56"/>
+ </Position19>
+ <Position20>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="2177" Column="36" TopLine="2173"/>
+ </Position20>
+ <Position21>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="7" Column="63"/>
+ </Position21>
+ <Position22>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="193" Column="28" TopLine="173"/>
+ </Position22>
+ <Position23>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="7" Column="75"/>
+ </Position23>
+ <Position24>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="647" Column="27" TopLine="627"/>
+ </Position24>
+ <Position25>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="7" Column="93"/>
+ </Position25>
+ <Position26>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="2173" Column="61" TopLine="2153"/>
+ </Position26>
+ <Position27>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="7" Column="104"/>
+ </Position27>
+ <Position28>
+ <Filename Value="grampsunit.pas"/>
+ <Caret Line="3805" Column="24" TopLine="3785"/>
+ </Position28>
+ <Position29>
+ <Filename Value="stabile.lpr"/>
+ <Caret Line="71" Column="33" TopLine="54"/>
+ </Position29>
+ <Position30>
+ <Filename Value="stabile.lpr"/>
+ <Caret Line="74" Column="24" TopLine="54"/>
+ </Position30>
+ </JumpHistory>
+ </ProjectSession>
+</CONFIG>
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-21 13:27:51 +0000