home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol072 / kalender.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-02-10  |  6.1 KB  |  237 lines
  1. Program Kalender ;
  2. (* This German program generates one or more calenders into a file    *)
  3. (* B:CALENDER.TXT.  The form of the calender is such that it can be    *)
  4. (* easily appended to graphics, eg. Snoopy etc.                *)
  5. (* The program was 'lifted' directly from a German book on programming    *)
  6. (* and required only minor changes to work ( the IO had to be fixed)    *)
  7. (* I thing this demonstrates the true portability of the PASCAL system  *)
  8.  
  9.  
  10. Type Twochtag    =    (So,Mo,Di,Mi,Don,Fr,Sa);
  11.      Tmonat    =    (Jan,Feb,Mrc,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  12.      Tmonatag    =    0..31;
  13.      Tjahr    =    1583..3000;
  14.      Tmonalis    =    Array (. Tmonat .) of
  15.             Record
  16.                 Anftag    :    Twochtag;
  17.                 Laenge    :    28..31  ;
  18.                 Name    :    Array (. 1..9 .) of Char;
  19.             End;
  20.      TBuf       =       Array (. Tmonat .) of
  21.                         Record
  22.                                 Line    :       Array (.1..80 .) of Char;
  23.                         End;
  24.  
  25.  
  26. Var Jahrx, Jahry, J, Jahrb        :    Tjahr;
  27.     Wochtagb                :    Twochtag;
  28.     Monalis                :    Tmonalis;
  29.     Cono                :    Text;
  30.     Out                    :    Text;
  31.     Buf                    :    Tbuf;
  32.  
  33.  
  34.  
  35.  
  36. Procedure Vorspann ;
  37.  
  38. Var Monindex    :    Tmonat;
  39.  
  40. Begin
  41.     Jahrb := 1980;
  42.     Wochtagb := Di;
  43.     With Monalis (. Jan .) Do
  44.     Begin Laenge:=31; Name:='January  '    End;
  45.     With Monalis(. Feb.)   Do  Name :='February ';
  46.     With Monalis(. Mrc.)   Do
  47.     Begin Laenge:=31; Name:='March    ' End;
  48.     With Monalis(.Apr.)    Do
  49.     Begin Laenge:=30; Name:='April    ' End;
  50.     With Monalis(. May.)   Do
  51.     Begin Laenge:=31; Name:='May      ' End;
  52.     With Monalis(. Jun.)   Do
  53.     Begin Laenge:=30; Name:='June     ' End;
  54.     With Monalis(.Jul.)    Do
  55.     Begin Laenge:=31; Name:='July     ' End;
  56.     With Monalis(.Aug.)    Do
  57.     Begin Laenge:=31; Name:='August   ' End;
  58.     With Monalis(.Sep.)    Do
  59.     Begin Laenge:=30; Name:='September' End;
  60.     With Monalis(.Oct.)    Do
  61.     Begin Laenge:=31; Name:='October  ' End;
  62.     With Monalis(.Nov.)    Do
  63.     Begin Laenge:=30; Name:='November ' End;
  64.     With Monalis(.Dec.)    Do
  65.     Begin Laenge:=31; Name:='December ' End;
  66.     
  67. End (* Vorspann *) ;
  68.  
  69.  
  70.  
  71.  
  72.  
  73. Function Schalt (Jahr : Tjahr ) :  Boolean;
  74.  
  75. Begin
  76.     Schalt := (( Jahr Mod 4 = 0) And ( Jahr Mod 100 <> 0))
  77.               Or ( Jahr Mod 400 = 0)
  78.  
  79. End (* Schalt  *)  ;
  80.  
  81.  
  82.  
  83. Function Wtag ( I : Integer )  : Twochtag;
  84.  
  85. Begin
  86.     I:=I Mod 7;
  87.     If I< 0 Then I:=7+I;
  88.     Case I Of
  89.     0: Wtag:=So; 1: Wtag:=Mo; 2: Wtag:=Di; 3: Wtag:= Mi;
  90.     4: Wtag:=Don; 5: Wtag:=Fr; 6: Wtag:=Sa;
  91.     End;
  92. End (* Wtag  *)  ;
  93.  
  94.  
  95. Procedure InitJahr ( Jahrz  : Tjahr );
  96. Var Wochtagz    : Twochtag;
  97.     Tagnr    : Integer;
  98.     J        : Tjahr;
  99.     Monindex    : Tmonat;
  100.  
  101.  
  102. Begin
  103.     Tagnr:=0;
  104.     If Jahrz = Jahrb Then Wochtagz := Wochtagb;
  105.     If Jahrz > Jahrb Then
  106.     Begin
  107.     For J:= Jahrb to Jahrz-1 Do
  108.         If Schalt (J) Then Tagnr:=Tagnr+366
  109.         Else Tagnr:=Tagnr+365;
  110.     Wochtagz:=Wtag(Ord(Wochtagb)+Tagnr)
  111.     End
  112.     Else
  113.     Begin
  114.     For J:=Jahrb-1 Downto Jahrz Do
  115.         If Schalt (J) Then Tagnr:=Tagnr+366
  116.             Else Tagnr:= Tagnr+365;
  117.         Wochtagz:=Wtag(Ord(Wochtagb)-Tagnr)
  118.     End  ;
  119.     
  120.     
  121.     Monalis(.Jan.).Anftag :=Wochtagz;
  122.     If Schalt(Jahrz) then Monalis(.Feb.).Laenge:=29
  123.     Else Monalis(.Feb.).Laenge:=28;
  124.     
  125.     For Monindex:=Feb to Dec Do
  126.     Monalis(.Monindex.).Anftag:=
  127.       Wtag(Ord(Monalis(.Pred(Monindex).).Anftag)
  128.       + Monalis(.Pred(Monindex).).Laenge)
  129.  
  130. End  (* Initjahr  *);
  131.  
  132.  
  133.  
  134.  
  135. Procedure Writemonate ( Jahrz  : Tjahr );
  136.  
  137. Var I :0..33;
  138.     H :Tmonat;
  139.  
  140. Begin
  141.     
  142.     For H:=Jan to Dec Do
  143.     Begin
  144.     Writeln('  ');
  145.     Writeln( Monalis(.H.).Name , Jahrz:5);
  146.     Write( ' ');
  147.     For I:=1 to 5 Do
  148.         Write (' Su Mo Tu We Th Fr Sa' );
  149.         Writeln(' Su Mo Tu ');
  150.         Write(' ':Ord(Monalis(.H.).Anftag)*3+1);
  151.     For I:=1 To Monalis(.H.).Laenge Do
  152.         Write(I:3 );
  153.     Writeln;
  154.     Writeln('  ');
  155.     End;
  156. End  (* Writemonat *)  ;
  157.  
  158.  
  159. Procedure Println( M1: Tmonat; M2: Tmonat; M3: Tmonat);
  160.  
  161. Var    I, J,K    :    Integer;
  162.     M1s,M2s,M3s:    Integer;
  163.         C1,C2,C3   :    Integer;
  164.     Cycle    :    Integer;
  165.  
  166.  
  167. Begin
  168. I:=1;
  169. J:=1;
  170. K:=1;
  171. M1s:=Ord(Monalis(.M1.).anftag);
  172. M2s:=Ord(Monalis(.M2.).anftag);
  173. M3s:=Ord(Monalis(.M3.).anftag);
  174. C1:=M1s; C2:=M2s; C3:=M3s;
  175.  
  176. Writeln(Out,' ');
  177. Writeln(Out,
  178. ' Su Mo Tu We Th Fr Sa      Su Mo Tu We Th Fr Sa      Su Mo Tu We Th Fr Sa');
  179. Writeln(Out);
  180. For Cycle :=1 to 6 Do
  181. Begin
  182.     If M1s <> 0 Then        Write(Out,' ':M1s*3);
  183.     While (7*Cycle-C1 >0)  Do
  184.  
  185.    Begin
  186.     If I<= Monalis(.M1.).Laenge Then
  187.     Write(Out,I:3) Else Write(Out,'   '); I:=I+1; C1:=C1+1;
  188.     End;
  189.     
  190.     Write(Out,' ':5+3*(7*Cycle-C1));
  191.     If M2s <> 0 Then Write(Out,' ':M2s*3);
  192.     While (7*Cycle-C2 >0)  Do
  193.  
  194.    Begin
  195.     If J<= Monalis(.M2.).Laenge Then
  196.     Write(Out,J:3) Else Write(Out,'   '); J:=J+1; C2:=C2+1;
  197.     End;
  198.     
  199.     Write(Out,' ':5+3*(7*Cycle-C2));
  200.     If M3s <> 0 Then Write(Out,' ':M3s*3);
  201.     While (7*Cycle-C3 >0)  Do
  202.  
  203.    Begin
  204.     If K<= Monalis(.M3.).Laenge Then 
  205.     Write(Out,K:3) Else Write(Out,'   '); K:=K+1; C3:=C3+1;
  206.     End;
  207.     M1s:=0; M2s:=0; M3s:=0;
  208.     Writeln(Out,' ');
  209. End;
  210. Writeln(Out,' ');
  211. End;
  212.  
  213.  
  214.  
  215. Begin
  216.     Reset('CON:' , Cono);
  217.     Rewrite('B:CALENDER.TXT',Out);
  218.     Writeln(' CALENDER Started ');
  219.     Writeln(' Input first-year for Calender creation e.g  1982');
  220.     
  221.     Vorspann  ;
  222.     Readln;
  223.     Read ( Jahrx);
  224.     Writeln(' Input the end-year for Calender creation   ');
  225.     Read (Jahry );
  226.     For J:= Jahrx to Jahry Do
  227.     Begin 
  228.     Initjahr(J);
  229.     Writeln(Out,'                                  ',J:4);
  230.     Writeln(Out,' ');    
  231.     Writeln(Out,
  232. '        January                 February                    Marc╩╛6#6>!┐╛┌)*┐&P    ~■╩":┐╓╓ƒ⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒┌"!╛6!┐4┬╔:╛╥_══j┌Y═O
  233. ═j╥M*ƒ"í├S* "í═╚
  234. ├3═@├b═l*╛M═1╔  ƒ═ô╡╞ ƒ╔!"└"─═7    *M═^Ç═å    \═ö!"┬:«╓ ╞ ƒ└┬⌡═ă┴Hí╥─*┬#"┬═º├¥═/    :«■ ┬σ>─═¢╡┬ß9═»    ═.╔*┬#"└:«µççççç_!Çσ'═
  235. !'6!36'┼═
  236. :1/!a╢╥E*─#"─>═z╡┬?C═9═I═▓├ü╔═.!╞6> !╞╛┌ç*╞&'    ~2╟■ ╩Ç:╞■    ┬y.═*╟M═!╞4┬Q╔>!ö╛╥¢:ö=2├í:ⁿ2╔:÷╥¼═\>!ö╛╥┐:ö=2K├┼:ⁿ╩╛6#6>!┐╛┌)*┐&P    ~■╩":┐╓╓ƒ⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒⌡:┐╓╓ƒ┴H▒┌"!╛6!┐4┬╔:╛╥_══j┌Y═O
  237. ═j