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