MODULE Kalender; (* $StackChk- *)

(* ------------------------------------------------------------------------
  :Program.       Kalender
  :Contents.      einige nützliche Datumsfunktionen
  :Author.        André Schenk
  :Address.       Matthias-Grünewald-Weg 1
  :Address.       D-71065 Sindelfingen (Germany)
  :Address.       andre@melior.s.bawue.de
  :Address.       2:2471/1216.42@fidonet
  :Phone.         +49-7031-811412
  :History.       Kalender 1.1 (04.04.93)
                  erste funktionsfähige Version der Library
  :History.       Kalender 1.2 (10.04.93)
                  Routine zur Berechnung der variablen Feiertage berichtigt
  :History.       Kalender 1.3 (25.04.93)
                  Kontrolle auf ungerade Zeiger an einer Stelle ausgeschaltet
  :History.       Kalender 2.0 (26.04.93)
                  Registernummern für Parameter teilweise geändert
  :History.       Kalender 2.1 (04.05.93)
                  Code aufgeräumt
  :History.       Kalender 2.2 (06.05.93)
                  Modul "SYSTEM" entfernt
  :History.       Kalender 2.3 (24.01.94)
                  einige Routinen mit englischen Namen versehen
                  Test auf geöffnete utility.library eingebaut
  :History.       Kalender 2.4 (09.04.94)
                  Variable dport mit Semaphore geschützt
  :History.       Kalender 2.6 (08.05.94)
                  neue Funktionen GetRealTime, SetRealTime
  :History.       Kalender 2.7 (18.06.94)
                  Stringtypen um ein Byte vergrößert
  :History.       Kalender 2.8 (08.10.95)
                  einige Namen geändert, an Oberon 3.20 angepaßt
  :History.       Kalender 2.9 (27.12.95)
                  Buß- und Bettag aus "Holiday" auskommentiert
  :Copyright.     Freeware
  :Language.      Oberon
  :Translator.    AMIGA OBERON v3.20d, A+L AG
------------------------------------------------------------------------ *)

IMPORT
  a  := Alert,
  b  := BattClock,
  c  := Conversions,
  d  := Dos,
  e  := Exec,
  E  := ExecSupport,
  l  := Locale,
  M  := MathFFP,
  s  := Strings,
  s0 := Strings0,
  t  := Timer,
  u  := Utility,
  S  := SYSTEM;

TYPE
  DatString  * = ARRAY 19 OF CHAR; (* Format: dd-mmm-yy hh:mm:ss *)
  DateString * = ARRAY 10 OF CHAR; (* Format: dd-mmm-yy          *)
  TimeString * = ARRAY  9 OF CHAR; (* Format: hh:mm:ss           *)

  Month - = RECORD
              standard -, locale - : ARRAY 4 OF CHAR
            END;

VAR
  table - : ARRAY 12 OF Month;

(* $Debug- *)
PROCEDURE Inittable;
(* interne Funktion *)
VAR
  locale : l.LocalePtr;
  index  : LONGINT;
BEGIN  
  table  [0].standard := "Jan"; table  [1].standard := "Feb";
  table  [2].standard := "Mar"; table  [3].standard := "Apr";
  table  [4].standard := "May"; table  [5].standard := "Jun";
  table  [6].standard := "Jul"; table  [7].standard := "Aug";
  table  [8].standard := "Sep"; table  [9].standard := "Oct";
  table [10].standard := "Nov"; table [11].standard := "Dec";
  IF l.base # NIL THEN
    locale := l.OpenLocale (NIL);
    IF locale # NIL THEN
      FOR index := 0 TO 11 DO
        (* $OddChk- *)
        COPY (l.GetLocaleStr (locale, l.abMon1 + index)^, table [index].locale)
        (* $OddChk= *)
      END;
      l.CloseLocale (locale)
    END
  END
END Inittable;

PROCEDURE DateToZahl (day, month, year : INTEGER) : LONGINT;
(* interne Funktion *)
VAR
  d, m, y : LONGINT;
BEGIN
  d := day;
  m := month;
  y := year;
  IF m < 3 THEN
    INC (m, 12);
    DEC (y)
  END;             
  RETURN y * 365 + y DIV 4 - y DIV 100 + y DIV 400 + M.Fix (30.60001 * M.Flt (m + 1)) - 122 + d
END DateToZahl;

PROCEDURE Easter (year : INTEGER) : LONGINT;
(* interne Funktion *)
CONST
  lastjul = 1582; (* dieses Kalender-System gilt erst seit 1582 *)
VAR
  day, month, a, b, c, d, e, x, y : INTEGER;
BEGIN
   a := year MOD 19;
   b := year MOD 4;
   c := year MOD 7;
   IF year <= lastjul THEN
     x := 15;
     y := 6
   ELSE
     x := ((year DIV 100) - (year DIV 400) - (year DIV 300) + 15) MOD 30;
     y := ((year DIV 100) - (year DIV 400) + 4) MOD 7
   END;
   d := (19 * a + x) MOD 30;
   e := (2 * b + 4 * c + 6 * d + y) MOD 7;
   IF (e = 6) & ((d = 29) OR ((d = 28) & (a > 10))) THEN
      day := 15 + d + e
   ELSE
      day := 22 + d + e
   END;
   IF day > 31 THEN              (* Tages-Datum über 31. ?                  *)
      month := 4;                (* J:  Monat dann APRIL                    *)
      DEC (day, 31)              (*     Tag für diesen Monat neu berechnen  *)
   ELSE                          (*    ------------------------------------ *)
      month := 3                 (* N:  Monat = MÄRZ                        *)
   END;
   RETURN DateToZahl (day, month, year)
END Easter;

PROCEDURE DateStampToRecord * (date     {2} : LONGINT;
                               VAR time {8} : u.ClockData);
(* wandelt ein Systemdatum (secs aus TimeVal des timer.device) in den *)
(* Verbund "time" *)
(* $SaveRegs+ *)
BEGIN  
  u.Amiga2Date (date, time)  
END DateStampToRecord;
(* $Debug= *)

PROCEDURE RecordToString * (VAR time {8} : u.ClockData;
                            VAR str  {9} : DatString);
(* wandelt den Verbund "time" in den String "str" *)
VAR 
  TagS, JahrS, StundeS, MinuteS, SekundeS : ARRAY 3 OF CHAR;
(* $SaveRegs+ *)
BEGIN
  IF c.IntToStr (LONG (time.mday), TagS,     10, 2, "0") THEN END;
  IF c.IntToStr (LONG (time.year), JahrS,    10, 2, "0") THEN END;
  IF c.IntToStr (LONG (time.hour), StundeS,  10, 2, "0") THEN END;
  IF c.IntToStr (LONG (time.min),  MinuteS,  10, 2, "0") THEN END;
  IF c.IntToStr (LONG (time.sec),  SekundeS, 10, 2, "0") THEN END;
  s0.Delete (str);
  s0.Append (str, TagS, 2); s0.AppendChar (str, "-");
  IF time.month <= 0 THEN
    time.month := 1
  END;
  s0.Append (str, table [time.month - 1].standard, 3);
  s0.AppendChar (str, "-"); s0.Append (str, JahrS,    2);
  s0.AppendChar (str, " "); s0.Append (str, StundeS,  2);
  s0.AppendChar (str, ":"); s0.Append (str, MinuteS,  2);
  s0.AppendChar (str, ":"); s0.Append (str, SekundeS, 2)
END RecordToString;

PROCEDURE DateStampToString * (date    {2} : LONGINT;
                               VAR str {8} : DatString);
(* wandelt das Systemdatum in den String "str" *)
VAR
  time : u.ClockData;
(* $SaveRegs+ *)
BEGIN
  DateStampToRecord (date, time);
  RecordToString (time, str) 
END DateStampToString; 

PROCEDURE UnixDateStampToString * (date    {2} : LONGINT;
                                   VAR str {8} : DatString);
(* wandelt ein Unix-Systemdatum in den String "str" *)
(* Format des UnixDateStamps:               *)
(* Bit  0 -  4 : Sekunde in Zweierschritten *)
(* Bit  5 - 10 : Minute                     *)
(* Bit 11 - 15 : Stunde                     *)
(* Bit 16 - 21 : Tag                        *)
(* Bit 22 - 25 : Monat                      *)
(* Bit 26 - 31 : Jahr + 1980                *)
VAR
  datestamp : LONGINT;
  time      : u.ClockData;
(* $SaveRegs+ *)
BEGIN
  datestamp  := date;
  time.sec   := SHORT (datestamp MOD 32);
  IF time.sec > 0 THEN
    time.sec := time.sec * 2 - 1
  END;
  datestamp  := datestamp DIV 32;
  time.min   := SHORT (datestamp MOD 64);
  datestamp  := datestamp DIV 64;
  time.hour  := SHORT (datestamp MOD 32);
  datestamp  := datestamp DIV 32;
  time.mday  := SHORT (datestamp MOD 32);
  datestamp  := datestamp DIV 32;
  time.month := SHORT (datestamp MOD 16);
  datestamp  := datestamp DIV 16;
  time.year  := SHORT (datestamp MOD 128 + 80);
  RecordToString (time, str) 
END UnixDateStampToString; 

PROCEDURE GetSysTime * () : LONGINT;
(* schreibt die aktuelle Zeit in einen LONGINT-Wert *)
(* Bei einem Fehler wird -1 zurückgegeben. *)
VAR 
  time : t.TimeVal;
  dreq : t.TimeRequestPtr;
(* $SaveRegs+ *)
BEGIN
  time.secs := -1;
  dreq := e.AllocVec (SIZE (dreq^), LONGSET {e.memClear, e.public, e.reverse});
  IF dreq # NIL THEN
    IF e.OpenDevice (t.timerName, t.microHz, dreq, LONGSET {}) = 0 THEN
      t.base := dreq^.node.device;
      t.GetSysTime (time);
      t.base := NIL;
      e.CloseDevice (dreq)
    END;
    e.FreeVec (dreq)
  END;
  RETURN time.secs
END GetSysTime;
  
(* $Debug- *)
PROCEDURE SetSysTime * (time {2} : LONGINT) : BOOLEAN;
(* stellt die System-Uhr nach dem übergebenen Systemdatum *)
VAR 
  ok   : BOOLEAN;
  port : e.MsgPortPtr;
  dreq : t.TimeRequestPtr;
(* $SaveRegs+ *)
BEGIN
  ok := FALSE;
  port := e.CreateMsgPort ();
  IF port # NIL THEN
    dreq := E.CreateExtIO (port, SIZE (t.TimeRequest));
    IF dreq # NIL THEN
      IF e.OpenDevice (t.timerName, t.vBlank, dreq, LONGSET {}) = 0 THEN
        dreq^.node.command := t.setSysTime;
        dreq^.time.secs := time;
        ok := e.DoIO (dreq) = 0;
        e.CloseDevice (dreq)
      END;
      E.DeleteExtIO (dreq)
    END;
    e.DeleteMsgPort (port)
  END;
  RETURN ok
END SetSysTime;
  
PROCEDURE TimeToRecord * (VAR time {8} : u.ClockData);
(* schreibt die aktuelle Systemzeit in den Verbund "time" *)
(* $SaveRegs+ *)
BEGIN
  DateStampToRecord (GetSysTime (), time)
END TimeToRecord;
    
PROCEDURE TimeToString * (VAR str {8} : DatString);
(* schreibt die aktuelle Systemzeit in den String "str" *)
VAR
  time : u.ClockData;
(* $SaveRegs+ *)
BEGIN
  TimeToRecord (time);
  RecordToString (time, str)
END TimeToString;
  
PROCEDURE RecordToDateStamp * (VAR time {8} : u.ClockData) : LONGINT;
(* wandelt den Verbund "time" in ein Systemdatum *)
(* $SaveRegs+ *)
BEGIN
  RETURN u.CheckDate (time)
END RecordToDateStamp;

PROCEDURE StringToDate * (VAR str  {8} : DateString;
                          VAR time {9} : u.ClockData);
(* sucht dd-mmm-yy im String "str" und schreibt Tag, Monat und Jahr *)
(* in den Verbund "time" *)
VAR
  date         : d.DatStringPtr;
  index, month : INTEGER;

  PROCEDURE ParseDate (VAR str : d.DatString); 
  (* macht aus einer Zeichenfolge das Format dd-mmm-yy *)
  VAR
    date : d.DateTime;
  BEGIN
    date.format  := d.formatDos;
    date.flags   := SHORTSET {};
    date.strDate := S.ADR (str);
    IF d.StrToDate (date) THEN
      IF d.DateToStr (date) THEN
        COPY (date.strDate^, str)
      END
    END
  END ParseDate;

(* $SaveRegs+ *)
BEGIN
  S.ALLOCATE (date);
  IF date # NIL THEN
    COPY (str, date^);
    ParseDate (date^);
    time.mday := ORD (date^ [1]) - 48;
    IF (date^ [0] # " ") & (date^ [0] # "0") THEN
      INC (time.mday, 10 * (ORD (date^ [0]) - 48))
    END;
    month := 0;
    index := -1;
    WHILE (index # 3) & (month < 12) DO
      INC (month);
      index := SHORT (s.Occurs (date^, table [month - 1].standard));
      IF index # 3 THEN
        index := SHORT (s.Occurs (date^, table [month - 1].locale))
      END
    END;
    time.month := month;
    time.year  := 10 * (ORD (date^ [7]) - 48) + ORD (date^ [8]) - 48 + 1900;
    u.Amiga2Date (u.CheckDate (time), time);
    DISPOSE (date)
  END
END StringToDate;

PROCEDURE StringToTime * (VAR str  {8} : TimeString;
                          VAR time {9} : u.ClockData);
(* sucht hh:mm:ss im String "str" und schreibt die Stunden, Minuten *)
(* und Sekunden in den Verbund "time" *)
VAR
  date : d.DatStringPtr;

  PROCEDURE ParseTime (VAR str : d.DatString); 
  (* macht aus einer Zeichenfolge das Format hh:mm:ss *)
  VAR
    date : d.DateTime;
  BEGIN
    date.format  := d.formatDos;
    date.flags   := SHORTSET {};
    date.strTime := S.ADR (str);
    IF d.StrToDate (date) THEN
      IF d.DateToStr (date) THEN
        COPY (date.strTime^, str)
      END
    END
  END ParseTime;

(* $SaveRegs+ *)
BEGIN
  S.ALLOCATE (date);
  IF date # NIL THEN
    COPY (str, date^);
    ParseTime (date^);
    time.hour := 10 * (ORD (date^ [0]) - 48) + ORD (date^ [1]) - 48;
    time.min  := 10 * (ORD (date^ [3]) - 48) + ORD (date^ [4]) - 48;
    time.sec  := 10 * (ORD (date^ [6]) - 48) + ORD (date^ [7]) - 48;
    DISPOSE (date)
  END
END StringToTime;

PROCEDURE StringToRecord * (VAR str  {8} : DatString;
                            VAR time {9} : u.ClockData);
(* wandelt den String "str" in den Verbund "time" *)
VAR
  date : DateString;
  Time : TimeString;
(* $SaveRegs+ *)
BEGIN
  s.Cut (str,  0, 9, date); StringToDate (date, time);
  s.Cut (str, 10, 8, Time); StringToTime (Time, time);
  u.Amiga2Date (u.CheckDate (time), time)
END StringToRecord; 

PROCEDURE WeekDay * (day   {2},
                     month {3},
                     year  {4} : INTEGER) : INTEGER;
(* berechnet den Wochentag aus dem Datum                                   *)
(* <- day   [1 .. 31]                                                      *)
(* <- month [1 .. 12]                                                      *)
(* <- year  [1582 .. MAX (INTEGER)]                                        *)
(* -> Nummer des Wochentags [0 .. 6]                                       *)
(*    0 = Sonntag, 1 = Montag, ... , 6 = Samstag                           *)
VAR
  time : u.ClockData;
(* $SaveRegs+ *)
BEGIN
  time.mday  := day;
  time.month := month;
  time.year  := year;
  u.Amiga2Date (u.CheckDate (time), time);
  RETURN time.wday
END WeekDay;

PROCEDURE BBTag (day, month, year : INTEGER) : BOOLEAN;
(* interne Funktion; prüft, ob ein Datum auf den Buß- und Bettag fällt *)
VAR
  d, m, wd : INTEGER;
BEGIN
  d := 15;
  m := 11;
  REPEAT
    INC (d);
    wd := WeekDay (d, m, year)
  UNTIL (wd = 3);
  RETURN (d = day) & (m = month)
END BBTag;

PROCEDURE Holiday * (day   {2},
                     month {3},
                     year  {4} : INTEGER) : BOOLEAN;
(* <- wie bei der Prozedur Wochentag                             *)
(* -> TRUE, wenn das Datum auf einen gesetzlichen Feiertag fällt *)
(* $SaveRegs+ *)
BEGIN
  RETURN
   (* ----------------------- Neujahr------------------------- *)
   ((month = 1) & (day =  1))                                  OR
   (* --------------------- Karfreitag ----------------------- *)
   (DateToZahl (day, month, year) = Easter (year) - 2)         OR
   (* --------------------- Ostermontag ---------------------- *)
   (DateToZahl (day, month, year) = Easter (year) + 1)         OR
   (* --------------------- Maifeiertag ---------------------- *)
   ((month = 5) & (day = 1))                                   OR
   (* ----------------- Christi Himmelfahrt ------------------ *)
   (DateToZahl (day, month, year) = Easter (year) + 39)        OR
   (* -------------------- Pfingstmontag --------------------- *)
   (DateToZahl (day, month, year) = Easter (year) + 50)        OR
   (* -------------- Tag der Deutschen Einheit  -------------- *) 
   ((month = 10) & (day = 3))                                  OR
(*
   (* ------------------- Buß- und Bettag -------------------- *)
   (BBTag (day, month, year))                                  OR
*)
   (* ---------------- Weihnachten, Silvester ---------------- *)
   ((month = 12) & ((day = 24) OR (day = 25) OR (day = 26)     OR
                    (day = 26) OR (day = 31)))             
END Holiday;

PROCEDURE GetRealTime * () : LONGINT;
(* liest die Zeit aus der Echtzeituhr      *)
(* Bei einem Fehler wird -1 zurückgegeben. *)
VAR
  time : LONGINT;
  base : e.APTR;
(* $SaveRegs+ *)
BEGIN
  time := -1;
  base := e.OpenResource (b.battClockName);
  IF base # NIL THEN
    b.base := base;
    time := b.ReadBattClock ()
  END;
  RETURN time
END GetRealTime;

PROCEDURE SetRealTime * (time {2} : LONGINT) : BOOLEAN;
(* schreibt die Zeit in die Echtzeituhr *)
VAR
  ok   : BOOLEAN;
  base : e.APTR;
(* $SaveRegs+ *)
BEGIN
  ok := FALSE;
  base := e.OpenResource (b.battClockName);
  IF base # NIL THEN
    b.base := base;
    b.WriteBattClock (time);
    ok := TRUE
  END;
  RETURN ok
END SetRealTime;
(* $Debug= *)

BEGIN
  IF d.base^.lib.version < 37 THEN
    a.Request ("", "requires Kickstart 2.04 !");
    HALT (d.fail)
  END;
  Inittable
END Kalender.