home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CLNDR.ZIP / CLNDR2.PAS
Encoding:
Pascal/Delphi Source File  |  1986-08-23  |  3.8 KB  |  193 lines
  1. PROGRAM clndr2;
  2.  
  3. { Full year printout  86-04-27 }
  4.  
  5. CONST
  6.   fudge = 6;
  7.  
  8. VAR
  9.   i, j, k : INTEGER;
  10.   month, year : INTEGER;
  11.   day, maxday : array[1..3] of INTEGER;
  12.   c: char;
  13.   s : string[132];
  14.   m4, m100, m400 : INTEGER;
  15.   leap : BOOLEAN;
  16.   pline : ARRAY[1..132] OF CHAR;
  17.   plen : INTEGER;
  18.   dayspermonth : ARRAY[1..12] OF INTEGER;
  19.   days : string[132];
  20.   months : ARRAY[1..12] OF STRING[12];
  21.  
  22. PROCEDURE init;
  23. BEGIN
  24.   plen:= 80;
  25.   FOR i:= 1 TO plen DO
  26.     pline[i]:= ' ';
  27.   dayspermonth[ 1] := 31;
  28.   dayspermonth[ 2] := 28;
  29.   dayspermonth[ 3] := 31;
  30.   dayspermonth[ 4] := 30;
  31.   dayspermonth[ 5] := 31;
  32.   dayspermonth[ 6] := 30;
  33.   dayspermonth[ 7] := 31;
  34.   dayspermonth[ 8] := 31;
  35.   dayspermonth[ 9] := 30;
  36.   dayspermonth[10] := 31;
  37.   dayspermonth[11] := 30;
  38.   dayspermonth[12] := 31;
  39.   months[ 1]:= '   January  ';
  40.   months[ 2]:= '  February  ';
  41.   months[ 3]:= '    March   ';
  42.   months[ 4]:= '    April   ';
  43.   months[ 5]:= '     May    ';
  44.   months[ 6]:= '    June    ';
  45.   months[ 7]:= '    July    ';
  46.   months[ 8]:= '   August   ';
  47.   months[ 9]:= '  September ';
  48.   months[10]:= '   October  ';
  49.   months[11]:= '  November  ';
  50.   months[12]:= '  December  ';
  51.   days:='S  M  T  W  T  F  S ';
  52. END;
  53.  
  54. PROCEDURE doline;
  55. VAR
  56.   i: INTEGER;
  57. BEGIN
  58.   FOR i:= 1 to plen DO
  59.   BEGIN
  60.     write(lst,pline[i]);
  61.     pline[i]:=' ';
  62.   END;
  63.   writeln(lst);
  64. END;
  65.  
  66. PROCEDURE mhead;
  67. VAR
  68.   i, j, k, l : INTEGER;
  69. BEGIN
  70.   writeln(lst);
  71.   writeln(lst);
  72.   writeln(lst);
  73.   k := length(days) + 6;
  74.   FOR i := 0 TO 2 DO
  75.   BEGIN
  76.     FOR j := 1 to 12 DO
  77.     BEGIN
  78.       l := i * k + fudge + 4 + j;
  79.       pline[l] := months[month + i][j];
  80.     END;
  81.   END;
  82.   doline;
  83.   FOR i := 0 TO 2 DO
  84.     FOR j := 1 TO length(days) DO
  85.       pline[i * k + j + fudge] := days[j];
  86.   doline;
  87.   writeln(lst);
  88. END;
  89.  
  90. PROCEDURE head;
  91. VAR
  92.   i, j, k : INTEGER;
  93. BEGIN
  94.   FOR i := 1 TO 2 DO
  95.     writeln(lst);
  96.   writeln(lst,' ':35, year);
  97.   if leap THEN
  98.     writeln(lst,' ':32,'A Leap Year');
  99. END;
  100.  
  101. FUNCTION dow(d, m, y : INTEGER): INTEGER;
  102. VAR
  103.   m1 : REAL;
  104.   c, l : INTEGER;
  105. BEGIN
  106.   IF leap THEN
  107.     l := 2
  108.   ELSE
  109.     l := 1;
  110.   c := y DIV 100;
  111.   y := y MOD 100;
  112.   m := m - 2;
  113.   IF m < 1 THEN m := m + 12;
  114.   m1 := (2.6 * m) - 0.2;
  115.   d := d + trunc(m1) + y + (y DIV 4) + (c DIV 4) - 2 * c - (l * (m DIV 11));
  116.   dow := d MOD 7;   { 0 = Sun, 1 = Mon,... }
  117. END;
  118.  
  119. PROCEDURE numout(p, n : INTEGER);
  120. BEGIN
  121.   WHILE n > 0 DO
  122.   BEGIN
  123.     pline[p] := chr(n MOD 10 + 48);
  124.     p := p - 1;
  125.     n := n DIV 10;
  126.   END;
  127. END;
  128.  
  129. PROCEDURE line(VAR done : BOOLEAN);
  130. VAR
  131.   i, j, k, l : INTEGER;
  132. BEGIN
  133.   done := true;
  134.   k := length(days) + 6;
  135.   FOR j := 1 to 3 DO
  136.   BEGIN
  137.     FOR i := 1 TO 7 DO
  138.     BEGIN
  139.       l := (j - 1) * k + fudge + 1;
  140.       IF day[j] <= maxday[j] THEN
  141.         numout(l + (i - 1) * 3, day[j]);
  142.       day[j] := day[j] + 1;
  143.     END;
  144.     done := (day[j] > maxday[j]) AND done;
  145.   END;
  146.   doline;
  147. END;
  148.  
  149. PROCEDURE doyear;
  150. VAR
  151.   i, j, k, y, mon : INTEGER;
  152.   done : BOOLEAN;
  153. BEGIN
  154.   month := 1;
  155.   m4 := year MOD 4;
  156.   m100 := year MOD 100;
  157.   m400 := year MOD 400;
  158.   IF ((m4 = 0) AND (m100 <> 0)) OR (m400 = 0) THEN
  159.   BEGIN
  160.     leap := true;
  161.     dayspermonth[2] := 29;
  162.   END
  163.   ELSE
  164.   BEGIN
  165.     leap := false;
  166.     dayspermonth[2] := 28;
  167.   END;
  168.   head;
  169.   REPEAT
  170.     FOR i := 1 to 3 DO
  171.     BEGIN
  172.       mon := month + i - 1;
  173.       j:= year;
  174.       day[i] := 1 - dow(1, mon, j);
  175.       maxday[i] := dayspermonth[mon];
  176.     END;
  177.     mhead;
  178.     REPEAT
  179.       line(done);
  180.     UNTIL done;
  181.     month := month + 3;
  182.   UNTIL month > 12;
  183. END;
  184.  
  185. BEGIN     { Main }
  186.   init;
  187.   write('Year (i.e. 1986) > ');
  188.   readln(year);
  189.   doyear;
  190.   write(lst,chr(12));
  191. END.
  192.  
  193.