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 / CPM / LANGUAGS / PASCAL / CAL.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  14KB  |  449 lines
  1. program calendar;
  2. {*************************************************************************
  3. Program:  CALENDAR
  4. Author:  Richard Conn
  5. Date:  4 Feb 82
  6.  
  7. Description:
  8.     CALENDAR is used to display a Calendar to the user.  The
  9. Calendar may be that of a particular Month in a particular Year
  10. or that of all Months in a Particular Year.
  11.     The calendar displayed is the Gregorian Calendar.
  12.     The Calendar display may be sent to the user's Console
  13. (by default) or optionally to the user's LST: device or a disk file.
  14.  
  15. Usage:
  16.         calendar [month] year [/o]
  17.     where
  18.         month may be one of january, february, ..., december
  19.             (optional and only first three letters are req'd)
  20.         year may be any year after byear
  21.         o may be one of the following --
  22.             p - send output to Printer
  23.             d - send output to Disk
  24.             (o is optional and defaults to Console if omitted)
  25.  
  26. Examples:
  27.         CALENDAR JANUARY 1982 -- Calendar of Month of January of 1982
  28.         CALENDAR JAN 1982 -- Same as Above
  29.         CALENDAR 1982 -- Calendar of all months of 1982
  30.         CALENDAR 1982 /P -- Same as Above but Output to Printer
  31.         CALENDAR 1982 /D -- Same as Above but Output to Disk
  32.         CALENDAR 1982 /P/D -- Same as Above but Output to Disk
  33.             (Disk has priority)
  34. *****************************************************************************}
  35.  
  36. {***************************************************************************
  37.  
  38.     'version' is the Version Number of CALENDAR.
  39.     'byear1' is the Base Year of CALENDAR.  This year MUST be a Leap
  40. Year.  Since CALENDAR uses integer arithmetic to do its calculations,
  41. the range of years that may be addressed by CALENDAR is from byear to
  42. byear + 30,000 (approx).
  43.     'bday1' is the Base Day of CALENDAR.  This is the number (1 to 7)
  44. of the First Sunday in January of the Base Year.
  45.  
  46. ****************************************************************************}
  47. const
  48.     version = 13;
  49.     byear1 = 1804;  { Base Year for this program }
  50.     bday1 = 1;      { Base Day for the Base Year }
  51.  
  52. {***********************************************
  53.     Global Types and Variables
  54. ************************************************}
  55. type
  56.     strptr = ^string;
  57. var
  58.     ofile : text;
  59.     filename : string[14];
  60.     month1, year1, dow : integer;
  61.     mposfnd, mpos, ypos : integer;
  62.     mdays : array [1..12] of integer;
  63.     month : array [1..12] of string[10];
  64.     year : string;
  65.     command : strptr;
  66.     cmdline, yline : string;
  67.     lyear : boolean;
  68.     icount : integer;
  69.     match, conout, diskout : boolean;
  70.     byear, bday, bdow : integer;
  71.  
  72. {****************************************************
  73.     External PASCAL/MT+ System Functions
  74. *****************************************************}
  75. external function @cmd : strptr;
  76.  
  77. {**************************************************************************
  78.     Function:  day_count
  79.         Computes the number of days since the beginning of the year.
  80.         (Jan 1 = Day 0)
  81.     Input Parameters:
  82.         day: integer in range 1-31
  83.         month: integer in range 1-12
  84.         year: integer
  85.         mdays[i, 1<=i<=12 ]: number of days in month i, i=1=January
  86.             (Global Parameter)
  87.     Output Parameters:
  88.         day_count: Number of days since 1st day of year (0=1st day)
  89. ***************************************************************************}
  90. function day_count (day, month, year : integer) : integer;
  91. var
  92.     ndays, i : integer;
  93. begin
  94.     ndays := day - 1;  { Adjust for first day being day 0}
  95.     if month <> 1 then for i:=1 to month-1 do ndays := ndays + mdays[i];
  96.                 { Compute Number of Days since Year Start }
  97.     day_count := ndays;
  98.     lyear := false;  { Assume NOT Leap Year }
  99.     if (year mod 4) <> 0 then exit;  { If not Leap Year, Done }
  100.     if ((year mod 100) = 0) and ((year mod 400) <> 0) then exit;
  101.             { 2000, 2400, etc are Leap, other centurys not }
  102.     lyear := true;  { Leap Year }
  103.     if month < 3 then exit;  { If in Feb or Jan, Done }
  104.     day_count := ndays + 1;  { Adjust for Leap Year }
  105. end;
  106.  
  107. {*********************************************************************
  108.     Function:  day_of_week
  109.         Computes day of the week that a given date falls on.
  110.     Input Parameters:
  111.         day : integer in range 1-31
  112.         month : integer in range 1-12
  113.         year : integer
  114.     Output Parameters:
  115.         day_of_week : integer in range 1-7 (bday = Sunday)
  116. **********************************************************************}
  117. function day_of_week (day, month, year : integer) : integer;
  118. var
  119.     ndays, tyear : integer;
  120. begin
  121.     ndays := day_count (day, month, year);  { Compute Number of Days }
  122.     ndays := ndays + 365*(year - byear) + ((year - byear + 3) div 4);
  123.     tyear := (year div 100) * 100;  { Century below given year }
  124.     if ((tyear mod 400) <> 0) and (byear < tyear) and (tyear < year) then
  125.         ndays := ndays - 1;  { Adjust for NO Leap Year century }
  126.     day_of_week := (ndays mod 7) + 1;
  127. end;
  128.  
  129. {************************************************************************
  130.     Function:  CLINE
  131.         Print syntax of Command Line for Calendar Program.
  132.     Input/Output Parameters:  None
  133. *************************************************************************}
  134. procedure cline;  { Print Syntax of Command Line }
  135. begin
  136.     writeln('    Calendar Command Line should be:');
  137.     writeln('        calendar month year /o');
  138.     writeln('    ', byear1, ' <= YEAR <= 30,000 (approx)');
  139.     writeln('    Only first three characters of MONTH are meaningful');
  140.     writeln('    /O may be one of --');
  141.     writeln('        /P to send output to Printer');
  142.     writeln('        /D to send output to Disk File');
  143.     writeln;
  144.     writeln('    Examples:');
  145.     writeln('        CALENDAR JAN 1982');
  146.     writeln('        CALENDAR DECEMBER 2000');
  147.     writeln('        CALENDAR 1982 /D');
  148.     writeln('        CALENDAR 1984 /P');
  149. end;
  150.  
  151. {*************************************************************************
  152.     Function:  NUMBER
  153.         Converts the input string of digits to an integer.
  154.     Input Parameter:
  155.         value:  string of digits
  156.     Output Parameter:
  157.         number:  value of digit string; evaluation stops at
  158.             first non-digit character
  159. **************************************************************************}
  160. function number (valstr : string) : integer;
  161. var
  162.     idx, numb : integer;
  163.     cont : boolean;
  164.     digit : char;
  165.     idigit : integer;
  166.     val1 : string;
  167. begin
  168.     val1 := valstr; { Temp Variable }
  169.     numb := 0;  { Initialize result }
  170.  
  171.     { Test for Empty Input String; if empty, return zero value }
  172.     if length(val1) = 0 then begin
  173.         number := numb;  { Pass out value }
  174.         exit;
  175.     end;
  176.  
  177.     { Extract each digit from string and convert into result }
  178.     cont := true;
  179.     idx := 1;
  180.     while cont do begin
  181.         digit := val1[idx];  { Get next digit }
  182.         if (digit < '0') or (digit > '9') then idigit := 10 else
  183.             idigit := ord(digit) - ord('0');  { Convert to bin }
  184.         if idigit = 10 then cont := false;
  185.         if cont then numb := numb * 10 + idigit;  { Update Value }
  186.         idx := idx + 1;  { Increment Char Pointer }
  187.         if length (val1) < idx then cont := false;
  188.     end;
  189.     number := numb;  { Final Value }
  190. end;
  191.  
  192. {************************************************************************
  193.     Function:  CAL
  194.         Prints one line of the calendar.
  195.     Input Parameters:
  196.         dow: Day of the Week to Start On
  197.         day: Number of Day in Month
  198.         month:  Month of Year
  199.         lyear:  Leap Year (T/F)
  200.     Output Parameter:
  201.         cal:  Number of next Day in Month (0=done)
  202. ************************************************************************}
  203. function cal (dow, day, month : integer) : integer;
  204. var
  205.     i : integer;
  206.     monlen, nday, ndays : integer;
  207. begin
  208.     { If day is zero, print blank entry }
  209.     if day=0 then begin
  210.         for i:=1 to 7 do write(ofile, '   ');
  211.         write(ofile, '  ');
  212.         cal := 0;
  213.         exit;
  214.     end;
  215.  
  216.     { Determine number of days in month }
  217.     monlen := mdays[month];
  218.     { If month is Feb and it is a leap year, then add 1 }
  219.     if (month=2) and lyear then monlen := monlen + 1;
  220.  
  221.     { If number < Sunday, set dow to 7+ }
  222.     if dow < bday then dow := dow + 7;
  223.  
  224.     { If not Sunday, space over to proper starting column of month cal }
  225.     if dow <> bday then for i:=1 to dow-bday do write(ofile, '   ');
  226.  
  227.     { Compute number of days in current line }
  228.     ndays := 7 - (dow-bday);
  229.     { If we exceed number of days in month, adjust to limit }
  230.     if day+ndays > monlen then ndays := monlen-day+1;
  231.  
  232.     { We are in proper position, to print day entries in Calendar line }
  233.     if ndays<>0 then for i:=1 to ndays do begin
  234.         nday := day + i - 1;
  235.         write(ofile, nday:2, ' ');
  236.     end;
  237.     { Fill out rest of line if end of calendar }
  238.     if (day<>1) and (ndays<>7) then
  239.         for i:=ndays+1 to 7 do write(ofile, '   ');
  240.  
  241.     { Write ending spaces }
  242.     write(ofile, '  ');
  243.  
  244.     { Set return value to be day of month to start on or zero if done }
  245.     if monlen < (ndays+day) then cal := 0 else cal := day + ndays;
  246.  
  247. end; { CAL }
  248.  
  249. {**********************************************************************
  250.     Function:  DOMONTH
  251.         Prints Calendar for Month 'month1' of Year 'year1'.
  252.     Input Parameters:
  253.         month1: month number (1 to 12)
  254.         year1: year number (byear to 30,000)
  255.     Output Parameters:
  256.         - None -
  257. ***********************************************************************}
  258. procedure domonth;
  259. var
  260.     day1 : integer;
  261. begin
  262.     { Determine what day of the week the first day of month falls on }
  263.     day1 := day_of_week (1,month1,year1);  { Day of 1st Day of Month }
  264.  
  265.     { Write header for Calendar Month }
  266.     writeln(ofile); writeln(ofile, 'Calendar for ',month[month1],' ',
  267.         year1);
  268.     writeln(ofile, 'Su Mo Tu We Th Fr Sa');
  269.  
  270.     { Print first line of Calendar }
  271.     day1 := cal (day1, 1, month1); writeln(ofile);
  272.  
  273.     { Print rest of Calendar }
  274.     while day1 <> 0 do begin
  275.         day1 := cal (bday, day1, month1);
  276.         writeln(ofile);
  277.     end;
  278.  
  279. end; { DOMONTH }
  280.  
  281. {**************************************************************
  282.     Function:  DOYEAR
  283.         Prints Calendar for Year 'year1'.
  284.     Input Parameters:
  285.         year1: year number
  286.     Output Parameters:
  287.         - None -
  288. **************************************************************}
  289. procedure doyear;
  290. var
  291.     dayx : array [1..3] of integer;
  292.     idx, mbase, group3, group4 : integer;
  293.  
  294. begin
  295.     { Write Header for Calendar }
  296.     writeln(ofile, '                       Calendar of Year ', year1);
  297.     writeln(ofile);
  298.  
  299.     { Loop over Calendar as 4 rows of three months each }
  300.     for group3 := 1 to 4 do begin
  301.         { Compute Base Month Number }
  302.         mbase := (group3-1) * 3 + 1;
  303.  
  304.         { Page if output to CON: and beginning 3rd group of months }
  305.         if (group3 = 3) and conout then begin
  306.             write('Strike RETURN Key to Continue - ');
  307.             readln; writeln;
  308.         end;
  309.  
  310.         { Print Heading of Each Month }
  311.         writeln(ofile);
  312.         for group4 := mbase to mbase+2 do
  313.             write(ofile, 'Calendar for ',month[group4], ' ');
  314.         if ((group3 = 1) or (group3 = 3)) and conout then
  315.             writeln(ofile, year1) else writeln(ofile);
  316.         for group4 := mbase to mbase+2 do begin
  317.                 write(ofile, 'Su Mo Tu We Th Fr Sa   ');
  318.             idx := group4 mod 3; if idx=0 then idx := 3;
  319.             dayx[idx] := day_of_week(1,group4,year1);
  320.         end;
  321.         writeln(ofile);
  322.  
  323.         { Print first line of Calendar }
  324.         dayx[1] := cal (dayx[1], 1, mbase);
  325.         dayx[2] := cal (dayx[2], 1, mbase+1);
  326.         dayx[3] := cal (dayx[3], 1, mbase+2);
  327.         writeln(ofile);
  328.  
  329.         { Print rest of Calendar }
  330.         repeat
  331.             dayx[1] := cal (bday, dayx[1], mbase);
  332.             dayx[2] := cal (bday, dayx[2], mbase+1);
  333.             dayx[3] := cal (bday, dayx[3], mbase+2);
  334.             writeln(ofile);
  335.         until dayx[1]+dayx[2]+dayx[3] = 0;
  336.         writeln(ofile);
  337.     end;
  338.  
  339. end; { DOYEAR }
  340.  
  341. {*************************************************************************
  342.     Function:  Initialize
  343.         Initialize the command line pointer, the number of days
  344.         in each month, and the names of the months.
  345.     Input/Output Parameters:  None
  346. **************************************************************************}
  347. procedure initialize;
  348. begin
  349.     { Point to Command Line }
  350.     command := @cmd;
  351.     cmdline := command^;
  352.  
  353.     { Number of days in each month }
  354.     mdays[1]  := 31; mdays[2]  := 28; mdays[3]  := 31;
  355.     mdays[4]  := 30; mdays[5]  := 31; mdays[6]  := 30;
  356.     mdays[7]  := 31; mdays[8]  := 31; mdays[9]  := 30;
  357.     mdays[10] := 31; mdays[11] := 30; mdays[12] := 31;
  358.  
  359.     { Names of each month }
  360.     month[1]  := 'JANUARY  '; month[2]  := 'FEBRUARY ';
  361.     month[3]  := 'MARCH    '; month[4]  := 'APRIL    ';
  362.     month[5]  := 'MAY      '; month[6]  := 'JUNE     ';
  363.     month[7]  := 'JULY     '; month[8]  := 'AUGUST   ';
  364.     month[9]  := 'SEPTEMBER'; month[10] := 'OCTOBER  ';
  365.     month[11] := 'NOVEMBER '; month[12] := 'DECEMBER ';
  366.  
  367. end;  { Initialize }
  368.  
  369. {Mainline}
  370. begin
  371.     { Initialize Month Data and Command Line Pointer }
  372.     initialize;
  373.  
  374.     { Print Banner }
  375.     writeln('Calendar,  Version ',(version div 10),'.',(version mod 10));
  376.  
  377.     { Determine Output Direction }
  378.     diskout := false;  { Assume no disk output }
  379.     conout := false;   { Assume no console output }
  380.     if pos ('/D',cmdline) <> 0 then begin
  381.         diskout := true;
  382.         write('Name of Disk Output File? '); readln(filename); end
  383.     else if pos ('/P',cmdline) <> 0 then filename := 'LST:'
  384.          else begin
  385.             filename := 'CON:'; conout := true; end;
  386.  
  387.     { Open Output File or Device }
  388.     assign (ofile, filename);
  389.     rewrite(ofile);
  390.     if ioresult = 255 then begin
  391.         writeln ('Fatal Error: Cannot Open ', filename, ' for Output');
  392.         exit;
  393.     end;
  394.     writeln('Calendar Output File/Device is ',filename);
  395.  
  396.     { Determine which month was specified in command line }
  397.     month1 := 0;  { Assume none for all months }
  398.     match := false;  { No match found }
  399.     for icount:=1 to 12 do begin
  400.         mpos := pos (copy (month[icount],1,3), cmdline);
  401.         if mpos <> 0 then begin
  402.             if match then begin
  403.                 writeln('Error -- More than one month given');
  404.                 exit;
  405.             end;
  406.             match := true;  { We have a match }
  407.             month1 := icount;
  408.             mposfnd := mpos;
  409.         end;
  410.     end;
  411.  
  412.     { Extract Year from command line }
  413.     yline := copy (cmdline, mposfnd, length(cmdline)-mposfnd+1);
  414.     ypos := pos (' ', yline);
  415.     year := copy (yline, ypos, length(yline)-ypos+1);
  416.     while (length(year) <> 0) and (year[1] = ' ') do
  417.         year := copy (year, 2, length(year)-1);
  418.     year1 := number(year);  { Convert Year String into Number }
  419.  
  420.     { If no year specified, give syntax of command }
  421.     if year1 = 0 then begin
  422.         cline;  { Print syntax of command line }
  423.         exit;
  424.     end;
  425.     { If year specified is out of range, say so }
  426.     if year1 < byear1 then begin
  427.         write('Invalid Year Specification');
  428.         writeln(' -- Year Specified was ',year1);
  429.         writeln('Year MUST be such that ', byear1, ' <= Year');
  430.         cline;  { Print syntax of command line }
  431.         exit;
  432.     end;
  433.  
  434.     { Determine Base Year from byear1 and Base Day from bday1 }
  435.     byear := byear1;   bday := bday1;
  436.     while year1 > byear+44 do begin
  437.         bdow := day_of_week (1,1,byear+44);  { First day of leap year }
  438.         byear := byear + 44;  { Set byear to next 11th leap year }
  439.         if bdow <= bday then bday := bday - bdow + 1
  440.                    else bday := 7 - (bdow - bday) + 1;
  441.                     { bday = 1st Sunday of Leap Year }
  442.     end;
  443.  
  444.     { Do Calendar }
  445.     if ?match then doyear else domonth;
  446.     if diskout then close (ofile, icount);
  447.  
  448. end. {Mainline}
  449.