home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol148 / biosin.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  8.2 KB  |  307 lines
  1. PROGRAM BIOSIN;
  2.  
  3. (*      Permission is hereby granted to republish,
  4.  *      but not for profit, any or all of this program,
  5.  *      provided that this copyright notice is included
  6.  *
  7.  *      Copyright 1978, Oregon Minicomputer Software, Inc.
  8.  *              2340 SW Canyon Road
  9.  *              Portland, Oregon 97201
  10.  *              (503) 226-7760
  11.  *)
  12.  
  13. CONST   MAXCHAR= 64;
  14.         PI= 3.141592;
  15.  
  16. TYPE    PLOTVALUE=      RECORD
  17.                         SPACENUMBER:    INTEGER;
  18.                         PLOTKIND:       CHAR;
  19.                         END;
  20.         LINEARRAY=      ARRAY [1..4] OF PLOTVALUE;
  21.         MONTHS= (MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC,JAN,FEB);
  22.         MONTHASCII= ARRAY [1..3] OF CHAR;
  23.         STRINGTYPE= ARRAY [1..10] OF CHAR;
  24.         DATES=  RECORD
  25.                 DAY:    INTEGER;
  26.                 MON:    MONTHASCII;
  27.                 MONTH:  MONTHS;
  28.                 YEAR:   INTEGER;
  29.                 ABSOLUTE: INTEGER;
  30.                 END;
  31.  
  32. VAR     MO:     MONTHASCII;
  33.         MONTH:  MONTHS;
  34.         DA,YR,PLOTABS,BIRTHABS,JULIANDATE,DAYSALIVE: INTEGER;
  35.         ERRORFLAG: BOOLEAN;
  36.         FIRSTTIME: BOOLEAN;
  37.         MAXDAY,I,MONTHSTOPLOT:  INTEGER;
  38.         CURRENTLINE:    LINEARRAY;
  39.         SINVAL33,SINVAL28,SINVAL23: INTEGER;
  40.         BDATE,PDATE: DATES;
  41.  
  42.  
  43. FUNCTION XROUND (INPUT:REAL): INTEGER;
  44. VAR ROUNDX: INTEGER;
  45. BEGIN
  46. IF INPUT >= 0 THEN ROUNDX:= TRUNC(INPUT + 0.5)
  47. ELSE ROUNDX:= TRUNC(INPUT - 0.5);
  48. XROUND:= ROUNDX;
  49. END;
  50.  
  51. PROCEDURE SINVALUE (PERIOD,DAYSALIVE,DAYOFMONTH:INTEGER;
  52.                                 VAR SINCHAREQUIV:INTEGER);
  53. VAR PERIODFRACTION: REAL;
  54.     STARTOFFSET: INTEGER;
  55. BEGIN
  56. STARTOFFSET:= DAYSALIVE MOD PERIOD;
  57. PERIODFRACTION:= ((STARTOFFSET + DAYOFMONTH - 1) / PERIOD) * 2 * PI;
  58. SINCHAREQUIV:= XROUND((SIN(PERIODFRACTION) + 1) * MAXCHAR) DIV 2;
  59. END;
  60.  
  61. PROCEDURE JULIAN(MONTH: MONTHS;DA: INTEGER;VAR JULIANDATE: INTEGER);
  62. BEGIN
  63. CASE MONTH OF
  64.         MAR: BEGIN MAXDAY:= 31;JULIANDATE:= DA; END;
  65.         APR: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 31; END;
  66.         MAY: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 61; END;
  67.         JUN: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 92; END;
  68.         JUL: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 122; END;
  69.         AUG: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 153; END;
  70.         SEP: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 184; END;
  71.         OCT: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 214; END;
  72.         NOV: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 245; END;
  73.         DEC: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 275; END;
  74.         JAN: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 306; END;
  75.         FEB: BEGIN
  76.              IF YR MOD 4 = 3 THEN MAXDAY:= 29
  77.              ELSE MAXDAY:= 28;
  78.              JULIANDATE:= DA + 337;
  79.              END;
  80.         END;
  81. END;
  82.  
  83. PROCEDURE ERROR ( STRING: STRINGTYPE);
  84. BEGIN
  85. WRITELN ('ERROR IN ENTRY OF ', STRING);
  86. ERRORFLAG:= TRUE;
  87. END;
  88.  
  89. PROCEDURE ABSOLUTEDATE (VAR DATE:DATES);
  90. VAR JULIANDATE: INTEGER;
  91.     MONTHERROR,YEARERROR: BOOLEAN;
  92. BEGIN
  93. MONTHERROR:= FALSE;
  94. YEARERROR:= FALSE;
  95. WITH DATE DO
  96.     BEGIN
  97.     IF FIRSTTIME THEN
  98.         BEGIN
  99.         IF MO = 'MAR' THEN MONTH:= MAR
  100.         ELSE IF MO = 'APR' THEN MONTH:= APR
  101.         ELSE IF MO = 'MAY' THEN MONTH:= MAY
  102.         ELSE IF MO = 'JUN' THEN MONTH:= JUN
  103.         ELSE IF MO = 'JUL' THEN MONTH:= JUL
  104.         ELSE IF MO = 'AUG' THEN MONTH:= AUG
  105.         ELSE IF MO = 'SEP' THEN MONTH:= SEP
  106.         ELSE IF MO = 'OCT' THEN MONTH:= OCT
  107.         ELSE IF MO = 'NOV' THEN MONTH:= NOV
  108.         ELSE IF MO = 'DEC' THEN MONTH:= DEC
  109.         ELSE IF MO = 'JAN' THEN MONTH:= JAN
  110.         ELSE IF MO = 'FEB' THEN MONTH:= FEB
  111.         ELSE MONTHERROR:= TRUE;
  112.         END;
  113.     IF MONTH > DEC THEN YR:= YEAR - 1 ELSE YR:= YEAR;
  114.     IF YR < 0 THEN YEARERROR:= TRUE;
  115.     ABSOLUTE:= YR DIV 4 * 1461 + YR MOD 4 * 365;
  116.     END;
  117. IF MONTHERROR THEN ERROR ('MONTH     ');
  118. IF YEARERROR THEN ERROR ('YEAR      ');
  119. JULIAN (DATE.MONTH,DATE.DAY,JULIANDATE);
  120. WITH DATE DO ABSOLUTE:= ABSOLUTE + JULIANDATE;
  121. END;
  122.  
  123. PROCEDURE SORT (VAR INOUT: LINEARRAY);
  124. VAR     TEMPHOLDER:     PLOTVALUE;
  125.         I:              INTEGER;
  126. BEGIN
  127. FOR I:= 1 TO 3 DO
  128.         BEGIN
  129.         IF INOUT[ I ].SPACENUMBER > INOUT[ I+1 ].SPACENUMBER THEN
  130.                 BEGIN
  131.                 TEMPHOLDER:= INOUT[ I ];
  132.                 INOUT[ I ]:= INOUT[ I+1 ];
  133.                 INOUT[ I+1 ]:= TEMPHOLDER;
  134.                 IF I >= 2 THEN I:= I - 2;
  135.                 END;
  136.         END;
  137. END;
  138.  
  139. PROCEDURE LINEARRANGE (VAR INOUT: LINEARRAY);
  140. VAR I: INTEGER;
  141. BEGIN
  142. FOR I:= 4 DOWNTO 2 DO
  143.     BEGIN
  144.     INOUT[I].SPACENUMBER:=
  145.                 INOUT[I].SPACENUMBER - INOUT[I-1].SPACENUMBER;
  146.     IF INOUT[I].SPACENUMBER = 0 THEN
  147.         BEGIN
  148.         IF (INOUT[I].PLOTKIND<>':')&(INOUT[I-1].PLOTKIND<>':') THEN
  149.             BEGIN
  150.             INOUT[I].PLOTKIND:= 'X';
  151.             INOUT[I-1].PLOTKIND:= 'X';
  152.             END
  153.         ELSE
  154.             BEGIN
  155.             IF INOUT[I].PLOTKIND = ':' THEN INOUT[I].PLOTKIND:=
  156.                                         INOUT[I-1].PLOTKIND
  157.             ELSE INOUT[I-1].PLOTKIND:= INOUT[I].PLOTKIND;
  158.             END;
  159.         END;
  160.     END;
  161. WITH INOUT[1] DO SPACENUMBER:= SPACENUMBER + 2;
  162. END;
  163.  
  164. PROCEDURE MAKESPACES (NUMBER:INTEGER);
  165. VAR I: INTEGER;
  166. BEGIN
  167. FOR I:= 1 TO NUMBER DO WRITE(' ');
  168. END;
  169.  
  170. PROCEDURE MAKELINEFEEDS (NUMBER:INTEGER);
  171. VAR I: INTEGER;
  172. BEGIN
  173. FOR I:= 1 TO NUMBER DO WRITELN;
  174. END;
  175.  
  176. PROCEDURE MAKESIGNS;
  177. VAR I: INTEGER;
  178. BEGIN
  179. MAKESPACES (MAXCHAR DIV 4 + 3);
  180. WRITE('-');
  181. MAKESPACES (MAXCHAR DIV 2);
  182. WRITELN('+');
  183. END;
  184.  
  185. PROCEDURE MAKECOLON;
  186. VAR I: INTEGER;
  187. BEGIN
  188. MAKESPACES (MAXCHAR DIV 2 + 3);
  189. WRITELN(':');
  190. END;
  191.  
  192. PROCEDURE COMPUTE (DAYSALIVE,DA:INTEGER;VAR CURRENTLINE: LINEARRAY);
  193. BEGIN
  194. SINVALUE (33,DAYSALIVE,DA,SINVAL33);
  195. SINVALUE (28,DAYSALIVE,DA,SINVAL28);
  196. SINVALUE (23,DAYSALIVE,DA,SINVAL23);
  197. WITH CURRENTLINE[1] DO
  198.         BEGIN
  199.         SPACENUMBER:= SINVAL33;
  200.         PLOTKIND:= 'I';
  201.         END;
  202. WITH CURRENTLINE[2] DO
  203.         BEGIN
  204.         SPACENUMBER:= SINVAL28;
  205.         PLOTKIND:= 'E';
  206.         END;
  207. WITH CURRENTLINE[3] DO
  208.         BEGIN
  209.         SPACENUMBER:= SINVAL23;
  210.         PLOTKIND:= 'P';
  211.         END;
  212. WITH CURRENTLINE[4] DO
  213.         BEGIN
  214.         SPACENUMBER:= MAXCHAR DIV 2;
  215.         PLOTKIND:= ':';
  216.         END;
  217. END;
  218.  
  219. PROCEDURE PRINTCHART;
  220. VAR DA:INTEGER;
  221.     I:INTEGER;
  222. BEGIN
  223. IF FIRSTTIME THEN I:= 10 ELSE I:= 2;
  224. MAKELINEFEEDS (I);
  225. IF FIRSTTIME THEN WRITELN('BIRTHDATE = ',
  226.             BDATE.DAY:2,' ',BDATE.MON,' ',(BDATE.YEAR + 1900):4);
  227. WRITELN('PLOT FOR THE MONTH OF ',PDATE.MON,' ',
  228.                         (PDATE.YEAR + 1900):4);
  229. IF FIRSTTIME THEN MAKESIGNS;
  230. MAKECOLON;
  231. FOR DA:= 1 TO MAXDAY DO
  232.         BEGIN
  233.         COMPUTE (DAYSALIVE,DA,CURRENTLINE);
  234.         SORT(CURRENTLINE);
  235.         LINEARRANGE(CURRENTLINE);
  236.         WRITE(DA:2);
  237.         FOR I:= 1 TO 4 DO
  238.           BEGIN
  239.           MAKESPACES(CURRENTLINE[I].SPACENUMBER - 1);
  240.           IF CURRENTLINE[I].SPACENUMBER <> 0 THEN
  241.                 WRITE(CURRENTLINE[I].PLOTKIND);
  242.           END;
  243.         WRITELN;
  244.         MAKECOLON;
  245.         END;
  246. END;
  247.  
  248. PROCEDURE MONTHDECODE (INPUTMONTH:MONTHS;VAR MONTH:MONTHASCII);
  249. BEGIN
  250. CASE INPUTMONTH OF
  251.         JAN:    MONTH:= 'JAN';
  252.         FEB:    MONTH:= 'FEB';
  253.         MAR:    MONTH:= 'MAR';
  254.         APR:    MONTH:= 'APR';
  255.         MAY:    MONTH:= 'MAY';
  256.         JUN:    MONTH:= 'JUN';
  257.         JUL:    MONTH:= 'JUL';
  258.         AUG:    MONTH:= 'AUG';
  259.         SEP:    MONTH:= 'SEP';
  260.         OCT:    MONTH:= 'OCT';
  261.         NOV:    MONTH:= 'NOV';
  262.         DEC:    MONTH:= 'DEC';
  263.      END;
  264. END;
  265.  
  266. (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
  267. BEGIN
  268. FIRSTTIME:= TRUE;
  269. ERRORFLAG:= FALSE;
  270. WRITE('BIRTHDATE? ');
  271. READLN(DA,MO,YR);
  272. WITH BDATE DO
  273.     BEGIN
  274.     DAY:= DA;
  275.     MON:= MO;
  276.     YEAR:= YR;
  277.     END;
  278. ABSOLUTEDATE(BDATE);
  279. IF   (DA < 1) OR (DA > MAXDAY)   THEN ERROR ('DATE      ');
  280. WRITE('MONTH TO START PLOT? ');
  281. READLN(MO,YR);
  282. WITH PDATE DO
  283.     BEGIN
  284.     DAY:= 1;
  285.     MON:= MO;
  286.     YEAR:= YR;
  287.     END;
  288. ABSOLUTEDATE(PDATE);
  289. DAYSALIVE:= PDATE.ABSOLUTE - BDATE.ABSOLUTE;
  290. IF DAYSALIVE < 0 THEN ERROR ('PLOT MONTH');
  291. WRITE('NUMBER OF MONTHS TO PLOT? ');
  292. READLN(MONTHSTOPLOT);
  293. FOR I:= 1 TO MONTHSTOPLOT DO
  294.     BEGIN
  295.     IF NOT ERRORFLAG THEN PRINTCHART;    FIRSTTIME:= FALSE;
  296.     WITH PDATE DO
  297.         BEGIN
  298.         IF MONTH = DEC THEN YEAR:= YEAR + 1;
  299.         IF MONTH <> FEB THEN MONTH:= SUCC(MONTH)
  300.         ELSE MONTH:= MAR;
  301.         END;
  302.     MONTHDECODE (PDATE.MONTH,PDATE.MON);
  303.     ABSOLUTEDATE (PDATE);
  304.     DAYSALIVE:= PDATE.ABSOLUTE - BDATE.ABSOLUTE;
  305.     END;
  306. END.
  307.