PROGRAM BIOSIN;

(*      Permission is hereby granted to republish,
 *      but not for profit, any or all of this program,
 *      provided that this copyright notice is included
 *
 *      Copyright 1978, Oregon Minicomputer Software, Inc.
 *              2340 SW Canyon Road
 *              Portland, Oregon 97201
 *              (503) 226-7760
 *)

CONST   MAXCHAR= 64;
        PI= 3.141592;

TYPE    PLOTVALUE=      RECORD
                        SPACENUMBER:    INTEGER;
                        PLOTKIND:       CHAR;
                        END;
        LINEARRAY=      ARRAY [1..4] OF PLOTVALUE;
        MONTHS= (MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC,JAN,FEB);
        MONTHASCII= ARRAY [1..3] OF CHAR;
        STRINGTYPE= ARRAY [1..10] OF CHAR;
        DATES=  RECORD
                DAY:    INTEGER;
                MON:    MONTHASCII;
                MONTH:  MONTHS;
                YEAR:   INTEGER;
                ABSOLUTE: INTEGER;
                END;

VAR     MO:     MONTHASCII;
        MONTH:  MONTHS;
        DA,YR,PLOTABS,BIRTHABS,JULIANDATE,DAYSALIVE: INTEGER;
        ERRORFLAG: BOOLEAN;
        FIRSTTIME: BOOLEAN;
        MAXDAY,I,MONTHSTOPLOT:  INTEGER;
        CURRENTLINE:    LINEARRAY;
        SINVAL33,SINVAL28,SINVAL23: INTEGER;
        BDATE,PDATE: DATES;


FUNCTION XROUND (INPUT:REAL): INTEGER;
VAR ROUNDX: INTEGER;
BEGIN
IF INPUT >= 0 THEN ROUNDX:= TRUNC(INPUT + 0.5)
ELSE ROUNDX:= TRUNC(INPUT - 0.5);
XROUND:= ROUNDX;
END;

PROCEDURE SINVALUE (PERIOD,DAYSALIVE,DAYOFMONTH:INTEGER;
                                VAR SINCHAREQUIV:INTEGER);
VAR PERIODFRACTION: REAL;
    STARTOFFSET: INTEGER;
BEGIN
STARTOFFSET:= DAYSALIVE MOD PERIOD;
PERIODFRACTION:= ((STARTOFFSET + DAYOFMONTH - 1) / PERIOD) * 2 * PI;
SINCHAREQUIV:= XROUND((SIN(PERIODFRACTION) + 1) * MAXCHAR) DIV 2;
END;

PROCEDURE JULIAN(MONTH: MONTHS;DA: INTEGER;VAR JULIANDATE: INTEGER);
BEGIN
CASE MONTH OF
        MAR: BEGIN MAXDAY:= 31;JULIANDATE:= DA; END;
        APR: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 31; END;
        MAY: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 61; END;
        JUN: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 92; END;
        JUL: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 122; END;
        AUG: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 153; END;
        SEP: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 184; END;
        OCT: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 214; END;
        NOV: BEGIN MAXDAY:= 30;JULIANDATE:= DA + 245; END;
        DEC: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 275; END;
        JAN: BEGIN MAXDAY:= 31;JULIANDATE:= DA + 306; END;
        FEB: BEGIN
             IF YR MOD 4 = 3 THEN MAXDAY:= 29
             ELSE MAXDAY:= 28;
             JULIANDATE:= DA + 337;
             END;
        END;
END;

PROCEDURE ERROR ( STRING: STRINGTYPE);
BEGIN
WRITELN ('ERROR IN ENTRY OF ', STRING);
ERRORFLAG:= TRUE;
END;

PROCEDURE ABSOLUTEDATE (VAR DATE:DATES);
VAR JULIANDATE: INTEGER;
    MONTHERROR,YEARERROR: BOOLEAN;
BEGIN
MONTHERROR:= FALSE;
YEARERROR:= FALSE;
WITH DATE DO
    BEGIN
    IF FIRSTTIME THEN
        BEGIN
        IF MO = 'MAR' THEN MONTH:= MAR
        ELSE IF MO = 'APR' THEN MONTH:= APR
        ELSE IF MO = 'MAY' THEN MONTH:= MAY
        ELSE IF MO = 'JUN' THEN MONTH:= JUN
        ELSE IF MO = 'JUL' THEN MONTH:= JUL
        ELSE IF MO = 'AUG' THEN MONTH:= AUG
        ELSE IF MO = 'SEP' THEN MONTH:= SEP
        ELSE IF MO = 'OCT' THEN MONTH:= OCT
        ELSE IF MO = 'NOV' THEN MONTH:= NOV
        ELSE IF MO = 'DEC' THEN MONTH:= DEC
        ELSE IF MO = 'JAN' THEN MONTH:= JAN
        ELSE IF MO = 'FEB' THEN MONTH:= FEB
        ELSE MONTHERROR:= TRUE;
        END;
    IF MONTH > DEC THEN YR:= YEAR - 1 ELSE YR:= YEAR;
    IF YR < 0 THEN YEARERROR:= TRUE;
    ABSOLUTE:= YR DIV 4 * 1461 + YR MOD 4 * 365;
    END;
IF MONTHERROR THEN ERROR ('MONTH     ');
IF YEARERROR THEN ERROR ('YEAR      ');
JULIAN (DATE.MONTH,DATE.DAY,JULIANDATE);
WITH DATE DO ABSOLUTE:= ABSOLUTE + JULIANDATE;
END;

PROCEDURE SORT (VAR INOUT: LINEARRAY);
VAR     TEMPHOLDER:     PLOTVALUE;
        I:              INTEGER;
BEGIN
FOR I:= 1 TO 3 DO
        BEGIN
        IF INOUT[ I ].SPACENUMBER > INOUT[ I+1 ].SPACENUMBER THEN
                BEGIN
                TEMPHOLDER:= INOUT[ I ];
                INOUT[ I ]:= INOUT[ I+1 ];
                INOUT[ I+1 ]:= TEMPHOLDER;
                IF I >= 2 THEN I:= I - 2;
                END;
        END;
END;

PROCEDURE LINEARRANGE (VAR INOUT: LINEARRAY);
VAR I: INTEGER;
BEGIN
FOR I:= 4 DOWNTO 2 DO
    BEGIN
    INOUT[I].SPACENUMBER:=
                INOUT[I].SPACENUMBER - INOUT[I-1].SPACENUMBER;
    IF INOUT[I].SPACENUMBER = 0 THEN
        BEGIN
        IF (INOUT[I].PLOTKIND<>':')&(INOUT[I-1].PLOTKIND<>':') THEN
            BEGIN
            INOUT[I].PLOTKIND:= 'X';
            INOUT[I-1].PLOTKIND:= 'X';
            END
        ELSE
            BEGIN
            IF INOUT[I].PLOTKIND = ':' THEN INOUT[I].PLOTKIND:=
                                        INOUT[I-1].PLOTKIND
            ELSE INOUT[I-1].PLOTKIND:= INOUT[I].PLOTKIND;
            END;
        END;
    END;
WITH INOUT[1] DO SPACENUMBER:= SPACENUMBER + 2;
END;

PROCEDURE MAKESPACES (NUMBER:INTEGER);
VAR I: INTEGER;
BEGIN
FOR I:= 1 TO NUMBER DO WRITE(' ');
END;

PROCEDURE MAKELINEFEEDS (NUMBER:INTEGER);
VAR I: INTEGER;
BEGIN
FOR I:= 1 TO NUMBER DO WRITELN;
END;

PROCEDURE MAKESIGNS;
VAR I: INTEGER;
BEGIN
MAKESPACES (MAXCHAR DIV 4 + 3);
WRITE('-');
MAKESPACES (MAXCHAR DIV 2);
WRITELN('+');
END;

PROCEDURE MAKECOLON;
VAR I: INTEGER;
BEGIN
MAKESPACES (MAXCHAR DIV 2 + 3);
WRITELN(':');
END;

PROCEDURE COMPUTE (DAYSALIVE,DA:INTEGER;VAR CURRENTLINE: LINEARRAY);
BEGIN
SINVALUE (33,DAYSALIVE,DA,SINVAL33);
SINVALUE (28,DAYSALIVE,DA,SINVAL28);
SINVALUE (23,DAYSALIVE,DA,SINVAL23);
WITH CURRENTLINE[1] DO
        BEGIN
        SPACENUMBER:= SINVAL33;
        PLOTKIND:= 'I';
        END;
WITH CURRENTLINE[2] DO
        BEGIN
        SPACENUMBER:= SINVAL28;
        PLOTKIND:= 'E';
        END;
WITH CURRENTLINE[3] DO
        BEGIN
        SPACENUMBER:= SINVAL23;
        PLOTKIND:= 'P';
        END;
WITH CURRENTLINE[4] DO
        BEGIN
        SPACENUMBER:= MAXCHAR DIV 2;
        PLOTKIND:= ':';
        END;
END;

PROCEDURE PRINTCHART;
VAR DA:INTEGER;
    I:INTEGER;
BEGIN
IF FIRSTTIME THEN I:= 10 ELSE I:= 2;
MAKELINEFEEDS (I);
IF FIRSTTIME THEN WRITELN('BIRTHDATE = ',
            BDATE.DAY:2,' ',BDATE.MON,' ',(BDATE.YEAR + 1900):4);
WRITELN('PLOT FOR THE MONTH OF ',PDATE.MON,' ',
                        (PDATE.YEAR + 1900):4);
IF FIRSTTIME THEN MAKESIGNS;
MAKECOLON;
FOR DA:= 1 TO MAXDAY DO
        BEGIN
        COMPUTE (DAYSALIVE,DA,CURRENTLINE);
        SORT(CURRENTLINE);
        LINEARRANGE(CURRENTLINE);
        WRITE(DA:2);
        FOR I:= 1 TO 4 DO
          BEGIN
          MAKESPACES(CURRENTLINE[I].SPACENUMBER - 1);
          IF CURRENTLINE[I].SPACENUMBER <> 0 THEN
                WRITE(CURRENTLINE[I].PLOTKIND);
          END;
        WRITELN;
        MAKECOLON;
        END;
END;

PROCEDURE MONTHDECODE (INPUTMONTH:MONTHS;VAR MONTH:MONTHASCII);
BEGIN
CASE INPUTMONTH OF
        JAN:    MONTH:= 'JAN';
        FEB:    MONTH:= 'FEB';
        MAR:    MONTH:= 'MAR';
        APR:    MONTH:= 'APR';
        MAY:    MONTH:= 'MAY';
        JUN:    MONTH:= 'JUN';
        JUL:    MONTH:= 'JUL';
        AUG:    MONTH:= 'AUG';
        SEP:    MONTH:= 'SEP';
        OCT:    MONTH:= 'OCT';
        NOV:    MONTH:= 'NOV';
        DEC:    MONTH:= 'DEC';
     END;
END;

(* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
BEGIN
FIRSTTIME:= TRUE;
ERRORFLAG:= FALSE;
WRITE('BIRTHDATE? ');
READLN(DA,MO,YR);
WITH BDATE DO
    BEGIN
    DAY:= DA;
    MON:= MO;
    YEAR:= YR;
    END;
ABSOLUTEDATE(BDATE);
IF   (DA < 1) OR (DA > MAXDAY)   THEN ERROR ('DATE      ');
WRITE('MONTH TO START PLOT? ');
READLN(MO,YR);
WITH PDATE DO
    BEGIN
    DAY:= 1;
    MON:= MO;
    YEAR:= YR;
    END;
ABSOLUTEDATE(PDATE);
DAYSALIVE:= PDATE.ABSOLUTE - BDATE.ABSOLUTE;
IF DAYSALIVE < 0 THEN ERROR ('PLOT MONTH');
WRITE('NUMBER OF MONTHS TO PLOT? ');
READLN(MONTHSTOPLOT);
FOR I:= 1 TO MONTHSTOPLOT DO
    BEGIN
    IF NOT ERRORFLAG THEN PRINTCHART;    FIRSTTIME:= FALSE;
    WITH PDATE DO
        BEGIN
        IF MONTH = DEC THEN YEAR:= YEAR + 1;
        IF MONTH <> FEB THEN MONTH:= SUCC(MONTH)
        ELSE MONTH:= MAR;
        END;
    MONTHDECODE (PDATE.MONTH,PDATE.MON);
    ABSOLUTEDATE (PDATE);
    DAYSALIVE:= PDATE.ABSOLUTE - BDATE.ABSOLUTE;
    END;
END.