home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol132 / biomo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  7.8 KB  |  249 lines
  1. program biograf;
  2.  
  3. const
  4.     phys = 'P';
  5.     emot = 'E';
  6.     intl = 'I';
  7.     resl = '*';
  8.     pi = 3.14159265;
  9.     blank = ' ';
  10.     dash = '-';
  11.  
  12. var
  13.     cyp, cye, cyi, lida: real;
  14.     xa, ya, pval, eval, ival, nval, cmn, cmd: integer;
  15.     pgs, wks, ndt, cyr, byr, cmo, bmo, bda: integer;
  16.     cda, hrs, adj, stl, ttl, ayr, amo, ada: integer;
  17.     printvar, ans: char;
  18.     name: array [1..30] of char;
  19.     add1: array [1..30] of char;
  20.     add2: array [1..30] of char;
  21.     add3: array [1..30] of char;
  22.     print: text;
  23.  
  24. begin
  25.     writeln( 'THIS PROGRAM COMPUTES AND PRINTS BIOGRAFS FOR A');
  26.     writeln( '     MONTHLY PERIOD.......READY? (Y/N)');
  27.     read(ans);
  28.     while ans = 'Y' do begin
  29.     writeln( 'ENTER NAME & ADDRESS....(use 4 lines)' );
  30.     read (name);
  31.     read (add1);
  32.     read (add2);
  33.     read (add3);
  34.     writeln( 'ENTER DATE & HOUR OF BIRTH....(use 24 hour clock) ');
  35.     read (bmo, bda, byr, hrs);
  36.         case bmo of
  37.             1 : bmo := 0;
  38.             2 : bmo := 31;
  39.             3 : bmo := 59;
  40.             4 : bmo := 90;
  41.             5 : bmo := 120;
  42.             6 : bmo := 151;
  43.             7 : bmo := 181;
  44.             8 : bmo := 212;
  45.             9 : bmo := 243;
  46.             10 : bmo := 273;
  47.             11 : bmo := 304;
  48.             12 : bmo := 334;
  49.         end;
  50.     writeln( 'ENTER DATE DESIRED FOR START OF BIORYTHMN....' );
  51.     read (cmo, cda, cyr);
  52.     cda := 1;
  53.     writeln( 'ENTER NUMBER OF MONTHLY CHARTS WANTED.. THEN,');
  54.     writeln( 'TOGGLE PRINTER ''ON'' ... THEN HIT RETURN KEY.');
  55.     read(wks);
  56.     for pgs := wks downto 1 do begin
  57.     cmn := cmo;
  58.     cmd := cmo;
  59.         case cmo of
  60.             1 : cmo := 0;
  61.             2 : cmo := 31;
  62.             3 : cmo := 59;
  63.             4 : cmo := 90;
  64.             5 : cmo := 120;
  65.             6 : cmo := 151;
  66.             7 : cmo := 181;
  67.             8 : cmo := 212;
  68.             9 : cmo := 243;
  69.             10 : cmo := 273;
  70.             11 : cmo := 304;
  71.             12 : cmo := 334;
  72.         end;
  73.         case cmd of
  74.             2 : cmd := 28;
  75.             4 : cmd := 30;
  76.             6 : cmd := 30;
  77.             9 : cmd := 30;
  78.             11 : cmd := 30;
  79.             else : cmd := 31;
  80.         end;
  81.     ayr := (cyr - byr) * 365;
  82.     amo := (cmo - bmo);
  83.     ada := (cda - bda);
  84.     stl := ayr + amo + ada;
  85.     adj := round((stl - 183)/1460);
  86.     ttl := stl + adj;
  87.     lida := ttl - 0.125 + (hrs/24);
  88.     rewrite( 'lst:', print);
  89.     write( print, chr(17));
  90.         writeln;
  91.         write( 'BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF ');
  92.         writeln( 'BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF');
  93.         writeln; writeln;
  94.         writeln( '        THIS' );
  95.         writeln( '      BIO-GRAF' );
  96.         writeln( '      COMPUTED' );
  97.         writeln( '     ESPECIALLY' );
  98.         writeln( '     FOR    YOU,' );
  99.         writeln; writeln; writeln;
  100.         writeln;
  101.         rewrite( 'lst:', print);
  102.         write( print, chr(27));
  103.         write( print, chr(52));
  104.         writeln( '           ', name); writeln;
  105.         writeln( '           ', add1);
  106.         writeln( '           ', add2);
  107.         writeln( '           ', add3); writeln;
  108.         rewrite( 'lst:', print);
  109.         write( print, chr(27));
  110.         write( print, chr(53));
  111.         writeln; writeln; writeln;
  112.         write( print, chr(14));
  113.         writeln( ' THIS IS YOUR BIO-GRAF FOR THE MONTH OF');
  114.         writeln;
  115.         write( print, chr(14));
  116.         case cmn of
  117.             1 : write( 'JANUARY':20);
  118.             2 : write( 'FEBRUARY':20);
  119.             3 : write( 'MARCH':20);
  120.             4 : write( 'APRIL':20);
  121.             5 : write( 'MAY':20);
  122.             6 : write( 'JUNE':20);
  123.             7 : write( 'JULY':20);
  124.             8 : write( 'AUGUST':20);
  125.             9 : write( 'SEPTEMBER':20);
  126.             10 : write( 'OCTOBER':20);
  127.             11 : write( 'NOVEMBER':20);
  128.             12 : write( 'DECEMBER':20);
  129.         end;
  130.         writeln( ' ', cyr:0);
  131.         writeln;
  132.     cyp := lida/23 - trunc(lida/23);
  133.     cye := lida/28 - trunc(lida/28);
  134.     cyi := lida/33 - trunc(lida/33);
  135.     rewrite( 'lst:', print);
  136.     write( print, chr(27));
  137.     write( print, chr(48));
  138.     if cmd = 31 then write( ' ':10, '1':20);
  139.     if cmd = 31 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3');
  140.     if cmd = 31 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  141.     if cmd = 31 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1');
  142.     if cmd = 30 then write( ' ':10, '1':20);
  143.     if cmd = 30 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3');
  144.     if cmd = 30 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  145.     if cmd = 30 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0');
  146.     if cmd = 28 then write( ' ':10, '1':20);
  147.     if cmd = 28 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2');
  148.     if cmd = 28 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  149.     if cmd = 28 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8');
  150.     cmd := (cmd * 2) + 2;
  151.     for ya := 20 downto 1 do begin
  152.         write((ya * 5):8, ' ');
  153.         for xa := 0 to cmd do begin
  154.             pval := round(sin((cyp + (xa/46)) * 2 * pi) * 20);
  155.             eval := round(sin((cye + (xa/56)) * 2 * pi) * 20);
  156.             ival := round(sin((cyi + (xa/66)) * 2 * pi) * 20);
  157.             nval := round((pval + eval + ival) div 3);
  158.             if pval = ya then printvar := phys;
  159.             if eval = ya then printvar := emot;
  160.             if ival = ya then printvar := intl;
  161.             if (pval = ya) and (eval = ya) then printvar := '2';
  162.             if (pval = ya) and (ival = ya) then printvar := '2';
  163.             if (eval = ya) and (ival = ya) then printvar := '2';
  164.             if nval = ya then printvar := resl;
  165.             if (nval <> ya) and (pval <> ya) and (eval <> ya) and (ival <> ya)
  166.                 then printvar := blank;
  167.             if (xa = 0) or (xa = cmd) then printvar := '|';
  168.             write(printvar);
  169.         end;
  170.         writeln((ya * 5): 4);
  171.     end;
  172.     write( 'CRITICAL': 5, ' ');
  173.     for xa := 0 to cmd do begin
  174.         pval := round(sin((cyp + (xa/46)) * 2 * pi) * 20);
  175.         eval := round(sin((cye + (xa/56)) * 2 * pi) * 20);
  176.         ival := round(sin((cyi + (xa/66)) * 2 * pi) * 20);
  177.         nval := round((pval + eval + ival) div 3);
  178.         if (nval = 0) then printvar := resl;
  179.         if (pval = 0) or (eval = 0) or (ival = 0) then printvar := 'C';
  180.         if (pval <> 0) and (eval <> 0) and (ival <> 0) and (nval <> 0) 
  181.             then printvar := dash;
  182.         if (xa = 0) or (xa = cmd) then printvar := '0';
  183.         write(printvar);
  184.     end;
  185.     writeln;
  186.     for ya := 1 to 20 do begin
  187.         write((ya * 5):8, ' ');
  188.         for xa := 0 to cmd do begin
  189.             pval := round(sin((cyp + (xa/46)) * 2 * pi) * 20);
  190.             eval := round(sin((cye + (xa/56)) * 2 * pi) * 20);
  191.             ival := round(sin((cyi + (xa/66)) * 2 * pi) * 20);
  192.             nval := round((pval + eval + ival) div 3);
  193.             if pval = (-ya) then printvar := phys;
  194.             if eval = (-ya) then printvar := emot;
  195.             if ival = (-ya) then printvar := intl;
  196.             if (pval = (-ya)) and (eval = (-ya)) then printvar := '2';
  197.             if (pval = (-ya)) and (ival = (-ya)) then printvar := '2';
  198.             if (eval = (-ya)) and (ival = (-ya)) then printvar := '2';
  199.             if nval = (-ya) then printvar := resl;
  200.             if (nval <> -ya) and (pval <> -ya) and (eval <> -ya) and (ival <> -ya)
  201.                 then printvar := blank;
  202.             if (xa = 0) or (xa = cmd) then printvar := '|';
  203.             write(printvar);
  204.         end;
  205.         writeln((ya * 5): 4);
  206.     end;
  207.     cmd := (cmd - 2) div 2;
  208.     if cmd = 31 then write( ' ':10, '1':20);
  209.     if cmd = 31 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3');
  210.     if cmd = 31 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  211.     if cmd = 31 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1');
  212.     if cmd = 30 then write( ' ':10, '1':20);
  213.     if cmd = 30 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3');
  214.     if cmd = 30 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  215.     if cmd = 30 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0');
  216.     if cmd = 28 then write( ' ':10, '1':20);
  217.     if cmd = 28 then writeln( ' 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 ');
  218.     if cmd = 28 then write( ' ':10, ' 1 2 3 4 5 6 7 8 9 0');
  219.     if cmd = 28 then writeln( ' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 ');
  220.     writeln; writeln; writeln;
  221.     rewrite( 'lst:', print);
  222.     write( print, chr(27));
  223.     write( print, chr(50));
  224.     write( 'BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF ');
  225.     writeln( 'BIO-GRAF BIO-GRAF BIO-GRAF BIO-GRAF');
  226.     writeln; writeln; writeln;
  227.     ndt := cmo + cda + 31;
  228.     if (ndt <32) and (ndt >0) then cmo := 1;
  229.     if (ndt <60) and (ndt >31) then cmo := 2;
  230.     if (ndt <91) and (ndt >59) then cmo := 3;
  231.     if (ndt <121) and (ndt >90) then cmo := 4;
  232.     if (ndt <152) and (ndt >120) then cmo := 5;
  233.     if (ndt <182) and (ndt >151) then cmo := 6;
  234.     if (ndt <213) and (ndt >181) then cmo := 7;
  235.     if (ndt <244) and (ndt >212) then cmo := 8;
  236.     if (ndt <274) and (ndt >243) then cmo := 9;
  237.     if (ndt <305) and (ndt >273) then cmo := 10;
  238.     if (ndt <335) and (ndt >304) then cmo := 11;
  239.     if (ndt <366) and (ndt >334) then cmo := 12;
  240.     if (ndt <400) and (ndt >365) then cmo := 1;
  241.     if (ndt <400) and (ndt >365) then cyr := cyr + 1;
  242.     end;
  243.     rewrite( 'lst:', print);
  244.     write( print, chr(19));
  245.     writeln( 'MORE TO DO?');
  246.     read(ans);
  247.     end;
  248. end.
  249.