home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CALENDAR.ZIP / CALENDAR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-10-19  |  3.6 KB  |  166 lines
  1.  
  2. Program CALENDAR;
  3.  
  4. Label Again,Amonth;
  5.  
  6. Const
  7.    Months: Array[1..12] of string[9]=('January','February','March','April',
  8.    'May','June','July','August','September','October','November','December');
  9.    WeekDay: Array[0..6] of string[3]=('Sun','Mon','Tue','Wed','Thu',
  10.    'Fri','Sat');
  11.    JulianDay: Array[1..12] of integer=(0,31,59,90,120,151,181,212,243,273,
  12.    304,334);
  13.    DaysInMonth: Array[1..12] of Integer=(31,28,31,30,31,30,31,31,30,31,30,31);
  14.    XPOS: Array[0..6] of integer = (15,23,31,39,47,55,63);
  15.  
  16. Type
  17.    AnyString = String[70];
  18.  
  19. Var
  20.    SYear:    String[4];
  21.    Display:  String[20];
  22.    Month,
  23.    Day,
  24.    Yr,Y,C,
  25.    Cn,D,L,
  26.    Row,
  27.    Year,
  28.    Jday,
  29.    Leap:     Integer;
  30.    Ch:       Char;
  31.  
  32. Procedure Stars(N: Integer);
  33. Var L: Integer;
  34. Begin
  35.    for L := 1 to N do
  36.    Write('*');
  37. End;
  38.  
  39. Procedure Spaces(N: Integer);
  40. Var L: Integer;
  41. Begin
  42.    for L := 1 to N do
  43.    Write(' ');
  44. End;
  45.  
  46. Procedure WrDay(X: Integer; S: AnyString);
  47. Begin
  48.     GotoXY(XPOS[X],Row); Write(s);
  49. End;
  50.  
  51. Procedure WrM(X: Integer; S: AnyString);
  52. Begin
  53.     GotoXY(X,4); Write(s);
  54. End;
  55.  
  56. Procedure WrD(X,DayCount: Integer);
  57. Begin
  58.     If X = 0 then Row := Row + 2;
  59.     GotoXY(XPOS[X],Row); Write(DayCount:2);
  60. End;
  61.  
  62. Procedure FirstDay(M,Yr: Integer);
  63. Begin
  64.    Y := Yr - 1801; C := Trunc((Yr-1)/100); Cn := Trunc(Yr/100);
  65.    D := (5+Y+Trunc(Y/4)-(C-18)+Trunc((C-16)/4)) Mod 7;
  66.    If Yr Mod 4 = 0 then Leap := 1 else Leap := 0;
  67.    Jday := JulianDay[M] + 1; If M > 2 then Jday := Jday + Leap;
  68.    D := D + (Jday Mod 7); {* Answer in D (1=Sat...7=Fri) *}
  69. End;
  70.  
  71. {************************ Main Program ***************************}
  72. Begin
  73. Again:
  74.    HighVideo;
  75.    GotoXY(1,22);
  76.    ClrEol;
  77.    Write('Calendar Year: ');
  78.    Readln(Year);
  79.    If (Year >= 0) And (Year < 100) then Year := Year + 1900; Str(Year,Syear);
  80.    GotoXY(1,23);
  81.    ClrEol;
  82.    If (Year < 1801) or (Year > 2199)  then
  83.    Begin
  84.       WriteLn('Calendar Years Must Be Between 1801 and 2199!');
  85.       Goto Again;
  86.    End;
  87. Amonth:
  88.    GotoXY(1,23);
  89.    ClrEol;
  90.    Write('Calendar Month: ');
  91.    Readln(Month);
  92.    GotoXY(1,24);
  93.    ClrEol;
  94.    If (Month < 0) or (Month > 12) then
  95.    Begin
  96.       WriteLn('Calendar Months Must Be 1..12!');
  97.       Goto Amonth;
  98.    End;
  99.    Clrscr;
  100.    GotoXY(28,2);
  101.    WriteLn('Perpetual Calendar -- DSOFT');
  102.    Spaces(5);
  103.    Stars(70);
  104.    Writeln;     {* Display Calendar Header *}
  105.    Spaces(5);
  106.    Stars(9);
  107.    Spaces(18);
  108.    Write(copy(Syear,1,1));
  109.    Spaces(4);
  110.    Write(copy(Syear,2,1));
  111.    Spaces(4);
  112.    Write(copy(Syear,3,1));
  113.    Spaces(4);
  114.    Write(copy(Syear,4,1));
  115.    Spaces(18);
  116.    Stars(9);
  117.    Writeln;
  118.    Row := 6;
  119.    Spaces(5);
  120.    Stars(70);
  121.    Writeln;
  122.    Spaces(5);
  123.    Stars(2);
  124.    Spaces(66);
  125.    Stars(2);
  126.    WriteLn;
  127.    For L := 1 to 13 do
  128.      Begin
  129.        GotoXY(6,6+L);
  130.        Stars(2);
  131.        GotoXY(74,6+L);
  132.        Stars(2);
  133.      End;
  134.    GotoXY(6,20);
  135.    Stars(70);
  136.    WriteLn;
  137.    FirstDay(Month,Year); {* D is now equal to the first day of the month *}
  138.    For L := 0 to 6 do
  139.      WrDay(L,WeekDay[L]);
  140.      WriteLn;
  141.      Spaces(5);
  142.      Stars(70);
  143.      WriteLn;
  144.      Row := 9;
  145.      L := Length(Months[Month]);
  146.      WrM(17,Months[Month]);
  147.      WrM(65-L,Months[Month]);
  148.      L := DaysInMonth[Month];
  149.      If Month = 2
  150.        then
  151.          L := L + Leap;
  152.      For C := 1 to L  do
  153.      Begin
  154.        CN := (D + C - 3) Mod 7; If CN < 0 then CN := CN + 7;
  155.        WrD(CN,C);
  156.      End;
  157.      GotoXY(1,22); ClrEol;
  158.      Write('Another Calendar (Y/N)');
  159.      Repeat Read(Kbd,Ch) until UpCase(Ch) in ['Y','N'];
  160.      If UpCase(Ch) = 'Y'
  161.        Then
  162.          goto Again
  163.        else
  164.          GotoXY(1,22);
  165. End.
  166.