From ada93c9da7373367ce29daa3d57cb35ea90f54e5 Mon Sep 17 00:00:00 2001 From: Erich Eckner Date: Fri, 10 Jul 2015 14:56:48 +0200 Subject: initialer Commit --- .gitignore | 17 + energiefunktion.inc | 221 +++ grampsmath.pas | 79 + grampstypen.pas | 2050 ++++++++++++++++++++++ grampsunit.pas | 4674 +++++++++++++++++++++++++++++++++++++++++++++++++++ make | 3 + stabile.lpi | 93 + stabile.lpr | 95 ++ stabile.lps | 194 +++ 9 files changed, 7426 insertions(+) create mode 100644 .gitignore create mode 100644 energiefunktion.inc create mode 100644 grampsmath.pas create mode 100644 grampstypen.pas create mode 100644 grampsunit.pas create mode 100755 make create mode 100644 stabile.lpi create mode 100644 stabile.lpr create mode 100644 stabile.lps 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+10) or (neuEreignis.Art=eaHochzeit))) then + loescheEreignis(Ereignisse,neuEreignis.ID); + neuEreignis:=nil; + dec(Ebene); + continue; + end; + if leftStr(S,6)='' then begin + delete(S,1,6); + S:=leftStr(S,pos('',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)='',S)); + NeuPerson.Vorname:=copy(S,1,pos('',S)-1); + continue; + end; + if leftstr(S,9)='' then begin + delete(S,1,pos('>',S)); + NeuPerson.Nachname:=copy(S,1,pos('',S)-1); + continue; + end; + if leftstr(S,17)=' neuEreignis.Jahr)) then + neuFamilie.Anfang:=neuEreignis; + neuEreignis:=nil; + continue; + end; + if leftStr(S,10)='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 jj 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 aKreuzungens[b] then begin + result:=-1; + exit; + end; + if aKrzEnergien[b] then begin + result:=-1; + exit; + end; + if aEnerg0)) 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 i0 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'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 (l0 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-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].Kreuzungen1) 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 + ((tmpNK) or + ((tmp0); + 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*stepsizenil 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 + + + + + + + + + + + + <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> -- cgit v1.2.3