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 / GENERAL2.INC < prev    next >
Text File  |  1979-12-31  |  7KB  |  231 lines
  1. PROCEDURE find_ear(VAR ptr : INTEGER; ear : str5 );
  2. VAR
  3.   top,
  4.   bottom,
  5.   middle,
  6.   MaxRec   : INTEGER;
  7.   temp_rab : Animal_Rec;
  8. BEGIN
  9.   initialize(Temp_Rab);
  10.   found := FALSE;
  11.   bottom := 0;
  12.   top    := filesize(infile) - 1;
  13.   REPEAT
  14.     middle := (bottom + top) DIV 2;
  15.     seek(infile,middle);
  16.     Read(infile,Temp_rab);
  17.     IF ear < Temp_rab.ear_no
  18.       THEN top := middle - 1
  19.       ELSE bottom := middle + 1;
  20.   UNTIL (ear = Temp_rab.ear_no) OR (top < bottom);
  21.   IF ear = Temp_rab.ear_no THEN
  22.       BEGIN
  23.         found := TRUE;
  24.         ptr := middle;
  25.       END
  26.     ELSE
  27.       BEGIN
  28.         found := FALSE;
  29.         ptr   := 0;
  30.       END;
  31. END;
  32.  
  33. PROCEDURE displayform;
  34. BEGIN
  35.   GotoXY(1,4);
  36.   Writeln('      Animal Number : _____            Name : ____________________   Sex : _ ');
  37.   Writeln('               Born : __ ___ 19__      Current Age :                         ');
  38.   Writeln('               Died : __ ___ 19__                          ');
  39.   Writeln('               Sire :                                      ');
  40.   Writeln('               Dam  :                                      ');
  41.   Writeln('                                                           ');
  42.   Writeln('  Comment 1  : ________________________________________    ');
  43.   Writeln('  Comment 2  : ________________________________________    ');
  44.   Writeln('  Comment 3  : ________________________________________    ');
  45.   Writeln('                    The following is used for Females only.                ');
  46.   Writeln('Date of Last Mating : __ ___ 19__                Sire :                    ');
  47.   Writeln('                                                                           ');
  48. END;
  49.  
  50. PROCEDURE display_Animal(rab : Animal_rec);
  51. {Displays the Animals information in the correct place on the form}
  52.  
  53. VAR
  54.   yy,ww,dd : INTEGER;
  55.   ok       : BOOLEAN;
  56.  
  57. BEGIN
  58.   WITH rab DO
  59.     BEGIN
  60.       dis(23,4,  ear_no);
  61.       dis(47,4,  name);
  62.       dis(76,4,  sex);
  63.       dis(23,5,  Date_Born);
  64.       dis(23,6,  Date_Died);
  65.       yy := 0;
  66.       ww := 0;
  67.       dd := 0;
  68.       verify_date(Date_Born,ok);
  69.       IF ok THEN
  70.           BEGIN
  71.             Verify_date(Date_Died,ok);
  72.             IF ok
  73.               THEN age(Date_Born,Date_Died,yy,ww,dd)
  74.               ELSE age(Date_Born,Date_Today,yy,ww,dd);
  75.             GotoXY(54,5);
  76.             IF yy > 0
  77.               THEN Write(YY:4,' Years ',ww:2,' Weeks ',dd:2,' Days')
  78.               ELSE Write(ww:4,' Weeks ',dd:2,' Days');
  79.           END;
  80.       dis(23,7,  sire);
  81.       dis(23,8,  dam);
  82.       dis(16,10, Comment_1);
  83.       dis(16,11, Comment_2);
  84.       dis(16,12, Comment_3);
  85.       IF sex = 'F' THEN
  86.           BEGIN
  87.             yy := 0;
  88.             ww := 0;
  89.             dd := 0;
  90.             dis(23,14, Date_Mated);
  91.             dis(57,14, Partner);
  92.             verify_date(Date_Mated,ok);
  93.             IF ok THEN
  94.                 BEGIN
  95.                   age(Date_Mated,Date_Today,yy,ww,dd);
  96.                   IF ww < 12 THEN
  97.                       BEGIN
  98.                         dd := dd + (ww * 7);
  99.                         GotoXY(30,15);
  100.                         Write(dd,' Days');
  101.                       END;
  102.                 END;
  103.           END;
  104.     END;
  105. END;
  106.  
  107. PROCEDURE f_table;
  108. {This routine print the numbers along the command line.  It only
  109.  prints those number which have a name beside them.}
  110.  
  111. VAR 
  112.   kx,i : INTEGER;
  113.   ch  : str1;
  114. BEGIN
  115.   kx := 2;
  116.   FOR i := 1 TO 6 DO
  117.     BEGIN
  118.       str(i,ch); {Converts i to a char so it can be printed by DIS}
  119.       IF (Animal_table[i].ear_no <> '') AND (Animal_table[i].ear_no <> 'CLEAR')
  120.         THEN
  121.           BEGIN
  122.             GotoXY(1,i+18);
  123.             ClrEOL;
  124.             WITH Animal_table[i] DO
  125.               Write(ch,'   ',name ,' ':26-Length(name),Ear_No,' ': 14-Length(Ear_No),sex);
  126.             dis(kx,17,ch);
  127.           END
  128.         ELSE
  129.           BEGIN
  130.             dis(kx,17,' '); {Delete number if Animal has been deleted}
  131.             GotoXY(1,i+18);
  132.             ClrEOL;
  133.             Write(ch);
  134.           END;
  135.       kx := kx + 4;
  136.     END;
  137. END;
  138.  
  139. PROCEDURE Animals_table(no : INTEGER; Animal : Animal_rec);
  140. BEGIN
  141.   Animal_table[no] := Animal;
  142.   f_table;
  143. END;
  144.  
  145. PROCEDURE update_Animal_Table(Animal : Animal_rec);
  146.  
  147. {Read through the 6 Animals in the table and see if its record number
  148.  matches the one that has just been edited.  If it does then print the
  149.  new information in its place.  The record number is used as it is the
  150.  only thing that cannot be change in the edit routine.}
  151.  
  152. VAR
  153.   i,l : INTEGER;
  154. BEGIN
  155.   FOR i := 1 TO 6 DO
  156.     IF Animal.rec_no = Animal_table[i].rec_no THEN
  157.         BEGIN
  158.           Animals_table(i,Animal);
  159.         END;
  160. END;
  161.  
  162. PROCEDURE InputStr(VAR S     : AnyStr;
  163.                        K,X,Y : INTEGER;
  164.                        Term  : CharSet;
  165.                    VAR TC    : CHAR);
  166.  
  167. CONST 
  168.   UnderScore  =  '_';
  169.  
  170. VAR
  171.   Ch : CHAR;
  172.   P  : INTEGER;
  173. BEGIN
  174.   P := 0;
  175.   GotoXY(X + 1,Y + 1);
  176.   Write(S,ConstStr(UnderScore,K - Length(S)));
  177.   REPEAT
  178.     GotoXY(X + P + 1,Y + 1);
  179.     Read(Kbd,Ch);
  180.     CASE Ch OF
  181.       #32..#126 : IF P < K THEN
  182.                       BEGIN
  183.                         IF Length(S) = K
  184.                           THEN
  185.                             Delete(S,K,1);
  186.                         P := P + 1;
  187.                         Insert(Ch,S,P);
  188.                         Write(Copy(S,P,K));
  189.                       END
  190.                     ELSE Beep;
  191.       ^S        : IF P > 0 THEN
  192.                       P := P - 1
  193.                     ELSE Beep;
  194.       ^D        : IF P < Length(S) THEN
  195.                       P := P + 1
  196.                     ELSE Beep;
  197.       ^A        : P := 0;
  198.       ^F        : P := Length(S);
  199.       ^G        : IF P < Length(S) THEN
  200.                       BEGIN
  201.                         Delete(S,P + 1,1);
  202.                         Write(Copy(S,P + 1,K),UnderScore);
  203.                       END;
  204.       ^H,#127   : IF P > 0 THEN
  205.                       BEGIN
  206.                         Delete(S,P,1);
  207.                         Write(^H,Copy(S,P,K),UnderScore);
  208.                         P := P - 1;
  209.                       END
  210.                     ELSE Beep;
  211.       ^Y        : BEGIN
  212.                     Write(ConstStr(UnderScore,Length(S) - P));
  213.                     Delete(S,P + 1,K);
  214.                   END;
  215.     ELSE
  216.       IF NOT (Ch IN Term)
  217.         THEN Beep;
  218.     END;  {of case}
  219.   UNTIL (Ch IN Term) OR (P = K);
  220.   P := Length(S);
  221.   GotoXY(X + P + 1,Y + 1);
  222.   Write('' :K - P);
  223.   IF (P = K)
  224.     THEN
  225.       CASE Ch OF
  226.         ^E,^Z,#27 : ;
  227.       ELSE  ch := ^X;
  228.    END;
  229.   TC := ch;
  230. END;
  231.