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.