{***************************************************************************} {* PROGRAM FAMILY {* {* p PoliteWait {* f GetBlankFileExt {* p WriteName {* p DisplayNames {* p FindRecordedFileExt {* f AlreadyRecorded {* p EnterDat {* p EnterPos {* p ScrlDataUp * These two need work!!! {* p ScrlDataDn * {* p ReadDat {* f Str3 {* p DeleteChild {* p DeleteSpouse {* p DeleteSibling {* p WriteOldAndForm {* p WriteBlankAndForm {* p DoArrowKey {* p GetSiblings {* p GetSpouses {* p ReWriteRecord {* p GetChildren {* p CheckQuit {* p GetMother {* p GetFather {* p AddSibling {* p AddSpouse {* p AddChild {* p AddMother _______________________________ p ReadPos. {* __ p AddFather/ __ p WriteOneOption. / {* |__ p WriteMenuOptions/ / {* |_________________________________________/ {* __ p MainMenu/ {* |__ p IntroScreen. {* MAIN / {***************************************************************************} program family; uses Dos, Crt; const MaxOpts = 7; type string3 = string[3]; var DumInt: integer; DumSearchRec: SearchRec; PresentRec: integer; PresentOpt: integer; OptionOK: array[1..MaxOpts] of boolean; Child: array[1..40] of integer; Spouse: array[1..40] of integer; Sibling: array[1..40] of integer; procedure PoliteWait; {***************************************************************************} var WaitKey: char; begin writeln; write('Please type the letter "C" to continue...'); repeat WaitKey := readkey; WaitKey := upcase(WaitKey); until WaitKey = 'C'; writeln; end; procedure IntroScreen; {***************************************************************************} begin clrscr; writeln('Family Tree by David W. Croft, copyright 1990.'); PoliteWait; end; Function GetBlankFileExt: string; {***************************************************************************} var ext: integer; ExtStr: string; ExtFound: boolean; begin ext := 0; ExtFound := false; repeat ext := ext + 1; str(Ext:3, ExtStr); FindFirst('FTREEDAT.'+ ExtStr, AnyFile, DumSearchRec); if DosError = 18 then ExtFound := true; if ext = 999 then begin writeln('Too many records.'); PoliteWait; halt; end; until ExtFound; PresentRec := Ext; GetBlankFileExt := ExtStr; end; Procedure WriteName(FileNum: integer); {***************************************************************************} var frec: text; FileExtStr: string3; FileNameStr: string[12]; fullname: string; begin if FileNum = 0 then writeln('0) Unknown') else begin str(FileNum:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; assign(frec, FileNameStr); reset(frec); readln(frec, fullname); writeln(FileNum,') ',fullname); close(frec); end; end; Procedure DisplayNames; {***************************************************************************} var FileExtStr: string3; alpha: integer; FileNameStr: string[12]; begin alpha := 1; repeat WriteName(alpha); alpha := alpha + 1; str(alpha:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; FindFirst(FileNameStr, AnyFile, DumSearchRec); until DosError = 18; end; Procedure FindRecordedFileExt(var FileExt: string3); {***************************************************************************} var FileNum: integer; begin writeln('0) None of these'); DisplayNames; write('What is the file number?: '); readln(FileNum); str(FileNum:3, FileExt); end; Function AlreadyRecorded(var FileExtStr: string3): boolean; {***************************************************************************} var TempAlreadyRecorded: boolean; recorded: char; TempFileExtStr: string3; begin TempFileExtStr := FileExtStr; clrscr; write('Has this person already been recorded (Y/N)?: '); readln(recorded); if upcase(recorded) = 'Y' then begin FindRecordedFileExt(FileExtStr); if FileExtStr = ' 0' then recorded := 'N' else Val(FileExtStr, PresentRec, DumInt); end; if upcase(recorded) = 'Y' then TempAlreadyRecorded := true else begin FileExtStr := TempFileExtStr; TempAlreadyRecorded := false; end; AlreadyRecorded := TempAlreadyRecorded; end; Procedure EnterDat(FileExtStr: string3); {***************************************************************************} var recdata: string; fullname: string; recfile: text; FileNameStr: string[12]; alpha: integer; FormFile: text; FormLine: string; begin val(FileExtStr, PresentRec, DumInt); clrscr; FileNameStr := 'FTREEDAT.' + FileExtStr; assign(recfile, FileNameStr); rewrite(recfile); assign(FormFile, 'FAMILY-F.ORM'); reset(FormFile); repeat readln(FormFile, FormLine); write(FormLine,': '); readln(RecData); if RecData <> '' then writeln(recfile, FormLine + ': ' + RecData); until EOF(FormFile); close(recfile); close(FormFile); PoliteWait; end; Procedure EnterPos(FileExt: string; gender: char; father, mother, NumChildren, NumSpouses, NumSiblings: integer); {***************************************************************************} var FileNameStr: string[12]; recfile: text; alpha: integer; begin FileNameStr := 'FTREEPOS.' + FileExt; assign(recfile, FileNameStr); rewrite(recfile); writeln(recfile, gender); writeln(recfile, father); writeln(recfile, mother); writeln(recfile, NumChildren); for alpha := 1 to NumChildren do writeln(recfile, child[alpha]); writeln(recfile, NumSpouses); for alpha := 1 to NumSpouses do writeln(recfile, Spouse[alpha]); writeln(recfile, NumSiblings); for alpha := 1 to NumSiblings do writeln(recfile, Sibling[alpha]); close(recfile); end; Procedure ReadPos(FileNum: integer; var gender: char; var father, mother, NumChildren, NumSpouses, NumSiblings: integer); {*****************************************************************************} var FileExtStr: string[3]; FileNameStr: string[12]; recfile: text; alpha: integer; begin str(FileNum:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(recfile, FileNameStr); reset(recfile); readln(recfile, gender); readln(recfile, father); OptionOK[1] := true; if father = 0 then OptionOK[1] := false; readln(recfile, mother); OptionOK[2] := true; if mother = 0 then OptionOK[2] := false; readln(recfile, NumChildren); OptionOK[4] := true; if NumChildren = 0 then OptionOK[4] := false; for alpha := 1 to NumChildren do readln(recfile, Child[alpha]); readln(recfile, NumSpouses); OptionOK[5] := true; if NumSpouses = 0 then OptionOK[5] := false; for alpha := 1 to NumSpouses do readln(recfile, Spouse[alpha]); OptionOK[3] := true; readln(recfile, NumSiblings); if NumSiblings = 0 then OptionOK[3] := false; for alpha := 1 to NumSiblings do readln(recfile, sibling[alpha]); close(recfile); end; Procedure ScrlDataUp; {***************************************************************************} begin end; Procedure ScrlDataDn; {***************************************************************************} begin end; Procedure ReadDat(FileNum: integer); var recfile: text; RecLine: string; fullname: string; FileNameStr: string[12]; FileExtStr: string3; alpha: integer; gender: char; father, mother, NumChildren, NumSpouses, NumSiblings: integer; TopScr, BotScr, NowScr: byte; begin PresentRec := FileNum; str(FileNum:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; FindFirst(FileNameStr, AnyFile, DumSearchRec); if DosError = 18 then begin FileExtStr := GetBlankFileExt; EnterDat(FileExtStr); Write('What is the gender of this person (M/F)?: '); readln(gender); gender := upcase(gender); EnterPos(FileExtStr, gender, 0,0,0,0,0); ReadDat(FileNum); end else begin clrscr; writeln; ReadPos(FileNum, gender, father, mother, NumChildren, NumSpouses, NumSiblings); write('Father: '); WriteName(father); write('Mother: '); WriteName(mother); for alpha := 1 to NumSiblings do begin write(' Sibling: '); WriteName(Sibling[alpha]); end; assign(recfile, FileNameStr); reset(recfile); readln(recfile, fullname); TextColor(Red); writeln(FileExtStr,') ',fullname); TextColor(White); for alpha := 1 to NumSpouses do begin write(' Spouse: '); WriteName(Spouse[alpha]); end; for alpha := 1 to NumChildren do begin write(' Child: '); WriteName(Child[alpha]); end; writeln('-------------------------------------------------------------------------------'); TopScr := WhereY; BotScr := 21 - TopScr; window(1,TopScr,80,21); {* possible error if BotScr <= 0 *} repeat NowScr := WhereY; if NowScr = BotScr then begin PoliteWait; clrscr; writeln; end; readln(recfile, recline); writeln(RecLine); until EOF(recfile); close(recfile); window(1,1,80,25); end; end; Procedure WriteOneOption(MenuOpt: integer); {*****************************************************************************} begin TextColor(Red); if MenuOpt = PresentOpt then TextBackGround(Green) else TextBackGround(Black); if OptionOK[MenuOpt] = true then TextColor(Red) else TextColor(Blue); case MenuOpt of 1: begin GotoXY(1,1); writeln('Father'); end; 2: begin GotoXY(20,1); writeln('Mother'); end; 3: begin GotoXY(40, 1); writeln('Sibling(s)'); end; 4: begin GotoXY(1,24); writeln('Children'); end; 5: begin GotoXY(20, 24); writeln('Spouse(s)'); end; 6: begin GotoXY(40,24); writeln('Quit'); end; 7: begin GotoXY(60, 24); writeln('Rewrite this record'); end; end; {case} end; Procedure WriteMenuOptions; {***************************************************************************} var MenuOpt: integer; begin for MenuOpt := 1 to MaxOpts do WriteOneOption(MenuOpt); TextColor(white); TextBackGround(Black); end; Procedure AddChild; {***************************************************************************} var FileExtStr: string3; FileNameStr: string[12]; FRec: text; TempGender: char; TempRec, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings: integer; TempChild: array[1..40] of integer; TempSpouse: array[1..40] of integer; TempSibling: array[1..40] of integer; father, mother, NumChildren, NumSpouses, NumSiblings: integer; alpha: integer; gender: char; NotRecorded: boolean; begin TempRec := PresentRec; ReadPos(PresentRec, TempGender, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings); for alpha := 1 to TempNumChildren do TempChild[alpha] := Child[alpha]; for alpha := 1 to TempNumSpouses do TempSpouse[alpha] := Spouse[alpha]; for alpha := 1 to TempNumSiblings do TempSibling[alpha] := Sibling[alpha]; str(PresentRec:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(frec, FileNameStr); rewrite(frec); FileExtStr := GetBlankFileExt; NotRecorded := not(AlreadyRecorded(FileExtStr)); if NotRecorded then begin EnterDat(FileExtStr); Write('What is the gender of the child (M/F)?: '); readln(gender); gender := upcase(gender); if TempGender = 'M' then EnterPos(FileExtStr, Gender, TempRec, 0, 0, 0, 0) else EnterPos(FileExtStr, Gender, 0, TempRec, 0, 0, 0); end else begin ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); if TempGender = 'M' then EnterPos(FileExtStr, Gender, TempRec, Mother, NumChildren, NumSpouses, NumSiblings) else EnterPos(FileExtStr, Gender, Father, TempRec, NumChildren, NumSpouses, NumSiblings); end; ReadDat(PresentRec); writeln(frec, TempGender); writeln(frec, TempFather); writeln(frec, TempMother); writeln(frec, TempNumChildren + 1); for alpha := 1 to TempNumChildren do writeln(frec, TempChild[alpha]); writeln(frec, PresentRec); writeln(frec, TempNumSpouses); for alpha := 1 to TempNumSpouses do writeln(frec, TempSpouse[alpha]); writeln(frec, TempNumSpouses); for alpha := 1 to TempNumSpouses do writeln(frec, TempSpouse[alpha]); close(frec); end; Procedure AddSpouse; {***************************************************************************} var FileExtStr: string3; FileNameStr: string[12]; FRec: text; TempGender: char; TempRec, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings: integer; TempChild: array[1..40] of integer; TempSpouse: array[1..40] of integer; TempSibling: array[1..40] of integer; father, mother, NumChildren, NumSpouses, NumSiblings: integer; alpha: integer; gender: char; NotRecorded: boolean; begin TempRec := PresentRec; ReadPos(PresentRec, TempGender, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings); for alpha := 1 to TempNumChildren do TempChild[alpha] := Child[alpha]; for alpha := 1 to TempNumSpouses do TempSpouse[alpha] := Spouse[alpha]; for alpha := 1 to TempNumSiblings do TempSibling[alpha] := Sibling[alpha]; str(PresentRec:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(frec, FileNameStr); rewrite(frec); FileExtStr := GetBlankFileExt; NotRecorded := not(AlreadyRecorded(FileExtStr)); if NotRecorded then begin EnterDat(FileExtStr); Spouse[1] := TempRec; if TempGender = 'M' then EnterPos(FileExtStr, 'F', 0, 0, 0, 1, 0) else EnterPos(FileExtStr, 'M', 0, 0, 0, 1, 0); end else begin ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); Spouse[NumSpouses+1] := TempRec; EnterPos(FileExtStr, Gender, Father, Mother, NumChildren, NumSpouses + 1, NumSiblings); end; ReadDat(PresentRec); writeln(frec, TempGender); writeln(frec, TempFather); writeln(frec, TempMother); writeln(frec, TempNumChildren); for alpha := 1 to TempNumChildren do writeln(frec, TempChild[alpha]); writeln(frec, TempNumSpouses+1); for alpha := 1 to TempNumSpouses do writeln(frec, TempSpouse[alpha]); writeln(frec, PresentRec); writeln(frec, TempNumSiblings); for alpha := 1 to TempNumSiblings do writeln(frec, TempSibling[alpha]); close(frec); end; Procedure AddSibling; {***************************************************************************} var FileExtStr: string3; FileNameStr: string[12]; FRec: text; TempGender: char; TempRec, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings: integer; TempChild: array[1..40] of integer; TempSpouse: array[1..40] of integer; TempSibling: array[1..40] of integer; father, mother, NumChildren, NumSpouses, NumSiblings: integer; alpha: integer; gender: char; NotRecorded: boolean; begin TempRec := PresentRec; ReadPos(PresentRec, TempGender, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings); for alpha := 1 to TempNumChildren do TempChild[alpha] := Child[alpha]; for alpha := 1 to TempNumSpouses do TempSpouse[alpha] := Spouse[alpha]; for alpha := 1 to TempNumSiblings do TempSibling[alpha] := Sibling[alpha]; str(PresentRec:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(frec, FileNameStr); rewrite(frec); FileExtStr := GetBlankFileExt; NotRecorded := not(AlreadyRecorded(FileExtStr)); if NotRecorded then begin EnterDat(FileExtStr); Write('What is the gender of the sibling (M/F)?: '); readln(gender); gender := upcase(gender); Sibling[1] := TempRec; EnterPos(FileExtStr, Gender, 0, 0, 0, 0, 1) end else begin ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); Sibling[NumSiblings+1] := TempRec; EnterPos(FileExtStr, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings + 1); end; ReadDat(PresentRec); writeln(frec, TempGender); writeln(frec, TempFather); writeln(frec, TempMother); writeln(frec, TempNumChildren); for alpha := 1 to TempNumChildren do writeln(frec, TempChild[alpha]); writeln(frec, TempNumSpouses); for alpha := 1 to TempNumSpouses do writeln(frec, TempSpouse[alpha]); writeln(frec, TempNumSiblings+1); for alpha := 1 to TempNumSiblings do writeln(frec, TempSibling[alpha]); writeln(frec, PresentRec); close(frec); end; Function Str3(IntValue: integer): string3; {***************************************************************************} var TempStr3: string3; begin str(IntValue:3, TempStr3); Str3 := TempStr3; end; Procedure DeleteChild; {***************************************************************************} var GoneChild: integer; alpha, bravo: integer; Gender: char; Father, Mother, NumChildren, NumSpouses, NumSiblings: integer; begin clrscr; ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); writeln('0) None of these'); for alpha := 1 to NumChildren do WriteName(Child[alpha]); writeln; write('Delete which child?: '); readln(GoneChild); if GoneChild <> 0 then begin bravo := 0; for alpha := 1 to NumChildren do begin if Child[alpha] = GoneChild then bravo := alpha; end; if bravo <> 0 then begin NumChildren := NumChildren - 1; for alpha := 1 to NumChildren do if alpha >= bravo then Child[alpha] := Child[alpha+1]; EnterPos(Str3(PresentRec), Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); writeln('The child was deleted.'); end else writeln('No child was deleted.'); end else writeln('No child was deleted.'); PoliteWait; clrscr; ReadDat(PresentRec); end; Procedure DeleteSpouse; {***************************************************************************} var GoneSpouse: integer; alpha, bravo: integer; Gender: char; Father, Mother, NumChildren, NumSpouses, NumSiblings: integer; begin clrscr; ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); writeln('0) None of these'); for alpha := 1 to NumSpouses do WriteName(Spouse[alpha]); writeln; write('Delete which Spouse?: '); readln(GoneSpouse); if GoneSpouse <> 0 then begin bravo := 0; for alpha := 1 to NumSpouses do begin if Spouse[alpha] = GoneSpouse then bravo := alpha; end; if bravo <> 0 then begin NumSpouses := NumSpouses - 1; for alpha := 1 to NumSpouses do if alpha >= bravo then Spouse[alpha] := Spouse[alpha+1]; EnterPos(Str3(PresentRec), Gender, Father, Mother, NumSpouses, NumSpouses, NumSiblings); writeln('The Spouse was deleted.'); end else writeln('No Spouse was deleted.'); end else writeln('No Spouse was deleted.'); PoliteWait; clrscr; ReadDat(PresentRec); end; Procedure DeleteSibling; {***************************************************************************} var Gonesibling: integer; alpha, bravo: integer; Gender: char; Father, Mother, NumChildren, NumSpouses, NumSiblings: integer; begin clrscr; ReadPos(PresentRec, Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); writeln('0) None of these'); for alpha := 1 to NumSiblings do WriteName(sibling[alpha]); writeln; write('Delete which sibling?: '); readln(Gonesibling); if Gonesibling <> 0 then begin bravo := 0; for alpha := 1 to NumSiblings do begin if sibling[alpha] = Gonesibling then bravo := alpha; end; if bravo <> 0 then begin NumSiblings := NumSiblings - 1; for alpha := 1 to NumSiblings do if alpha >= bravo then sibling[alpha] := sibling[alpha+1]; EnterPos(Str3(PresentRec), Gender, Father, Mother, NumChildren, NumSpouses, NumSiblings); writeln('The sibling was deleted.'); end else writeln('No sibling was deleted.'); end else writeln('No sibling was deleted.'); PoliteWait; clrscr; ReadDat(PresentRec); end; Procedure GetChildren(NumChildren: integer); {***************************************************************************} var alpha, bravo: integer; FileExtStr: string[3]; FileNameStr: string[12]; frec: text; fullname: string; thechild: integer; begin clrscr; for alpha := 1 to NumChildren do begin str(Child[alpha]:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; assign(frec, FileNameStr); reset(frec); readln(frec, fullname); writeln(alpha,') ',fullname); close(frec); end; writeln(NumChildren+1,') Add another child'); writeln(NumChildren+2,') Delete a child'); writeln; write('Examine which child?: '); readln(thechild); if thechild = NumChildren+1 then AddChild else if theChild = NumChildren+2 then DeleteChild else ReadDat(Child[thechild]); end; Procedure GetSpouses(NumSpouses: integer); {***************************************************************************} var alpha, bravo: integer; FileExtStr: string[3]; FileNameStr: string[12]; frec: text; fullname: string; TheSpouse: integer; begin clrscr; for alpha := 1 to NumSpouses do begin str(Spouse[alpha]:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; assign(frec, FileNameStr); reset(frec); readln(frec, fullname); writeln(alpha,') ',fullname); close(frec); end; writeln(NumSpouses+1,') Add another spouse'); writeln(NumSpouses+2,') Delete a spouse'); writeln; write('Examine which spouse?: '); readln(TheSpouse); if TheSpouse = NumSpouses+1 then AddSpouse else if TheSpouse = NumSpouses+2 then DeleteSpouse else ReadDat(Spouse[TheSpouse]); end; Procedure GetSiblings(NumSiblings: integer); {***************************************************************************} var alpha, bravo: integer; FileExtStr: string[3]; FileNameStr: string[12]; frec: text; fullname: string; TheSibling: integer; begin clrscr; for alpha := 1 to NumSiblings do begin str(Sibling[alpha]:3, FileExtStr); FileNameStr := 'FTREEDAT.' + FileExtStr; assign(frec, FileNameStr); reset(frec); readln(frec, fullname); writeln(alpha,') ',fullname); close(frec); end; writeln(NumSiblings+1,') Add another sibling'); writeln(NumSiblings+2,') Delete a sibling'); writeln; write('Examine which sibling?: '); readln(TheSibling); if TheSibling = NumSiblings+1 then AddSibling else if TheSibling = NumSiblings+2 then DeleteSibling else ReadDat(Sibling[TheSibling]); end; Procedure AddFather; {***************************************************************************} var FileExtStr: string3; FileNameStr: string[12]; FRec: text; TempGender: char; Tempfather, Tempmother, TempNumChildren, TempNumSpouses, TempNumSiblings: integer; TempChild: array[1..40] of integer; gender: char; father, mother, NumChildren, NumSpouses, NumSiblings: integer; alpha: integer; NotRecorded: boolean; begin ReadPos(PresentRec, TempGender, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings); for alpha := 1 to TempNumChildren do TempChild[alpha] := Child[alpha]; str(PresentRec:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(frec, FileNameStr); rewrite(frec); child[1] := PresentRec; FileExtStr := GetBlankFileExt; NotRecorded := not(AlreadyRecorded(FileExtStr)); if NotRecorded then begin EnterDat(FileExtStr); EnterPos(FileExtStr, 'M', 0, 0, 1, 0, 0); end else begin ReadPos(PresentRec, gender, father, mother, NumChildren, NumSpouses, NumSiblings); EnterPos(FileExtStr, gender, father, mother, NumChildren+1, NumSpouses, NumSiblings); end; ReadDat(PresentRec); writeln(frec, TempGender); writeln(frec, PresentRec); writeln(frec, TempMother); writeln(frec, TempNumChildren); for alpha := 1 to TempNumChildren do writeln(frec, TempChild[alpha]); close(frec); end; Procedure AddMother; {***************************************************************************} var FileExtStr: string3; FileNameStr: string[12]; FRec: text; TempGender: char; Tempfather, Tempmother, TempNumChildren, TempNumSpouses, TempNumSiblings: integer; TempChild: array[1..40] of integer; gender: char; father, mother, NumChildren, NumSpouses, NumSiblings: integer; alpha: integer; NotRecorded: boolean; begin ReadPos(PresentRec, TempGender, TempFather, TempMother, TempNumChildren, TempNumSpouses, TempNumSiblings); for alpha := 1 to TempNumChildren do TempChild[alpha] := Child[alpha]; str(PresentRec:3, FileExtStr); FileNameStr := 'FTREEPOS.' + FileExtStr; assign(frec, FileNameStr); rewrite(frec); child[1] := PresentRec; FileExtStr := GetBlankFileExt; NotRecorded := not(AlreadyRecorded(FileExtStr)); if NotRecorded then begin EnterDat(FileExtStr); EnterPos(FileExtStr, 'F', 0, 0, 1, 0, 0); end else begin ReadPos(PresentRec, gender, father, mother, NumChildren, NumSpouses, NumSiblings); EnterPos(FileExtStr, gender, father, mother, NumChildren+1, NumSpouses, NumSiblings); end; ReadDat(PresentRec); writeln(frec, TempGender); writeln(frec, TempFather); writeln(frec, PresentRec); writeln(frec, TempNumChildren); for alpha := 1 to TempNumChildren do writeln(frec, TempChild[alpha]); close(frec); end; Procedure WriteOldAndForm(OldStr, FormStr: string; var TempRec, FormRec: text); {***************************************************************************} var LineStr: string; begin writeln(OldStr); FormStr := FormStr + ': '; write(FormStr); readln(LineStr); if LineStr <> '' then writeln(TempRec, FormStr + LineStr) else begin GotoXY(1, WhereY-1); ClrEol; writeln(OldStr); writeln(TempRec, OldStr); end; end; Procedure WriteBlankAndForm(OldStr: string; var FormStr: string; var TempRec, FormRec: text); {***************************************************************************} var LineStr: string; begin FormStr := FormStr + ': '; writeln(FormStr); write(FormStr); readln(LineStr); if LineStr <> '' then writeln(TempRec, FormStr + LineStr); readln(FormRec, FormStr); end; Procedure ReWriteRecord; {***************************************************************************} var FileNameStr: string[12]; OldRec, TempRec, FormRec: text; LineStr, FormStr, OldStr: string; Form: boolean; begin FileNameStr := 'FTREEDAT.' + Str3(PresentRec); assign(OldRec, FileNameStr); reset(OldRec); assign(TempRec, 'FTREEDAT.TMP'); rewrite(TempRec); assign(FormRec, 'FAMILY-F.ORM'); reset(FormRec); clrscr; repeat readln(OldRec, OldStr); readln(FormRec, FormStr); if FormStr = copy(OldStr, 1, length(FormStr)) then WriteOldAndForm(OldStr, FormStr, TempRec, FormRec) else repeat Form := false; if FormStr = copy(OldStr, 1, length(FormStr)) then begin WriteOldAndForm(OldStr, FormStr, TempRec, FormRec); Form := true; end else begin WriteBlankAndForm(OldStr, FormStr, TempRec, FormRec); end; until Form or (FormStr = ''); until EOF(FormRec); close(OldRec); close(TempRec); close(FormRec); rewrite(OldRec); reset(TempRec); repeat readln(TempRec, LineStr); writeln(OldRec, LineStr); until EOF(TempRec); close(TempRec); close(OldRec); PoliteWait; ReadDat(PresentRec); end; Procedure CheckQuit(var Quit: boolean); {***************************************************************************} var QuitOpt: char; begin clrscr; write('Do you want to quit this program? (Y/N): '); readln(QuitOpt); QuitOpt := upcase(QuitOpt); if QuitOpt = 'Y' then Quit := true else begin clrscr; ReadDat(PresentRec); end; end; Procedure GetFather(Father: integer); {***************************************************************************} var useropt: char; Gender: char; Mother, NumChildren, NumSpouses, NumSiblings: integer; begin clrscr; WriteName(Father); write('Hit ENTER to examine or type "D" to delete: '); useropt := readkey; writeln; useropt := upcase(useropt); if useropt <> 'D' then ReadDat(Father) else begin ReadPos(PresentRec, Gender, DumInt, Mother, NumChildren, NumSpouses, NumSiblings); EnterPos(Str3(PresentRec), Gender, 0, Mother, NumChildren, NumSpouses, NumSiblings); writeln('The father has been deleted.'); PoliteWait; clrscr; ReadDat(PresentRec); end; end; Procedure GetMother(Mother: integer); {***************************************************************************} var useropt: char; Gender: char; Father, NumChildren, NumSpouses, NumSiblings: integer; begin clrscr; WriteName(Mother); write('Hit ENTER to examine or type "D" to delete: '); useropt := readkey; writeln; useropt := upcase(useropt); if useropt <> 'D' then ReadDat(Mother) else begin ReadPos(PresentRec, Gender, Father, DumInt, NumChildren, NumSpouses, NumSiblings); EnterPos(Str3(PresentRec), Gender, Father, 0, NumChildren, NumSpouses, NumSiblings); writeln('The mother has been deleted.'); PoliteWait; clrscr; ReadDat(PresentRec); end; end; Procedure DoArrowKey; {***************************************************************************} const Left = #75; Right = #77; Up = #72; Down = #80; var Direct: char; begin Direct := readkey; if Direct = Right then begin PresentOpt := PresentOpt + 1; if PresentOpt > MaxOpts then PresentOpt := 1; end else if Direct = Left then begin PresentOpt := PresentOpt - 1; if PresentOpt = 0 then PresentOpt := MaxOpts; end else if Direct = Up then ScrlDataDn else if Direct = Down then ScrlDataUp else write(#7); WriteMenuOptions; end; Procedure MainMenu; {***************************************************************************} var option: integer; quit: boolean; UserChar: char; FileExtStr: string3; gender: char; father, mother, NumChildren, NumSpouses, NumSiblings: integer; begin Quit := false; repeat ReadPos(PresentRec, gender, father, mother, NumChildren, NumSpouses, NumSiblings); WriteMenuOptions; repeat until keypressed; UserChar := readkey; if UserChar = #13 then begin if OptionOK[PresentOpt] = false then begin case PresentOpt of 1: AddFather; 2: AddMother; 4: AddChild; 5: AddSpouse; 3: AddSibling; else write(#7); end; {case} end else case PresentOpt of 1: GetFather(Father); 2: GetMother(Mother); 6: CheckQuit(Quit); 4: GetChildren(NumChildren); 7: RewriteRecord; 5: GetSpouses(NumSpouses); 3: GetSiblings(NumSiblings); end; {case} end else if UserChar = #0 then DoArrowKey else write(#7); until Quit; end; {***************************************************************************} {***************************************************************************} {***************************************************************************} begin OptionOK[6] := true; OptionOK[7] := true; IntroScreen; ReadDat(1); PresentOpt := 1; MainMenu; end.