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 / BEEHIVE / UTILITYS / TODAY.ARC / TODAY.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-11  |  14KB  |  434 lines
  1. {$I-,R-,C-}        {TODAY. Version 1.0. by Mick Howland 05/25/89}
  2.  
  3. Const
  4.      area  : Byte = 13;       {User area where TODAY data files are located}
  5.      ioval : Integer = 0;
  6.      ioerr : Boolean = False;
  7.      max   = 20;              {maximum number of entries from data files that}
  8.                               {the array can hold. Increase it if you want to}
  9.                               {but watch your available memory shrink!       }
  10. Type
  11.     str80 = String[80];
  12.     str04 = String[4];
  13.  
  14. Var
  15.    input                                            : Text;
  16.    birthday,special,reminder                        : Array[1..max] Of str80;
  17.    line                                             : str80;
  18.    year,month,day,minutes,hours,weekday,b,s,r,dummy : Integer;
  19.    bday,spec,rem,error                              : Boolean;
  20.  
  21. Procedure Initialize;
  22. Begin
  23.      bday:= False;
  24.      spec:= False;
  25.      rem:= False;
  26.      error:= False;
  27.      b:= Port[$FC];    {Enable external I/O port on my TRS-80 Model 4P}
  28.      s:= b Or $10;
  29.      Port[$EC]:= s;
  30.      b:= 0;
  31.      s:= 0;
  32.      r:= 0;
  33. End;
  34.  
  35. Function Get_Comp_Date(year,month,day: Integer) : Real;
  36. Var
  37.    adjust      : String[24];
  38.    y,diy       : Real;
  39.    temp0,temp1 : Integer;
  40.  
  41. Begin
  42.      diy:= 365;
  43.      adjust:= '000303060811131619212426';
  44.      Val(Copy(adjust,(month - 1) * 2 + 1,2),temp0,temp1);
  45.      y:= year * diy + (Int((year - 1) / 4) + (month - 1) * 28) + temp0 + day;
  46.      If (month > 2) And ((year And Not -4) = 0) Then
  47.         y:= y + 1;
  48.      Get_Comp_Date:= y;
  49. End;
  50.  
  51. Function Get_Day_Of_Week(year,month,day : Integer) : Integer;
  52. Var
  53.    y : Real;
  54.  
  55. Begin
  56.      y:= Get_Comp_Date(year,month,day);
  57.      year:= Trunc((y - Int(y / 7) * 7)- 1);
  58.      If year < 1 Then
  59.         year:= year + 7;
  60.      Get_Day_Of_Week:= year;
  61. End;
  62.  
  63. {This routine gets the time and date from the RTC. All values are integer}
  64. {Replace this with you own routine and make sure you don't change the    }
  65. {variable names                                                          }
  66.  
  67. Procedure Get_Date_Time;
  68. Begin
  69.      minutes := Port[$D0 + 5] And $0F * 10 + Port[$D0 + 4] And $0F;
  70.      hours   := Port[$D0 + 7] And $0F * 10 + Port[$D0 + 6] And $0F;
  71.      day     := Port[$D0 + 9] And $0F * 10 + Port[$D0 + 8] And $0F;
  72.      month   := Port[$D0 + 11] And $0F * 10 + Port[$D0 + 10] And $0F;
  73.      year    := Port[$D0 + 13] And $0F * 10 + Port[$D0 + 12] And $0F;
  74.      year:= year + 1900;
  75.      If (minutes In [0..59]) And (hours In [0..23]) And
  76.         (day In [1..31]) And (month In [1..12]) Then
  77.      Else
  78.          Begin
  79.               minutes:= 0;
  80.               hours:= 0;
  81.               day:= 1;
  82.               month:= 1;
  83.               year:= 1980;
  84.          End;
  85. End;
  86.  
  87. Procedure Display_Date_Time;
  88. Begin
  89.      Case hours Of
  90.            0..11 : Write('Good morning.');
  91.           12..17 : Write('Good afternoon.');
  92.           18..23 : Write('Good evening.');
  93.      End;
  94.      Write(' It''s ');
  95.      weekday:= Get_Day_Of_Week(year,month,day);
  96.      Case weekday Of
  97.           1 : Write('Sunday');
  98.           2 : Write('Monday');
  99.           3 : Write('Tuesday');
  100.           4 : Write('Wednesday');
  101.           5 : Write('Thursday');
  102.           6 : Write('Friday');
  103.           7 : Write('Saturday');
  104.      End;
  105.      Write(' the ',day);
  106.      Case day Of
  107.           1,21,31      : Write('st');
  108.           2,22         : Write('nd');
  109.           3,23         : Write('rd');
  110.           4..20,24..30 : Write('th');
  111.      End;
  112.      Write(' of ');
  113.      Case month Of
  114.            1 : Write('January');
  115.            2 : Write('February');
  116.            3 : Write('March');
  117.            4 : Write('April');
  118.            5 : Write('May');
  119.            6 : Write('June');
  120.            7 : Write('July');
  121.            8 : Write('August');
  122.            9 : Write('September');
  123.           10 : Write('October');
  124.           11 : Write('November');
  125.           12 : Write('December');
  126.      End;
  127.      Write(' ',year,'. Current time is ');
  128.      If hours < 10 Then
  129.         Write('0',hours)
  130.      Else
  131.          Write(hours);
  132.      Write(':');
  133.      If minutes < 10 Then
  134.         Writeln('0',minutes)
  135.      Else
  136.          Writeln(minutes);
  137. End;
  138.  
  139. Procedure Command_Line;
  140. Var
  141.    parameter : str04;
  142.  
  143. Begin
  144.      parameter:= Paramstr(1);
  145.      If parameter <> '' Then
  146.         Begin
  147.              Get_Date_Time;
  148.              Val(Copy(parameter,1,2),month,dummy);
  149.              Val(Copy(parameter,3,2),day,dummy);
  150.              If month In [1..12] Then
  151.                 Begin
  152.                      If day In [1..31] Then
  153.                      Else
  154.                          Get_Date_Time;
  155.                 End
  156.              Else
  157.                  Get_Date_Time;
  158.         End
  159.      Else
  160.          Get_Date_Time;
  161.      Display_Date_Time;
  162. End;
  163.  
  164. Procedure Display(Line : Str80);
  165. Var
  166.    pos06,pos02 : str04;
  167.    wday        : string[1];
  168.    pos10       : Char;
  169.  
  170. Begin
  171.      Str(weekday,wday);
  172.      pos02:= Copy(line,2,4);
  173.      pos06:= Copy(line,6,4);
  174.      pos10:= Copy(line,10,1);
  175.      Delete(line,1,10);
  176.      If pos10 In ['1'..'7'] Then
  177.         Begin
  178.              If wday = pos10 Then
  179.                 If pos06 = '    ' Then
  180.                    Writeln(' ',line)
  181.                 Else
  182.                     Writeln(' In ',pos06,' ',line);
  183.         End
  184.      Else
  185.          If pos10 = 'C' Then
  186.             Writeln('         ',line)
  187.          Else
  188.              If pos06 = '    ' Then
  189.                 Writeln(' ',line)
  190.              Else
  191.                 Writeln(' In ',pos06,' ',line);
  192. End;
  193.  
  194. Procedure List_Arrays;
  195. Var
  196.    i : Integer;
  197.  
  198. Begin
  199.      Writeln;
  200.      If bday Then
  201.         Begin
  202.              Writeln('Happy Birthday to...');
  203.              For i:= 1 To b Do
  204.                  Display(birthday[i]);
  205.         End
  206.      Else
  207.          Begin
  208.               Writeln;
  209.               Writeln('Happy Birthday to...');
  210.               Writeln(' Absolutely no one in particular!');
  211.          End;
  212.      If spec Then
  213.         Begin
  214.              Writeln;
  215.              Writeln('On this day...');
  216.              For i:= 1 To s Do
  217.                  Display(special[i]);
  218.         End
  219.      Else
  220.          Begin
  221.               Writeln;
  222.               Writeln('On this day...');
  223.               Writeln(' Absolutely nothing happend. Amazing!');
  224.          End;
  225.      If rem Then
  226.         Begin
  227.              Writeln;
  228.              Writeln('Remember...');
  229.              For i:= 1 To r Do
  230.                  Begin
  231.                       Delete(reminder[i],1,10);
  232.                       Writeln(' ',reminder[i]);
  233.                  End;
  234.         End;
  235.      Writeln;
  236. End;
  237.  
  238. Procedure Store_Reminder;
  239. Var
  240.    wday : Integer;
  241.  
  242. Begin
  243.      Val(Copy(line,10,1),wday,dummy);
  244.      If dummy <> 0 Then
  245.         wday:= 0;
  246.      If (wday = 0) And (r <> max) Then
  247.         Begin
  248.              r:= r + 1;
  249.              reminder[r]:= line;
  250.              rem:= True;
  251.         End
  252.      Else
  253.          If (weekday = wday) And (r <> max) Then
  254.             Begin
  255.              r:= r + 1;
  256.              reminder[r]:= line;
  257.              rem:= True;
  258.         End;
  259. End;
  260.  
  261. Procedure Load_Arrays;
  262. Var
  263.    pos6to10                             : str04;
  264.    bsr                                  : Char;
  265.    date1,date2,date3                    : Real;
  266.    date4,date5,date6,date7,os0,os1,wday : Integer;
  267.  
  268. Begin
  269.      os0:= 0;
  270.      os1:= 0;
  271.      Val(Copy(line,2,2),date4,dummy);
  272.      Val(Copy(line,4,2),date5,dummy);
  273.      Val(Copy(line,10,1),wday,dummy);
  274.      If dummy <> 0 Then
  275.         wday:= 0;
  276.      pos6to10:= Copy(line,6,4);
  277.      bsr:= Copy(line,1,1);
  278.      Begin
  279.           Case bsr Of
  280.                'B' : Begin
  281.                           If (month = date4) And (day = date5) Then
  282.                              If (wday = 0) And (b <> max) Then
  283.                                 Begin
  284.                                      b:= b + 1;
  285.                                      birthday[b]:= line;
  286.                                      bday:= True;
  287.                                 End
  288.                              Else
  289.                                  Begin
  290.                                       If (weekday = wday) And (b <> max) Then
  291.                                          Begin
  292.                                               b:= b + 1;
  293.                                               birthday[b]:= line;
  294.                                               bday:= True;
  295.                                          End;
  296.                                  End;
  297.                      End;
  298.                'S' : Begin
  299.                           If (month = date4) And (day = date5) Then
  300.                              If (wday = 0) And (s <> max) Then
  301.                                 Begin
  302.                                      s:= s + 1;
  303.                                      special[s]:= line;
  304.                                      spec:= True;
  305.                                 End
  306.                              Else
  307.                                  Begin
  308.                                       If (weekday = wday) And (s <> max) Then
  309.                                          Begin
  310.                                               s:= s + 1;
  311.                                               special[s]:= line;
  312.                                               spec:= True;
  313.                                          End;
  314.                                  End;
  315.                      End;
  316.                'R' : Begin
  317.                           Val(Copy(line,6,2),date6,dummy);
  318.                           Val(Copy(line,8,2),date7,dummy);
  319.                           If pos6to10 = '    ' Then
  320.                              Begin
  321.                                   If date4 = 0 Then
  322.                                      If day = date5 Then
  323.                                         Store_Reminder;
  324.                                   If date5 = 0 Then
  325.                                      If month = date4 Then
  326.                                         Store_Reminder;
  327.                                   If month = date4 Then
  328.                                      If day = date5 Then
  329.                                         Store_Reminder;
  330.                              End
  331.                           Else
  332.                               Begin
  333.                                    If (date4 = 0) And (date6 = 0) Then
  334.                                       If day In [date5..date7] Then
  335.                                          Store_Reminder;
  336.                                    If date4 > date6 Then
  337.                                       If (month >= (date6 + 1)) And
  338.                                          (month <= (date4 - 1)) Then
  339.                                       Else
  340.                                           Begin
  341.                                                If (date5 = 0) And (date7 = 0) Then
  342.                                                   Store_Reminder;
  343.                                           End
  344.                                    Else
  345.                                        Begin
  346.                                             If (month In [date4..date6]) And
  347.                                                (date5 = 0) And (date7 = 0) Then
  348.                                                Store_Reminder;
  349.                                        End;
  350.                                    If (date4 <> 0) And (date6 <> 0) And
  351.                                       (date5 <> 0) And (date7 <> 0) Then
  352.                                       Begin
  353.                                            If date4 > date6 Then
  354.                                               Begin
  355.                                                    If month >= date4 Then
  356.                                                       Begin
  357.                                                            os0:= 1;
  358.                                                            os1:= 0;
  359.                                                       End
  360.                                                    Else
  361.                                                        Begin
  362.                                                             os0:= 0;
  363.                                                             os1:= 1;
  364.                                                        End;
  365.                                               End;
  366.                                            date1:= Get_Comp_Date(year - os1,date4,date5);
  367.                                            date2:= Get_Comp_Date(year + os0,date6,date7);
  368.                                            date3:= Get_Comp_Date(year,month,day);
  369.                                            If (date3 >= date1) And (date3 <= date2) Then
  370.                                               Store_Reminder;
  371.                                       End;
  372.                               End;
  373.                      End;
  374.           End;
  375.      End;
  376. End;
  377.  
  378. Procedure Io_Check;
  379. Begin
  380.      ioval:= ioresult;
  381.      ioerr:= (ioval <> 0);
  382.      If ioerr Then
  383.         Begin
  384.              If ioval = 1 Then
  385.                 Writeln('TODAY data files not found in user area ',area)
  386.              Else
  387.                  Writeln('Error has occured while reading TODAY data file.');
  388.              error:= True;
  389.         End;
  390. End;
  391.  
  392. Procedure Open_File;
  393. Var
  394.    ext  : String[3];
  395.    user : Byte;
  396.  
  397. Begin
  398.      line:= 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
  399.      user:= Bdos($20,$00ff);
  400.      Bdos($20,area);
  401.      ext:= Copy(line,(month - 1) * 3 + 1,3);
  402.      Assign(input,'TODAY.' + ext);
  403.      Io_Check;
  404.      Reset(input);
  405.      Io_Check;
  406.      While (Not Eof(input)) And (Not ioerr) Do
  407.            Begin
  408.                 Readln(input,line);
  409.                 Io_Check;
  410.                 Load_Arrays;
  411.            End;
  412.      Close(input);
  413.      Assign(input,'TODAY.OWN');
  414.      Io_Check;
  415.      Reset(input);
  416.      Io_Check;
  417.      While (Not Eof(input)) And (Not ioerr)  Do
  418.            Begin
  419.                 Readln(input,line);
  420.                 Io_Check;
  421.                 Load_Arrays;
  422.            End;
  423.      Close(input);
  424.      Bdos($20,user);
  425.      If Not error Then
  426.         List_Arrays;
  427. End;
  428.  
  429. Begin
  430.      Initialize;
  431.      Command_line;
  432.      Open_File;
  433. End.
  434.