{***************************************************************************}

{*  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.