home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / cal.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  11.2 KB  |  382 lines
  1. { MaxonPascal3-Anpassung / Test: Falk Zühlsdorff (PackMAN) 1994 }
  2.  
  3. Program Wochentag;
  4.  
  5. {$incl 'dos.lib'};
  6.  
  7. Const
  8.   Fett     = #$1b'[1m';
  9.   Norm     = #$1b'[0m';
  10.   Unterstr = #$1b'[4m';
  11.  
  12. Type Modus = (Wochentag, Monatskalender, Jahreskalender, Differenz, Inform);
  13.  
  14. Var day,monat,jahr: integer;
  15.     para: string;
  16.     Mode: Modus;
  17.     Dosdatum: Datestamp;
  18.     yho:p_Datestamp;
  19.     Heute, Tage: Long;
  20.  
  21. Function Tagname(i:integer):Str;
  22.   Begin
  23.     Case i Of
  24.     0: Tagname:='Montag';
  25.     1: Tagname:='Dienstag';
  26.     2: Tagname:='Mittwoch';
  27.     3: Tagname:='Donnerstag';
  28.     4: Tagname:='Freitag';
  29.     5: Tagname:='Samstag';
  30.     6: Tagname:='Sonntag'
  31.     End;
  32.   End;
  33.  
  34. Function Monatname(i:integer):Str;
  35.   Begin
  36.     Case i Of
  37.      1: Monatname:='Januar';
  38.      2: Monatname:='Februar';
  39.      3: Monatname:='März';
  40.      4: Monatname:='April';
  41.      5: Monatname:='Mai';
  42.      6: Monatname:='Juni';
  43.      7: Monatname:='Juli';
  44.      8: Monatname:='August';
  45.      9: Monatname:='September';
  46.     10: Monatname:='Oktober';
  47.     11: Monatname:='November';
  48.     12: Monatname:='Dezember';
  49.     End;
  50.   End;
  51.  
  52. Function Monatstage(monat,jahr:integer):integer;
  53.   { Anzahl der Tage eines Monats ermitteln.
  54.     Das Jahr muß wg. Februar in Schaltjahren angegeben werden. }
  55.   Begin
  56.     Case monat of
  57.       1,3,5,7,8,10,12: Monatstage := 31;
  58.       4,6,9,11: Monatstage := 30;
  59.       2: If (jahr mod 4=0) and ((jahr mod 100<>0) or (jahr mod 400=0)) Then
  60.            Monatstage := 29
  61.          Else
  62.            Monatstage := 28;
  63.     End
  64.   End;
  65.  
  66.  
  67. Function Anzahl(t,m,j:integer):Long;
  68.   { Anzahl der seit Donnerstag, dem 1.1.1600 vergangenen Tage }
  69.   Var r: Long;
  70.       i: integer;
  71.   Begin
  72.     r := 365*Long(j-1600)      { normale Tage }
  73.        + Long(j-1600) div 4    { Schaltjahre }
  74.        - Long(j-1600) div 100  { Jahrhunderte keine Schaltjahre }
  75.        + Long(j-1600) div 400; { Alle 400 Jahre doch }
  76.     If (j mod 4=0) and ((j mod 100<>0) or (j mod 400=0)) and (m > 2)
  77.       Then r := r+1;       { In Schaltjahren ab Februar 1 Tag mehr }
  78.     For i:=1 To m-1 Do r := r+Monatstage(i,j);
  79.     Anzahl := r + t - 1
  80.   End;
  81.  
  82.  
  83. Procedure MonthCal(monat,jahr:integer);
  84.   Var i,j,k,mt,t: integer;
  85.       a: Array[1..7,1..8] of Boolean;
  86.   Begin
  87.     writeln;
  88.     writeln(Fett,Unterstr,Monatname(Monat),' ',Jahr);
  89.     writeln(Norm,Fett);
  90.     writeln('     Mo        Di        Mi        Do        Fr        Sa        So',Norm);
  91.     mt := Monatstage(monat,jahr);
  92.     For i:=1 to 8 do
  93.       Begin
  94.         t := 7*i-7+1-(Anzahl(1,monat,jahr)+6) mod 7;
  95.         For k:=0 to 6 do
  96.           a[k+1,i] := (k+t>=1) and (k+t<=mt);
  97.       End;
  98.     i := 1;
  99.     Repeat
  100.       CBreak;
  101.       For j:=1 to 7 do
  102.         If a[j,i] or (i>1) and a[j,i-1]
  103.           Then write('----------')
  104.           Else write('          ');
  105.         If a[7,i] or (i>1) and a[7,i-1] then write('-');
  106.         writeln;
  107.       For j:=1 to 7 do
  108.         Begin
  109.           CBreak;
  110.           t := 7*(i-1)-(Anzahl(1,monat,jahr)+6) mod 7;
  111.           If a[j,i] Then write('|',t+j:2,'       ')
  112.           Else If (j>1) and a[j-1,i] Then write('|         ')
  113.                                      Else write('          ')
  114.         End;
  115.         If a[7,i] then write('|');
  116.         writeln;
  117.       For k:=1 to 6 do
  118.         Begin
  119.           CBreak;
  120.           For j:=1 to 7 do
  121.             If a[j,i] Then write('|         ')
  122.             Else If (j>1) and a[j-1,i] Then write('|         ')
  123.                                        Else write('          ');
  124.           If a[7,i] then write('|');
  125.           writeln
  126.         End;
  127.       i := i+1
  128.     Until not(a[1,i-1] or a[7,i-1]);
  129.   End;
  130.  
  131.  
  132. Procedure Zahlenbanner(n,posn: integer);
  133.   Type Feldtyp = Array[0..5,0..9] of string[6];
  134.   Var i:integer;
  135.       f: Feldtyp; Static;
  136.   Procedure Rekurs(z,l:integer);
  137.     Begin
  138.       If z>=10 Then Rekurs(z div 10,l);
  139.       write(' ',f[l,z mod 10],' ')
  140.     End;
  141.  
  142.   Begin
  143.   f := Feldtyp(
  144.   (" *** ","  *  "," *** ","**** ","*    ","*****"," *** ","*****"," *** "," *** "),
  145.   ("*   *"," **  ","*   *","    *","*  * ","*    ","*    ","    *","*   *","*   *"),
  146.   ("*   *","* *  ","   * "," *** ","*  * ","**** ","**** ","   * "," *** "," ****"),
  147.   ("*   *","  *  ","  *  ","    *","*****","    *","*   *","  *  ","*   *","    *"),
  148.   ("*   *","  *  "," *   ","    *","   * ","    *","*   *"," *   ","*   *","    *"),
  149.   (" *** "," *** ","*****","**** ","   * ","**** "," *** ","*    "," *** "," *** "));
  150.   For i:=0 to 5 do
  151.     Begin
  152.       write('':posn);
  153.       Rekurs(n,i);
  154.       writeln
  155.     End;
  156.   End;
  157.  
  158.  
  159. Procedure YearCal(jahr: integer);
  160.   Var i,mon,k,t,s,mt:integer;
  161.   Begin
  162.     write(Fett);
  163.     Zahlenbanner(jahr,22);
  164.     write(Norm);
  165.     For i:=0 to 3 Do
  166.       Begin
  167.         CBreak;
  168.         writeln(Fett);
  169.         For mon := 3*i+1 to 3*i+3 Do
  170.           Case mon Of
  171.           1: write('        Januar           ');
  172.           2: write('        Februar          ');
  173.           3: write('         März            ');
  174.           4: write('        April            ');
  175.           5: write('         Mai             ');
  176.           6: write('         Juni            ');
  177.           7: write('         Juli            ');
  178.           8: write('        August           ');
  179.           9: write('       September         ');
  180.           10:write('        Oktober          ');
  181.           11:write('       November          ');
  182.           12:write('       Dezember          ');
  183.           End;
  184.         writeln(Norm);
  185.         For mon := 1 to 3 do
  186.           write(' ',unterstr,'Mo Di Mi Do Fr Sa ',Fett,'So',Norm,'    ');
  187.         CBreak;
  188.         For k:=0 to 5 do
  189.           Begin
  190.             writeln;
  191.             For mon := 3*i+1 to 3*i+3 do
  192.               Begin
  193.                 mt := Monatstage(mon,jahr);
  194.                 t := 7*k+1-(Anzahl(1,mon,jahr)+6) mod 7;
  195.                 For s:=t to t+6 do
  196.                   Begin
  197.                     CBreak;
  198.                     If s=t+6 Then write(Fett);
  199.                     If (s>=1) And (s<=mt) Then
  200.                       write(s:3)
  201.                     Else
  202.                       write('   ')
  203.                   End;
  204.                 write(Norm,'    ');
  205.               End;
  206.           End;
  207.         writeln;
  208.       End
  209.   End;
  210.  
  211.  
  212. FUNCTION Fehler:boolean;
  213.   Begin
  214.     writeln('Syntax: cal [[<tag>] <monat>] <jahr> [-]');
  215.     fehler:=true;
  216.   End;
  217.  
  218.  
  219. Function Parse: Modus;
  220.   { Parameterstring auswerten und Modus zurückgeben.
  221.     Jahr, Monat und Tag global setzen.                  }
  222.   Var p: integer;
  223.       c: Char;
  224.   Procedure Get;   { Nächstes Zeichen aus Eingabe lesen }
  225.     Begin
  226.       c := Upcase(para[p]);
  227.       If c >= ' ' Then p:=p+1 else c:=chr(0);
  228.     End;
  229.   Procedure Over;  { Leerzeichen überlesen }
  230.     Begin
  231.       While c=' ' Do Get
  232.     End;
  233.   Procedure Over2;  { Trennzeichen überlesen }
  234.     Begin
  235.       While c in ['.', '-', '/', ' '] Do Get;
  236.     End;
  237.   Procedure GetNum(Var n:integer);
  238.     { Zahl lesen }
  239.     Begin
  240.       n :=0;
  241.       While c in ['0'..'9'] Do
  242.         Begin
  243.           n := 10*n+ ord(c)-ord('0');
  244.           get
  245.         End;
  246.     End;
  247.   Procedure GetMonth(Var m:integer);
  248.     { Monat lesen oder Fehler melden }
  249.     Var i:integer; s:String;
  250.     Begin
  251.       s:='';
  252.       While c In ['A'..'Z','Ä','Ö','Ü'] Do
  253.         Begin
  254.           s:=s+c;
  255.           Get
  256.         End;
  257.       s[4]:=chr(0);     { Nur erste 3 Buchstaben bertachten }
  258.       If s='JAN' Then m:=1 Else
  259.       If s='FEB' Then m:=2 Else
  260.       If(s='MÄR')or(s='MAR')or(s='MAE') Then m:=3 Else
  261.       If s='APR' Then m:=4 Else
  262.       If(s='MAI')or(s='MAY') Then m:=5 Else
  263.       If s='JUN' Then m:=6 Else
  264.       If s='JUL' Then m:=7 Else
  265.       If s='AUG' Then m:=8 Else
  266.       If s='SEP' Then m:=9 Else
  267.       If(s='OKT')or(s='OCT') Then m:=10 Else
  268.       If s='NOV' Then m:=11 Else
  269.       If(s='DEZ')or(s='DEC') Then m:=12 Else IF Fehler THEN exit;
  270.     End;
  271.  
  272.   Begin { "Parse" }
  273.     p := 1;
  274.     Get; Over;
  275.     If c='?' Then
  276.       Begin
  277.         Parse:=Inform;
  278.         Get
  279.       End
  280.     Else
  281.     If c in ['0'..'9'] Then
  282.       Begin
  283.         GetNum(Jahr);
  284.         Over2;
  285.         If c=chr(0) Then Parse := Jahreskalender
  286.         Else
  287.         If c in ['0'..'9'] Then
  288.           Begin
  289.             Monat := Jahr;
  290.             Getnum(jahr);
  291.             Over2;
  292.             If c=chr(0) Then Parse := Monatskalender
  293.             Else
  294.             If c in ['0'..'9'] Then
  295.               Begin
  296.                 day := Monat;
  297.                 Monat := Jahr;
  298.                 Getnum(Jahr);
  299.                 Over;
  300.                 If c=chr(0) Then Parse := Wochentag
  301.                 Else If c='-' Then
  302.                   Begin Parse := Differenz; Get End
  303.                 Else IF Fehler THEN exit;
  304.               End
  305.             Else IF Fehler THEN exit;
  306.           End
  307.         Else  { zweiter Parameter keine Zahl }
  308.           Begin
  309.             day := Jahr;
  310.             GetMonth(Monat);
  311.             Over2;
  312.             If c In ['0'..'9'] Then GetNum(Jahr)
  313.                                Else IF Fehler THEN exit;
  314.             Parse := Wochentag;
  315.             Over;
  316.             If c=chr(0) Then Parse := Wochentag
  317.             Else If c='-' Then
  318.               Begin Parse := Differenz; Get End
  319.             Else IF Fehler THEN exit;
  320.           End;
  321.       End
  322.     Else { erster Parameter keine Zahl }
  323.       Begin
  324.         GetMonth(Monat);
  325.         Over2;
  326.         If c In ['0'..'9'] Then GetNum(Jahr) Else IF Fehler THEN exit;
  327.         Parse := Monatskalender;
  328.       End;
  329.     Over;
  330.     If c<>chr(0) Then IF Fehler THEN exit;{ keine weiteren Parameter zulassen }
  331.   End;
  332.  
  333. Begin
  334.   If FromWB Then Halt(0);
  335.   If (Parameterlen=0) or (Parameterlen>78) Then IF Fehler THEN exit;;
  336.   para := Parameterstr; para[parameterlen+1]:=chr(0);
  337.   Mode := Parse;
  338.   If Mode<>Inform Then
  339.     If Jahr in [0..99] Then Jahr:=Jahr+1900
  340.     Else
  341.     If not(Jahr in [1600..9999]) Then Error('Falsches Jahr!');
  342.   Case Mode Of
  343.     Wochentag: If (Monat<1) or (Monat>12) Then Error('Falscher Monat!')
  344.                Else If (day<1) or (day>Monatstage(Monat,Jahr)) Then
  345.                  Error("Falscher Tag")
  346.                Else
  347.                writeln(day,'. ', Monatname(Monat),' ',jahr,': ',
  348.                  Tagname((Anzahl(day,monat,jahr)+6) mod 7 ));
  349.     Monatskalender: If (Monat<1) or (Monat>12) Then Error('Falscher Monat!')
  350.                     Else MonthCal(Monat,Jahr);
  351.     Jahreskalender: YearCal(jahr);
  352.     Differenz:  If (Monat<1) or (Monat>12) Then Error('Falscher Monat!')
  353.                 Else If (day<1) or (day>Monatstage(Monat,Jahr)) Then
  354.                   Error("Falscher Tag")
  355.                 Else
  356.                 Begin
  357.                   yho:=_Datestamp(^Dosdatum);
  358.                   If Dosdatum.ds_days=0 Then
  359.                     Error("Datum ist nicht gesetzt.");
  360.                   Tage := Anzahl(day,monat,jahr);
  361.                   Heute :=Anzahl(1,1,1978)+Dosdatum.ds_days;
  362.                   If Heute <= Tage Then
  363.                     write('In ',Tage-Heute,' Tagen ist ')
  364.                   Else
  365.                     write('Vor ',Heute-Tage,' Tagen war ');
  366.                   Writeln(Tagname((Tage+6) mod 7 ), ', der ',
  367.                           day, '. ', Monatname(monat),' ', jahr,'.');
  368.                 End;
  369.     Inform: Begin
  370.             writeln('CAL - Das universelle Kalenderprogramm');
  371.             writeln('Geschrieben von Jens Gelhar 1990');
  372.             writeln('Syntax:  cal <jahr>                  Jahreskalender');
  373.             writeln('         cal <monat> <jahr>          Monatskalender');
  374.             writeln('         cal <tag> <monat> <jahr>    Wochentag ausgeben');
  375.             writeln('         cal <tag> <monat> <jahr> -  Differenz zu heutigem Datum');
  376.             End;
  377.   End;
  378.   writeln
  379. End.
  380.  
  381.  
  382.