I2010506%DBSTU1.BITNET@cunyvm.cuny.edu (04/25/89)
Date: 24 April 1989, 18:03:17 MEZ
From: Christian Boettger +49 (0)531 3915113 / I2010506 at DBSTU1
To: info-pascal at vim.brl
program kalender (input,output);
type jahre = 1982..2399;
monate = (jan,feb,mrz,apr,mai,jun,jul,aug,sep,okt,nov,dez);
wochen = 0..5;
tage = 0..6;
wtage = packed array [1..2] of char;
spalten = 0..133;
var jahr : jahre;
ausgabe : text;
spalte : spalten;
procedure rahmen (var ausgabe : text);
begin
write (ausgabe,' ');
write (ausgabe,'*');
write (ausgabe,' ':125);
writeln (ausgabe,'*');
end;
procedure ueberschrift (jahr:jahre);
type ziffernsegmente = packed array [1..9] of char;
zeilen = 1..7;
spalten = 0..133;
ziffern = 0..9;
stellen = (tausender,hunderter,zehner,einer);
var zeile : zeilen;
spalte : spalten;
stelle : stellen;
ziffer : ziffern;
i : zeilen;
function teileauf (st:stellen;j:jahre):ziffern;
begin
case st of
tausender: teileauf := j div 1000;
hunderter: teileauf := (j mod 1000) div 100;
zehner : teileauf := (j mod 100) div 10;
einer : teileauf := j mod 10
end
end;
function ziffernsegment (z:zeilen;ziffer:ziffern):ziffernsegmente;
var s1,s2,s3,s4,s5,s6,s7,s8 : ziffernsegmente;
begin
s1 := ' ****** ';
s2 := ' ** **';
s3 := ' ** ';
s4 := ' *** ';
s5 := ' ** ';
s6 := ' ** ';
s7 := ' ** ';
s8 := ' **';
case z of
1 : case ziffer of
1 : ziffernsegment := s4;
2,3,5,6,7,8,9,0 : ziffernsegment := s1;
4 : ziffernsegment := s2
end;
2,3 : case ziffer of
1 : ziffernsegment := s5;
2,3,7 : ziffernsegment := s8;
4,8,9,0 : ziffernsegment := s2;
5,6 : ziffernsegment := s3
end;
4 : case ziffer of
1 : ziffernsegment := s5;
2,3,4,5,6,8,9 : ziffernsegment := s1;
7 : ziffernsegment := s7;
0 : ziffernsegment := s2
end;
5 : case ziffer of
1 : ziffernsegment := s5;
2 : ziffernsegment := s3;
3,4,5,9 : ziffernsegment := s8;
6,8,0 : ziffernsegment := s2;
7 : ziffernsegment := s6
end;
6 : case ziffer of
1,7 : ziffernsegment := s5;
2 : ziffernsegment := s3;
3,4,5,9 : ziffernsegment := s8;
6,8,0 : ziffernsegment := s2
end;
7 : case ziffer of
1,2,3,5,6,8,9,0 : ziffernsegment := s1;
4 : ziffernsegment := s8;
7 : ziffernsegment := s5
end
end
end;
begin (* of ueberschrift *)
write (ausgabe,' ');
for spalte := 1 to 126 do write (ausgabe,'*');
writeln (ausgabe,'*');
rahmen (ausgabe); rahmen(ausgabe);
for zeile := 1 to 7 do
begin
write(ausgabe,' ');
write(ausgabe,'*');
write(ausgabe,' ':43);
for stelle := tausender to einer do
begin
ziffer := teileauf (stelle,jahr);
write (ausgabe,ziffernsegment(zeile,ziffer):11)
end;
write (ausgabe,' ':38);
writeln(ausgabe,'*')
end;
for i := 1 to 5 do rahmen (ausgabe);
write (ausgabe,' ');
for spalte := 1 to 126 do write (ausgabe,'*');
writeln (ausgabe,'*');
rahmen (ausgabe); rahmen(ausgabe);
end;
procedure druck (anfangsmonat,endmonat:monate;jahr:jahre);
var tag : tage;
woche : wochen;
monat : monate;
kalender : array [jan..dez,0..6,0..5] of integer;
function schaltjahr (j:jahre):boolean;
begin
if ((j mod 4 = 0) and (j mod 100 <> 0) or (j mod 400 = 0))
then schaltjahr := true
else schaltjahr := false
end;
function jahresanfang (j:jahre):tage;
var jj : jahre;
t : tage;
begin
t := 4;
for jj := 1983 to j do
if schaltjahr (jj-1)
then t := (t+2) mod 7
else t := (t+1) mod 7;
jahresanfang := t
end;
function laenge (m:monate;j:jahre):integer;
begin
case m of
jan,mrz,mai,jul,aug,okt,dez : laenge := 31;
apr,jun,sep,nov : laenge := 30;
feb : if schaltjahr(j)
then laenge := 29
else laenge := 28
end
end;
function monatsanfang (m:monate;j:jahre):tage;
var mm : monate;
t : tage;
begin
if m = jan then monatsanfang := jahresanfang(j)
else begin
t := jahresanfang(j);
for mm := jan to pred(m) do
t := (t+laenge(mm,j)) mod 7;
monatsanfang := t
end;
end;
function wochentag (t:tage):wtage;
begin
case t of
0 : wochentag := 'Mo';
1 : wochentag := 'Tu';
2 : wochentag := 'We';
3 : wochentag := 'Th';
4 : wochentag := 'Fr';
5 : wochentag := 'Sa';
6 : wochentag := 'Su'
end
end;
begin (* of druck *)
for monat := anfangsmonat to endmonat do
for tag := 0 to 6 do
for woche := 0 to 5 do
kalender[monat,tag,woche] := 1+tag+woche*7
-monatsanfang(monat,jahr);
rahmen (ausgabe);
for tag := 0 to 6 do
begin
write (ausgabe,' ');
write (ausgabe,'*');
write (ausgabe,' ':28);
write(ausgabe,wochentag(tag):3,' ');
for monat := anfangsmonat to endmonat do
for woche := 0 to 5 do
begin
if ( kalender[monat,tag,woche] <= 0 ) or
( kalender[monat,tag,woche] > laenge(monat,jahr) )
then write(ausgabe,' ':3)
else write(ausgabe,kalender[monat,tag,woche]:3)
end;
write (ausgabe,wochentag(tag):3);
write (ausgabe,' ':18); writeln (ausgabe,'*');
end;
rahmen (ausgabe);rahmen (ausgabe)
end;
(******************************************************************)
(************* hauptprogramm **************)
(******************************************************************)
begin
read(jahr);
if ( jahr >= 1983 ) and ( jahr <= 2399 )
then begin
rewrite(ausgabe);
ueberschrift(jahr);
write (ausgabe,' ');
write (ausgabe,'*');
write (ausgabe,' ':32);
write (ausgabe,'January':12,'February':19);
write (ausgabe,'March':16,'April':18);
write (ausgabe,' ':28);
writeln (ausgabe,'*');
druck(jan,apr,jahr);
write (ausgabe,' ');
write (ausgabe,'*');
write (ausgabe,' ':32);
write (ausgabe,'May':9,'June':19);
write (ausgabe,'July':18,'August':20);
write (ausgabe,' ':27);
writeln (ausgabe,'*');
druck(mai,aug,jahr);
write (ausgabe,' ');
write (ausgabe,'*');
write (ausgabe,' ':32);
write (ausgabe,'September':15,'October':16);
write (ausgabe,'November':19,'December':16);
write (ausgabe,' ':27);
writeln (ausgabe,'*');
druck(sep,dez,jahr);
rahmen (ausgabe);
write (ausgabe,' ');
for spalte := 1 to 126 do write (ausgabe,'*');
writeln (ausgabe,'*');
writeln (ausgabe);
close(ausgabe);
end
else
begin
write('This program evaluates calendars for years ');
writeln('between 1983 and 2399 ||');
if ( jahr < 1983 )
then writeln('Try it in a museum |');
if ( jahr > 2399 )
then writeln('You won`t live then anyway |')
end
end.
________________________________________________________________________________
Christian Boettger phone: (+49) (0)531/391-5113
mail: Institut fuer Metallphysik und Nukleare Festkoerperphysik,
(room -167/-168), Technische Universitaet Braunschweig,
Mendelssohnstrasse 3, D-3300 Braunschweig, Bundesrepublik Deutschland
________________________________________________________________________________
EARN: I2010506@DBSTU1.BITNET InterNet: boettger@julian.uwo.CA
I2010605@DBSTU1.BITNET UseNet: boettger@julian.UUCP
********************************************************************************