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