home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug027.arc / FAMILY.INC < prev    next >
Text File  |  1979-12-31  |  3KB  |  121 lines
  1. overlay PROCEDURE Family_Display(Date : str14);
  2.  
  3. LABEL 
  4.   escape;
  5.  
  6. CONST 
  7.   MaxParents = 50;
  8.   MaxChildren = 500;
  9.  
  10. TYPE 
  11.   child_rec = RECORD
  12.                 rec_no    : INTEGER;
  13.                 parent    : str5;
  14.               END;
  15.  
  16. VAR 
  17.   dummy     : str5;
  18.   rab,
  19.   rab_child : Animal_rec;
  20.   i,y       : INTEGER;
  21.   k,ok      : INTEGER;
  22.   child     : ARRAY[1..MaxChildren] OF child_rec; {holds record no of childern}
  23.   parent    : ARRAY[1..MaxParents]  OF str5;      {holds parents ear number}
  24.   rec       : INTEGER;
  25.   parents   : INTEGER;
  26.   got       : BOOLEAN;
  27.   J         : INTEGER;
  28.  
  29. PROCEDURE check(dd : str5);
  30. BEGIN
  31.   got := FALSE;
  32.   FOR i := 1 TO parents  DO
  33.     IF parent[i] = dd
  34.       THEN got := TRUE;
  35.   IF NOT got
  36.     THEN
  37.       BEGIN
  38.         parent[i]  := dd;
  39.         parents := parents + 1;
  40.       END;
  41. END;
  42.  
  43. BEGIN
  44.   line(1);
  45.   dis(1,2,'                         D I S P L A Y      F A M I L Y');
  46.   print;
  47.   IF ch <> #27
  48.     THEN
  49.       BEGIN
  50.         line(1);
  51.         GotoXY(1,2);
  52.         Write(Q,date,'     F A M I L Y   of');
  53.         ClrEOL;
  54.         Write(Q,'    ',Animal.name,' ':20-Length(Animal.name));
  55.         y := 3;
  56.         parents := 1;
  57.         FOR i := 1 TO MaxParents DO parent[i] := '';
  58.         dummy := Animal.ear_no;
  59.         IF Animal.sex = 'M'
  60.           THEN Writeln(Q,'FATHER',dummy:10)
  61.           ELSE Writeln(Q,'MOTHER',dummy:10);
  62.         RESET(infile);
  63.         rec := 1;
  64.         I   := 0;
  65.         REPEAT
  66.           Read(infile,rab);
  67.           I := I + 1;
  68.           IF (rab.sire = dummy)
  69.             THEN
  70.               BEGIN
  71.                 check(rab.dam);
  72.                 child[rec].parent := rab.dam;
  73.                 child[rec].rec_no := rab.rec_no;
  74.                 rec := rec + 1;
  75.               END;
  76.           IF (rab.dam  = dummy)
  77.             THEN
  78.               BEGIN
  79.                 check(rab.sire);
  80.                 child[rec].parent := rab.sire;
  81.                 child[rec].rec_no := rab.rec_no;
  82.                 rec := rec + 1;
  83.               END;
  84.         UNTIL EOF(infile);
  85.         FOR k := 1 TO parents - 1 DO
  86.           BEGIN
  87.             find_ear(J,parent[k]);
  88.             seek(infile,J);
  89.             Read(infile,rab);
  90.             y := y + 1;
  91.             Writeln(Q);
  92.             Write(Q,'    ',rab.name,' ':30-Length(rab.name));
  93.             IF (rab.sex = 'M')
  94.               THEN Write(Q,'FATHER')
  95.               ELSE Write(Q,'MOTHER');
  96.             Writeln(Q,rab.ear_no:10);
  97.             FOR i := 1 TO rec -1 DO
  98.               BEGIN
  99.                 IF rab.ear_no  = child[i].parent
  100.                   THEN
  101.                     BEGIN
  102.                       seek(infile,child[i].rec_no);
  103.                       Read(infile,rab_child);
  104.                       Write(Q,' ':14,rab_child.name,' ':20-Length(rab_child.name));
  105.                       Write(Q,rab_child.sex:3);
  106.                       Writeln(Q,rab_child.ear_no:7);
  107.                       y := y + 1;
  108.                     END;
  109.               END;
  110.           END; {For K := 1 to parents}
  111.         Writeln;
  112.         Writeln;
  113.       END;
  114.   escape:
  115.   ASSIGN(Q,'CON:');
  116.   REWRITE(Q);
  117.   Write('Press RETURN to continue ':50);
  118.   Readln;
  119.   ch := ^M;
  120. END;
  121.