CP/M/CPM_CDROM.iso/beehive/utilitys/today.arc/TODAY.PAS

Pascal/Delphi Source File | 1991-08-11 | 14KB | 434 lines

{$I-,R-,C-}        {TODAY. Version 1.0. by Mick Howland 05/25/89}

Const
     area  : Byte = 13;       {User area where TODAY data files are located}
     ioval : Integer = 0;
     ioerr : Boolean = False;
     max   = 20;              {maximum number of entries from data files that}
                              {the array can hold. Increase it if you want to}
                              {but watch your available memory shrink!       }
Type
    str80 = String[80];
    str04 = String[4];

Var
   input                                            : Text;
   birthday,special,reminder                        : Array[1..max] Of str80;
   line                                             : str80;
   year,month,day,minutes,hours,weekday,b,s,r,dummy : Integer;
   bday,spec,rem,error                              : Boolean;

Procedure Initialize;
Begin
     bday:= False;
     spec:= False;
     rem:= False;
     error:= False;
     b:= Port[$FC];    {Enable external I/O port on my TRS-80 Model 4P}
     s:= b Or $10;
     Port[$EC]:= s;
     b:= 0;
     s:= 0;
     r:= 0;
End;

Function Get_Comp_Date(year,month,day: Integer) : Real;
Var
   adjust      : String[24];
   y,diy       : Real;
   temp0,temp1 : Integer;

Begin
     diy:= 365;
     adjust:= '000303060811131619212426';
     Val(Copy(adjust,(month - 1) * 2 + 1,2),temp0,temp1);
     y:= year * diy + (Int((year - 1) / 4) + (month - 1) * 28) + temp0 + day;
     If (month > 2) And ((year And Not -4) = 0) Then
        y:= y + 1;
     Get_Comp_Date:= y;
End;

Function Get_Day_Of_Week(year,month,day : Integer) : Integer;
Var
   y : Real;

Begin
     y:= Get_Comp_Date(year,month,day);
     year:= Trunc((y - Int(y / 7) * 7)- 1);
     If year < 1 Then
        year:= year + 7;
     Get_Day_Of_Week:= year;
End;

{This routine gets the time and date from the RTC. All values are integer}
{Replace this with you own routine and make sure you don't change the    }
{variable names                                                          }

Procedure Get_Date_Time;
Begin
     minutes := Port[$D0 + 5] And $0F * 10 + Port[$D0 + 4] And $0F;
     hours   := Port[$D0 + 7] And $0F * 10 + Port[$D0 + 6] And $0F;
     day     := Port[$D0 + 9] And $0F * 10 + Port[$D0 + 8] And $0F;
     month   := Port[$D0 + 11] And $0F * 10 + Port[$D0 + 10] And $0F;
     year    := Port[$D0 + 13] And $0F * 10 + Port[$D0 + 12] And $0F;
     year:= year + 1900;
     If (minutes In [0..59]) And (hours In [0..23]) And
        (day In [1..31]) And (month In [1..12]) Then
     Else
         Begin
              minutes:= 0;
              hours:= 0;
              day:= 1;
              month:= 1;
              year:= 1980;
         End;
End;

Procedure Display_Date_Time;
Begin
     Case hours Of
           0..11 : Write('Good morning.');
          12..17 : Write('Good afternoon.');
          18..23 : Write('Good evening.');
     End;
     Write(' It''s ');
     weekday:= Get_Day_Of_Week(year,month,day);
     Case weekday Of
          1 : Write('Sunday');
          2 : Write('Monday');
          3 : Write('Tuesday');
          4 : Write('Wednesday');
          5 : Write('Thursday');
          6 : Write('Friday');
          7 : Write('Saturday');
     End;
     Write(' the ',day);
     Case day Of
          1,21,31      : Write('st');
          2,22         : Write('nd');
          3,23         : Write('rd');
          4..20,24..30 : Write('th');
     End;
     Write(' of ');
     Case month Of
           1 : Write('January');
           2 : Write('February');
           3 : Write('March');
           4 : Write('April');
           5 : Write('May');
           6 : Write('June');
           7 : Write('July');
           8 : Write('August');
           9 : Write('September');
          10 : Write('October');
          11 : Write('November');
          12 : Write('December');
     End;
     Write(' ',year,'. Current time is ');
     If hours < 10 Then
        Write('0',hours)
     Else
         Write(hours);
     Write(':');
     If minutes < 10 Then
        Writeln('0',minutes)
     Else
         Writeln(minutes);
End;

Procedure Command_Line;
Var
   parameter : str04;

Begin
     parameter:= Paramstr(1);
     If parameter <> '' Then
        Begin
             Get_Date_Time;
             Val(Copy(parameter,1,2),month,dummy);
             Val(Copy(parameter,3,2),day,dummy);
             If month In [1..12] Then
                Begin
                     If day In [1..31] Then
                     Else
                         Get_Date_Time;
                End
             Else
                 Get_Date_Time;
        End
     Else
         Get_Date_Time;
     Display_Date_Time;
End;

Procedure Display(Line : Str80);
Var
   pos06,pos02 : str04;
   wday        : string[1];
   pos10       : Char;

Begin
     Str(weekday,wday);
     pos02:= Copy(line,2,4);
     pos06:= Copy(line,6,4);
     pos10:= Copy(line,10,1);
     Delete(line,1,10);
     If pos10 In ['1'..'7'] Then
        Begin
             If wday = pos10 Then
                If pos06 = '    ' Then
                   Writeln(' ',line)
                Else
                    Writeln(' In ',pos06,' ',line);
        End
     Else
         If pos10 = 'C' Then
            Writeln('         ',line)
         Else
             If pos06 = '    ' Then
                Writeln(' ',line)
             Else
                Writeln(' In ',pos06,' ',line);
End;

Procedure List_Arrays;
Var
   i : Integer;

Begin
     Writeln;
     If bday Then
        Begin
             Writeln('Happy Birthday to...');
             For i:= 1 To b Do
                 Display(birthday[i]);
        End
     Else
         Begin
              Writeln;
              Writeln('Happy Birthday to...');
              Writeln(' Absolutely no one in particular!');
         End;
     If spec Then
        Begin
             Writeln;
             Writeln('On this day...');
             For i:= 1 To s Do
                 Display(special[i]);
        End
     Else
         Begin
              Writeln;
              Writeln('On this day...');
              Writeln(' Absolutely nothing happend. Amazing!');
         End;
     If rem Then
        Begin
             Writeln;
             Writeln('Remember...');
             For i:= 1 To r Do
                 Begin
                      Delete(reminder[i],1,10);
                      Writeln(' ',reminder[i]);
                 End;
        End;
     Writeln;
End;

Procedure Store_Reminder;
Var
   wday : Integer;

Begin
     Val(Copy(line,10,1),wday,dummy);
     If dummy <> 0 Then
        wday:= 0;
     If (wday = 0) And (r <> max) Then
        Begin
             r:= r + 1;
             reminder[r]:= line;
             rem:= True;
        End
     Else
         If (weekday = wday) And (r <> max) Then
            Begin
             r:= r + 1;
             reminder[r]:= line;
             rem:= True;
        End;
End;

Procedure Load_Arrays;
Var
   pos6to10                             : str04;
   bsr                                  : Char;
   date1,date2,date3                    : Real;
   date4,date5,date6,date7,os0,os1,wday : Integer;

Begin
     os0:= 0;
     os1:= 0;
     Val(Copy(line,2,2),date4,dummy);
     Val(Copy(line,4,2),date5,dummy);
     Val(Copy(line,10,1),wday,dummy);
     If dummy <> 0 Then
        wday:= 0;
     pos6to10:= Copy(line,6,4);
     bsr:= Copy(line,1,1);
     Begin
          Case bsr Of
               'B' : Begin
                          If (month = date4) And (day = date5) Then
                             If (wday = 0) And (b <> max) Then
                                Begin
                                     b:= b + 1;
                                     birthday[b]:= line;
                                     bday:= True;
                                End
                             Else
                                 Begin
                                      If (weekday = wday) And (b <> max) Then
                                         Begin
                                              b:= b + 1;
                                              birthday[b]:= line;
                                              bday:= True;
                                         End;
                                 End;
                     End;
               'S' : Begin
                          If (month = date4) And (day = date5) Then
                             If (wday = 0) And (s <> max) Then
                                Begin
                                     s:= s + 1;
                                     special[s]:= line;
                                     spec:= True;
                                End
                             Else
                                 Begin
                                      If (weekday = wday) And (s <> max) Then
                                         Begin
                                              s:= s + 1;
                                              special[s]:= line;
                                              spec:= True;
                                         End;
                                 End;
                     End;
               'R' : Begin
                          Val(Copy(line,6,2),date6,dummy);
                          Val(Copy(line,8,2),date7,dummy);
                          If pos6to10 = '    ' Then
                             Begin
                                  If date4 = 0 Then
                                     If day = date5 Then
                                        Store_Reminder;
                                  If date5 = 0 Then
                                     If month = date4 Then
                                        Store_Reminder;
                                  If month = date4 Then
                                     If day = date5 Then
                                        Store_Reminder;
                             End
                          Else
                              Begin
                                   If (date4 = 0) And (date6 = 0) Then
                                      If day In [date5..date7] Then
                                         Store_Reminder;
                                   If date4 > date6 Then
                                      If (month >= (date6 + 1)) And
                                         (month <= (date4 - 1)) Then
                                      Else
                                          Begin
                                               If (date5 = 0) And (date7 = 0) Then
                                                  Store_Reminder;
                                          End
                                   Else
                                       Begin
                                            If (month In [date4..date6]) And
                                               (date5 = 0) And (date7 = 0) Then
                                               Store_Reminder;
                                       End;
                                   If (date4 <> 0) And (date6 <> 0) And
                                      (date5 <> 0) And (date7 <> 0) Then
                                      Begin
                                           If date4 > date6 Then
                                              Begin
                                                   If month >= date4 Then
                                                      Begin
                                                           os0:= 1;
                                                           os1:= 0;
                                                      End
                                                   Else
                                                       Begin
                                                            os0:= 0;
                                                            os1:= 1;
                                                       End;
                                              End;
                                           date1:= Get_Comp_Date(year - os1,date4,date5);
                                           date2:= Get_Comp_Date(year + os0,date6,date7);
                                           date3:= Get_Comp_Date(year,month,day);
                                           If (date3 >= date1) And (date3 <= date2) Then
                                              Store_Reminder;
                                      End;
                              End;
                     End;
          End;
     End;
End;

Procedure Io_Check;
Begin
     ioval:= ioresult;
     ioerr:= (ioval <> 0);
     If ioerr Then
        Begin
             If ioval = 1 Then
                Writeln('TODAY data files not found in user area ',area)
             Else
                 Writeln('Error has occured while reading TODAY data file.');
             error:= True;
        End;
End;

Procedure Open_File;
Var
   ext  : String[3];
   user : Byte;

Begin
     line:= 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
     user:= Bdos($20,$00ff);
     Bdos($20,area);
     ext:= Copy(line,(month - 1) * 3 + 1,3);
     Assign(input,'TODAY.' + ext);
     Io_Check;
     Reset(input);
     Io_Check;
     While (Not Eof(input)) And (Not ioerr) Do
           Begin
                Readln(input,line);
                Io_Check;
                Load_Arrays;
           End;
     Close(input);
     Assign(input,'TODAY.OWN');
     Io_Check;
     Reset(input);
     Io_Check;
     While (Not Eof(input)) And (Not ioerr)  Do
           Begin
                Readln(input,line);
                Io_Check;
                Load_Arrays;
           End;
     Close(input);
     Bdos($20,user);
     If Not error Then
        List_Arrays;
End;

Begin
     Initialize;
     Command_line;
     Open_File;
End.