diff options
Diffstat (limited to 'grampstypen.pas')
| -rw-r--r-- | grampstypen.pas | 2050 |
1 files changed, 2050 insertions, 0 deletions
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. |