home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CALYR2.ZIP / CALYR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-09-17  |  6.5 KB  |  257 lines
  1. Program calyr;
  2. {   ***********  PUBLIC DOMAIN ************
  3.     Accepts year as input...
  4.     Year should be between 1901 and 2099 inclusive;
  5.     Accepts 2 digit year, if 2 digit assumes 19xx;
  6.     Displays 1st 6 months, then second 6 months, allows return to 1st 6;
  7.     If valid year not entered on command line, ask for year.
  8.  
  9.     If letter 'P' in command line, display calendar on printer,
  10.     If letter 'S' in command line, display calendar on screen,
  11.     If neither 'P' nor 'S' in command line, ask where to display.
  12.  
  13.   MODIFICATION HISTORY
  14.  DATE    AUTHOR              CHANGES
  15. 04/28/85 William Chestnut  Original Version
  16.          5800 Sunset Blvd.
  17.          LA, CA 90078
  18.  
  19. 09/15/85 Roy J. Collins    1. Allow display of calendar on screen or printer
  20.          P.O.B. 1192       2. Re-structured parts of code.
  21.          Leesburg,VA 22075
  22. }
  23. Const
  24.   day_letters = '  S  M  T  W  T  F  S';
  25. Type
  26.    parmtype = String[127];
  27.    Str = String[80];
  28. Var
  29.    year,dow : Integer;   { Year is target year for calendar, Dow is the day }
  30.                          { number of 1/1/xxxx, Sunday=1, Monday=2, etc.     }
  31.    cal  : Array[1..12,1..42] Of Integer;
  32.    dpm  : Array[1..12] Of Integer;  { number of days in each month }
  33.    m    : Integer;
  34.    ch   : Char;
  35.    yearstr : parmtype;
  36.    out_flag : Char;
  37.  
  38. Procedure getparm(Var s:parmtype);  { Get command line parameter }
  39. Var
  40.    parms : parmtype Absolute CSeg:$80;
  41.    p : Integer;
  42. Begin
  43.   s:='';
  44.   out_flag := ' ';
  45.   If Pos('S',parms) > 0 Then Begin
  46.     out_flag := 'S';
  47.     Delete(parms,Pos('S',parms),1);
  48.     End
  49.   Else
  50.   If Pos('s',parms) > 0 Then Begin
  51.     out_flag := 'S';
  52.     Delete(parms,Pos('s',parms),1);
  53.     End
  54.   Else
  55.   If Pos('P',parms) > 0 Then Begin
  56.     out_flag := 'P';
  57.     Delete(parms,Pos('P',parms),1);
  58.     End
  59.   Else
  60.   If Pos('p',parms) > 0 Then Begin
  61.     out_flag := 'P';
  62.     Delete(parms,Pos('p',parms),1);
  63.     End;
  64.   While (parms <> '') And (parms[1]=' ') Do
  65.     Delete(parms,1,1);
  66.   While ((parms <> '') And (parms[Length(parms)]=' ')) Do
  67.     Delete(parms,Length(parms),1);
  68.   s := parms;
  69. End;
  70.  
  71. Procedure getyear;    { Gets Year from keyboard, Calculates Dow }
  72. Var
  73.    dayofweek : Real;
  74.    errorcode : Integer;
  75. Begin         { GetYear  }
  76.   year :=0;
  77.   While year = 0 Do Begin
  78.     getparm(yearstr);
  79.     If Length(yearstr) = 0 Then Begin
  80.       Write('YEAR  ');
  81.       ReadLn(yearstr);
  82.       End;
  83.     Val(yearstr,year,errorcode);
  84.     If errorcode <> 0 Then
  85.       year := 0;
  86.     End;
  87.   If ( year > 0 ) And ( year <= 99 ) Then
  88.     year := year + 1900;
  89.   While ( year < 1901 ) Or ( year > 2099 ) Do Begin
  90.     Writeln('Year must be between 1901 and 2099');
  91.     getyear;
  92.     End;
  93.   dayofweek:=Int((year-1901)*365.25);
  94.   While dayofweek > 28000 Do
  95.     dayofweek := dayofweek - 28000;
  96.   dow := Round(dayofweek) Mod 7 + 3;
  97.   If dow > 7 Then
  98.     dow := dow - 7;
  99. End;  { GetYear }
  100.  
  101. Procedure fillinarray;
  102. Var
  103.    m,d,date  : Integer ;
  104. Begin
  105.   For m := 1 To 12 Do       { sets days per month to DPM[ ]  }
  106.     Case m Of
  107.       1,3,5,7,8,10,12 : dpm[m] := 31;
  108.       4,6,9,11        : dpm[m] := 30;
  109.       2               : dpm[m] := 28;
  110.       End; (* case *)
  111.   If year Mod 4 = 0 Then    { end set days per month to DPM[ ]  }
  112.     dpm[2] := 29;
  113.   For m := 1 To 12 Do       { set Cal [ , ] to 0 }
  114.       For d := 1 To 42 Do cal[m,d] := 0;
  115.   For m := 1 To 12 Do Begin
  116.     For date := 1 To dpm[m] Do
  117.       cal[m,dow+date-1] := date;
  118.     dow := dow + dpm[m];
  119.     While dow > 7 Do
  120.       dow := dow - 7;
  121.     End;
  122. End;         { FillInArray }
  123.  
  124. Procedure displayamonth;
  125. Var
  126.    i,j,k : Integer;
  127. Begin
  128.   Writeln(day_letters);
  129.   For k := 0 To 5 Do Begin
  130.     For j := 1 To 7 Do
  131.       If cal[m,k*7+j] <> 0 Then
  132.         Write(cal[m,k*7+j]:3) Else Write('   ');
  133.     Writeln;
  134.     End;
  135.   Writeln;
  136.   Writeln;
  137. End;
  138.  
  139. Function month_name(month:Integer):Str;
  140. Begin
  141.   Case month Of
  142.      1 : month_name := 'January';
  143.      2 : month_name := 'February';
  144.      3 : month_name := 'March';
  145.      4 : month_name := 'April';
  146.      5 : month_name := 'May';
  147.      6 : month_name := 'June';
  148.      7 : month_name := 'July';
  149.      8 : month_name := 'August';
  150.      9 : month_name := 'September';
  151.     10 : month_name := 'October';
  152.     11 : month_name := 'November';
  153.     12 : month_name := 'December';
  154.     End;
  155. End; (* func month_name *)
  156.  
  157. Procedure print_a_week(month,week:Integer);
  158. Var
  159.    s : Str;
  160.    i,j,k : Integer;
  161. Begin
  162.   If week < 0 Then Begin
  163.     For i := month To month + 2 Do Begin
  164.       s := month_name(i);
  165.       Write(Lst,s,' ':26-Length(s));
  166.       End;
  167.     Writeln(Lst);
  168.     For i := 1 To 3 Do
  169.       Write(Lst,day_letters,'    ');
  170.     End
  171.   Else Begin
  172.       For j := 1 To 7 Do
  173.         If cal[month,week*7+j] <> 0 Then
  174.           Write(Lst,cal[month,week*7+j]:3)
  175.         Else
  176.          Write(Lst,'   ');
  177.       Write(Lst,'    ');
  178.       End;
  179. End; (* proc print_a_week *)
  180.  
  181. Procedure print_calendar;
  182. Var
  183.   w : Integer;
  184. Begin
  185.   Writeln(Lst);
  186.   Writeln(Lst,'                                 ',year);
  187.   Writeln(Lst);
  188.   m := 1;
  189.   While m < 12 Do Begin
  190.     print_a_week(m,-1);
  191.     Writeln(Lst);
  192.     For w := 0 To 5 Do Begin
  193.       print_a_week(m,w);
  194.       print_a_week(m+1,w);
  195.       print_a_week(m+2,w);
  196.       Writeln(Lst);
  197.       End;
  198.     Writeln(Lst);
  199.     Writeln(Lst);
  200.     m := m + 3;
  201.     End;
  202. End; (* proc print_calendar *)
  203.  
  204. Procedure disphalf(start:Integer);
  205. Var
  206.   y : Integer;
  207. Begin
  208.   y := 3;
  209.   For m := start To start+2 Do Begin
  210.     Window((m-start)*25+1,y,(m-(start-1))*25-1,y+10);
  211.     Writeln;
  212.     Writeln(month_name(m));
  213.     displayamonth;
  214.     End;
  215.   start := start+3;
  216.   y := 13;
  217.   For m := start To start+2 Do Begin
  218.     Window((m-start)*25+1,y,(m-(start-1))*25-1,y+10);
  219.     Writeln;
  220.     Writeln;
  221.     Writeln;
  222.     Writeln(month_name(m));
  223.     displayamonth;
  224.     End;
  225.   Window(1,1,80,25);
  226. End;
  227.  
  228. Begin   {main body}
  229.    getyear;
  230.    fillinarray;
  231.    If ((out_flag <> 'S') And (out_flag <> 'P')) Then Begin
  232.      Write('Display calendar on S)creen or P)rinter? (S/P) ');
  233.      Repeat
  234.        Read(Kbd,out_flag);
  235.        out_flag := UpCase(out_flag);
  236.      Until ((out_flag='S') Or (out_flag='P'));
  237.      Writeln(out_flag);
  238.      End;
  239.    If out_flag = 'P' Then
  240.      print_calendar
  241.    Else
  242.      Repeat
  243.        ClrScr;
  244.        Writeln('YEAR  ',year);
  245.        disphalf(1);
  246.        Writeln;
  247.        Write('Type any key for second half  ');
  248.        Read(Kbd,ch);
  249.        ClrScr;
  250.        Writeln('YEAR  ',year);
  251.        disphalf(7);
  252.        Writeln;
  253.        Write('Enter a 1 to see the first half again, any other key to quit  ');
  254.        Read(Kbd,ch);
  255.      Until ch <> '1';
  256. End.
  257.