home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug027.arc / TTPED.INC < prev    next >
Text File  |  1979-12-31  |  3KB  |  103 lines
  1. OVERLAY
  2. PROCEDURE Pedigree(date : str11);
  3. LABEL
  4.   ESCAPE;
  5. VAR
  6.   ptr : INTEGER;
  7.   ear : str5;
  8.  
  9. PROCEDURE ped(child : Animal_rec);
  10. VAR
  11.   gp      : ARRAY[1..20,1..2] OF str5;
  12.   name    : ARRAY[1..20] OF str20;
  13.   ear2    : ARRAY[1..20] OF str5;
  14.   parent  : INTEGER;
  15.   y,x     : INTEGER;
  16.   l,z     : INTEGER;
  17. BEGIN
  18.     parent := 1;
  19.     x := 1;
  20.     y := 1;
  21.     L := 1;
  22.     gp[parent,1] := child.sire;
  23.     gp[parent,2] := child.dam;
  24.     parent := parent + 1;
  25.     REPEAT
  26.       FindKey(EarIndexFile,Ptr,gp[x,L]);
  27.       GetRec(DatF,Ptr,Animal);
  28.       name[parent - 1] := Animal.name;
  29.       ear2[parent - 1] := Animal.ear_No;
  30.       gp[parent,1] := Animal.sire;
  31.       gp[parent,2] := Animal.dam;
  32.       parent := parent + 1;
  33.       y := y + 1;
  34.       IF L = 2
  35.         THEN x := x + 1;
  36.       IF L = 1
  37.         THEN L := 2
  38.         ELSE L := 1;
  39.     UNTIL x = 8;
  40.     Writeln(Q);
  41.     Writeln(Q);
  42.   Writeln(Q,' ':37-(Length(child.name) DIV 2),child.name);
  43.   Writeln(Q,'                                     |');
  44.   Writeln(Q,'             +-----------------------+------------------------+');
  45.   Writeln(Q,'             |                    PARENTS                     |');
  46.   Writeln(Q,'         1 ',gp[1,1],'                                          2 ',gp[1,2]);
  47.   Writeln(Q,'             |                                                |');
  48.   Writeln(Q,'         +---+--------------+   GRAND PARENTS   +-------------+---+');
  49.   Writeln(Q,'         |                  |                   |                 |');
  50.   Writeln(Q,'     3 ',gp[2,1],'            4 ',gp[2,2],'             5 ',gp[3,1],
  51.           '           6 ',gp[3,2]);
  52.   Writeln(Q,'         |                  |                   |                 |');
  53.   Writeln(Q,'         |                  |GREAT GRAND PARENTS|                 |');
  54.   Writeln(Q,'     +---+-----+       +----+----+        +-----+----+       +----+----+');
  55.   Writeln(Q,'     |         |       |         |        |          |       |         |');
  56.   Writeln(Q,' 7 ',gp[4,1],'   8 ',gp[4,2],' 9 ', gp[5,1],'  10 ',
  57.           gp[5,2],' 11 ', gp[6,1],'   12 ' ,gp[6,2],' 13 ',  gp[7,1],'  14 ',   gp[7,2]);
  58.   Writeln(q);
  59.   Writeln;
  60.   Write('Press RETURN to continue ':50);
  61.   Readln;
  62.   Writeln(Q);
  63.   Writeln(Q);
  64.   ClrScr;
  65.   line(1);
  66.   GotoXY(1,2);
  67.    Write(Q,'               P E D I G R E E     of');
  68.    ClrEOL;
  69.    Write(Q,'    ',child.name,' ':20-Length(child.name));
  70.    Writeln(Q);
  71.    Writeln(Q);
  72.    FOR x := 1 TO parent - 2 DO
  73.      BEGIN
  74.        Writeln(Q,x:10,'      ',ear2[x],'  ',name[x],'  ':20 - Length(name[x]),gp[x+1,1]: 7,gp[x+1,2]:7);
  75.        IF x = 2
  76.          THEN Writeln(q);
  77.        IF x = 6
  78.          THEN Writeln(q);
  79.      END;
  80. END;
  81.  
  82. BEGIN
  83.   line(1);
  84.   dis(1,2,'                               P E D I G R E E           ');
  85.   print;
  86.   IF ch <> #27
  87.     THEN
  88.       BEGIN
  89.         line(1);
  90.         GotoXY(1,2);
  91.         Write(Q,date,'    P E D I G R E E     of');
  92.         ClrEOL;
  93.         Write(Q,'    ',Animal.name,' ':20-Length(Animal.name));
  94.         ped(Animal);
  95.         ASSIGN(Q,'CON:');
  96.         REWRITE(Q);
  97.         Write('Press RETURN to continue ':50);
  98.         Readln;
  99.         ClrScr;
  100.       END;
  101.   ch := ^M;
  102. END;
  103.