Kalenderroutinen

Forth Source Code zum Beitrag: „Geburtstagsfragen (2)“ aus dem Forth Magazin Vierte Dimension.

\ ------------------------------------------------------------------------
\  K a l e n d e r - R o u t i n e n  (Gforth 0.7.0)   30jul12 17:30 -jgt
\ ------------------------------------------------------------------------

  cr cr ."  Berechnung der Differenz zweier Kalenderdaten oder"
     cr ."  eines zweiten Kalenderdatums aus der Differenz. Die"
     cr ."  Differenz kann auch als Vielfaches des astronomischen"
     cr ."  Sonnenjahres (tropischen Jahres) eingegeben werden."

\ Zur Differenzbildung wird eine fortlaufende Tageszählung verwendet,
\ die nach Julianischem Kalender am 3. März im Jahr 1 unserer
\ Zeitrechnung mit Tag Null beginnt. Das ist nach proleptischem
\ (= vorgezogenem) Gregorianischem Kalender (der vor 1582 keine
\ historische Bedeutung hat) der 1. März des Jahres Null.
\
\ Mit diesem Tag beginnt ein 400-Jahres-Zyklus. Durch Beginn des
\ (virtuellen) Jahres mit März ergibt sich ein Schalttag am Jahresende
\ durch den Start des neuen Jahres. Die Monate März bis Dezember
\ behalten ihre Nummerierung, Januar und Februar gelten als 13. und
\ 14. Monat des Vorjahres.
\
\ Neben der intern verwendeten Tageszahl (TZ) wird der gebräuchliche
\ "Julian Day" (JD, nach Scalinger) angezeigt. Er beginnt mit dem
\ 1. Januar 4713 v.Chr., in seiner historischen Variante um 0 Uhr,
\ astronomisch jedoch um 12 Uhr mittags, was nach Gregorianischem
\ Kalender -4713-11-24 12:00 (UT) entspricht. Um aus TZ den astrono-
\ mischen JD zu erhalten, wird 1721119,5 addiert.
\
\ Bei Programmstart wird der Kalender gewählt: gregorianisch, julianisch
\ ------------------------------------------------------------------------
\ oder hybrid (historisch). Letzteres soll heißen, dass ein Eingabedatum
\ vor 1582-10-15 automatisch julianisch interpretiert wird. Historisch
\ folgte auf 1582-10-04 (jul.) unmittelbar 1582-10-15 (greg.).
\
\ Sodann wird in der Hauptschleife ein Eingabedatum angefordert und
\ die gewünschte Funktion gewählt: (a) Eingabe eines zweiten Datums
\ und Anzeige der dazwischen liegenden Tage, Stunden und Minuten;
\ (b) Eingabe eines Offsets in Tagen und Ausgabe des resultierenden
\ Datums; (c) Eingabe einer Anzahl Sonnenjahre und tabellarische
\ Ausgabe der dazwischen liegenden Daten zur jeweils gleichen Jahres-
\ zeit ("Wahrer Geburtstag"). Zu beachten: Bei (b) und (c) wird der
\ Kalender des Ausgangstages beibehalten, auch wenn der historische
\ Kalendersprung in die Quere kommen sollte.
\
\ Die Länge des Sonnenjahres ist leichten Veränderungen unterworfen.
\ Zu Beginn de Jahres 2000 betrug sie 365,2421905 Tage, gegenwärtig
\ liegt sie bei 365,242375 Tagen. 365,2423 dürfte ein für unsere Zwecke
\ brauchbarer Wert sein. (Das Gregorianische Jahr dauert - über 400
\ Jahre gemittelt - 365,2425 Tage.)

\ ------------------------------------------------------------------------
\       K O N S T A N T E N   U N D   V A R I A B L E N
\ ------------------------------------------------------------------------
        fvariable  TZ1      fvariable  TZ2      \ Tageszähler
        variable   wahl                         \ Funktionswahl
        variable   offs     1 offs !            \ Datums-Offset
        variable   trops    1 trops !           \ Anzahl Sonnenjahre
        variable   stepWid                      \ Tabellen-Schrittweite
        variable   mode                         \ Kalenderwahl
        variable   jflag                        \ julianisches Flag
        variable   func                         \ Funktionsvariable
        variable   temp                         \ Kurzzeitvariable

        365.2423e  fconstant  ftrop             \ tropisches Jahr

        s"          Jahr = "  2constant  Jhr$
        s"         Monat = "  2constant  Mon$
        s"           Tag = "  2constant  Tag$
        s"        Stunde = "  2constant  Std$
        s"        Minute = "  2constant  Min$

\ Datumsvariablen aktuell vorbesetzen. (Bei Verwendung des Julianischen
\ Kalenders bis in die Neuzeit wird das aktuelle Datum umgerechnet.)
    time&date  ( sec min hour day month year)
        dup  variable Jhr1  Jhr1 !   variable Jhr2  Jhr2 !
        dup  variable Mon1  Mon1 !   variable Mon2  Mon2 !
        dup  variable Tag1  Tag1 !   variable Tag2  Tag2 !
        dup  variable Std1  Std1 !   variable Std2  Std2 !
        dup  variable Min1  Min1 !   variable Min2  Min2 !  ( sec) drop

\ ------------------------------------------------------------------------
\       H I L F S F U N K T I O N E N
\ ------------------------------------------------------------------------
\ In einem Feld mit p Positionen wird die doppelt-genaue Zahl d
\ mindestens #-stellig (ggf. mit führenden Nullen) rechtsbündig ausgeben.
: d.r#  ( d # p --)  >r 1- >r tuck dabs
        <<# r> 0 do # loop #s rot sign #>
        r> over - spaces type #>> ;

\ Die einfach-genaue Zahl n wird mindestens #-stellig (ggf. mit
\ führenden Nullen) ausgeben, ohne Blank am Ende.
: .#  ( n # --)  swap s>d rot  0 d.r# ;

\ Division mit Aufrunden.
: /up  ( n1 n2 -- n3)  negate / negate ;

\ Integer-Funktion: r2 ist der ganzzahlige Anteil von r1.
: fint  ( r1 -- r2)  f>d d>f ;

\ Wie »f.«, aber mit unterdrücktem Dezimalpunkt im Integer-Fall.
: f.'  ( r --)  fdup fdup fint f= IF f>d d. ELSE f. THEN ;

\ Ausgabe einer Zeichenkette, eingeschlossen in Anführungszeichen.
\ Beispiel für einen Aufruf: s" Hallo!" type"
: type"  ( stringvar --)  [char] " emit  type  [char] " emit ;

\ Mehrfach-Drop vom Daten-Stack.
: drops  ( n xx --)  0 DO drop LOOP ; 

\ Kürzel für Kalenderwahl.
: juln  ( --)  -1 jflag ! ;              \ julianischer Kalender
: greg  ( --)   0 jflag ! ;              \ gregorianischer Kalender
\ ------------------------------------------------------------------------
\       T A G E S Z A H L   A U S   D A T U M
\ ------------------------------------------------------------------------
\ Januar und Februar zum 13. und 14. Monat des Vorjahres deklarieren.
: Justage  ( Mon Jhr -- Mon' Jhr')  over 3 < IF 1- swap 12 + swap THEN ;

\ Aus der Jahreszahl die (ganzzahlige) Tagesnummer für 1. März berechnen.
: gJhr>TN  ( n1 -- n2)       \ für Gregorianischn Kalender
    400 /mod 146097 *       swap    \ 146097 = 400*365 + 97
    100 /mod  36524 * rot + swap    \  36524 = 100*365 + 24
      4 /mod   1461 * rot + swap    \   1461 =   4*365 + 1
                365 *     + ;       \    365 =   1*365

: jJhr>TN  ( n1 – n2)        \ für Julianischen Kalender
      4 /mod   1461 * swap          \   1461 =   4*365 + 1
                365 * +             \    365 =   1*365
                  2 - ;      \ Kalenderdifferenz zum Zeitpunkt TZ=0 

\ Aus der Jahreszahl die (ganzzahlige) Tagesnummer für 1. März berechnen.
: Jhr>TN  ( n1 -- n2)  jflag @  IF  jJhr>TN  ELSE  gJhr>TN  THEN ;

\ Aus Monatstag (n1) und Monat (n2) die Tage seit 1. März (n3) ermitteln.
: Mon&Tag>Tage  ( n1 n2 -- n3)  1+ 306 * 10 / 123 - + ;

\ Aus Minute (n1) und Stunde (n2) den Tagesbruchteil (r) berechnen.
: Std&Min>Tag  ( n1 n2 -- r)  s>f 24e f/  s>f 1440e f/ f+ ;

\ Aus einem Kalenderdatum die (ganzzahlige) Tagesnummer berechnen.
: Jhr&Mon&Tag>TN  ( Tag Mon Jhr -- n)  Jhr>TN -rot Mon&Tag>Tage + ;

\ Aus einem Kalenderdatum die Tageszahl berechnen.
: Date>TZ  ( Min Std Tag Mon Jhr -- r)
        Justage Jhr&Mon&Tag>TN s>f Std&Min>Tag f+ ;

\ Den »Julian Day« (JD, astron.) berechnen. Nicht verwendet im Programm.
: Date>JD  ( Min Std Tag Mon Jhr -- MJD)  Date>TZ  1721119.5e f+ ;

\ ------------------------------------------------------------------------
\       D A T U M   A U S   T A G E S Z A H L
\ ------------------------------------------------------------------------
\ Aus der (ganzzahligen) Tagesnummer Jahreszahl und Jahrestage berechnen.
: gTN>Jhr&Tage  ( n -- Tage Jahr)         \ für Gregorianischen Kalender
      146097 /mod >r    36524 /mod dup 4 =
             IF  1- nip 36524 swap  THEN  >r
        1461 /mod >r      365 /mod dup 4 =
             IF  1- nip   365 swap  THEN
             r> 4 * +  r> 100 * +  r> 400 * + ;

: jTN>Jhr&Tage  ( n -- Tage Jahr)  2 +    \ für Julianischen Kalender
        1461 /mod >r      365 /mod dup 4 =
             IF  1- nip   365 swap  THEN
             r> 4 * + ;

\ Aus der (ganzzahligen) Tagesnummer Jahreszahl und Jahrestage berechnen.
\ Schaltjahre werden erkannt (4*365=1460 -> 365 3; 4*365+1=1461 -> 0 4).
: TN>Jhr&Tage  ( n -- Tage Jahr)
        jflag @  IF  jTN>Jhr&Tage  ELSE  gTN>Jhr&Tage  THEN ;

\ Aus dem Jahrestag (0...365) Monat und Monatstag berechnen.
\ Januar und Februar gelten als 13. und 14. Monat des virtuellen Jahres.
: Tage>Mon&Tag  ( Tage -- Tag Monat)
        31 + 10 * 306 /mod >r  10 / 1+ r> 2 + ;

\ Aus der Tageszahl das echte Datum bilden.
\ Beispiele: 305.5e -> 0 12 31 12 0; 306.5e -> 0 12 1 1 1
: TZ>Date  ( TZ -- Min Std Tag Mon Jhr)
        fdup  1e fmod  1440e f* .5e f+  f>s  60 /mod  ( Min Std)
              f>s TN>Jhr&Tage swap Tage>Mon&Tag  ( Jhr Tag Mon)
              dup 12 > IF   12 - rot 1+  ( Jan & Feb zum neuen Jahr) 
                       ELSE      rot  THEN ;

\ Datum aus TZ berechnen und Variablen laden.
: setDate  ( TZ --)  TZ>Date
        dup Jhr1 ! Jhr2 !   dup Mon1 ! Mon2 !   dup Tag1 ! Tag2 !
        dup Std1 ! Std2 !   dup Min1 ! Min2 ! ;

\ Aus der (ganzzahligen) Tagesnummer Wochentag berechnen und ausgeben.
: DayOfTheWeek  ( n --)
    2 + 7 mod  CASE
                  0  OF  ."  Mo"  ENDOF      1  OF  ."  Di"  ENDOF
                  2  OF  ."  Mi"  ENDOF      3  OF  ."  Do"  ENDOF
                  4  OF  ."  Fr"  ENDOF      5  OF  ."  Sa"  ENDOF
                  6  OF  ."  So"  ENDOF
               ENDCASE ;

\ Ausgabe Datum und Uhrzeit (Format: yyyy-mm-dd hh:mm).
: displayDate  ( min hour day month year --)
    ( Jhr) 4 .#  ." -"  ( Mon) 0 max 2 .#  ." -"  ( Tag) 0 max 2 .#
    space  ( Std) -1 max 2 .# ." :"  ( Min) -1 max 2 .# ;

\ Aus einer Tageszahl das echte Datum errechnen und ausgeben.
: tellDate  ( TZ --)  fdup TZ>Date  displayDate  f>s space DayOfTheWeek ;

\ ------------------------------------------------------------------------
\       T A S T A T U R E I N G A B E
\ ------------------------------------------------------------------------
\ Tastatur-Eingabe für einen Zahlenwert. (Nicht-Zahlen werden abgewiesen.)
: getItem  { W: var-addr D: strg -- }
    BEGIN  cr  strg ( c-addr u) type ." [" var-addr @ 1 .r ." ] "
                           pad 10 accept
           dup IF          pad swap s>number?
                    IF     d>s  var-addr !  true
                    ELSE   2drop            false
                    THEN
               ELSE        0=  ( null string)
               THEN
    UNTIL ;

\ Aktuellen Kalender (gregorianisch oder juianisch) anzeigen.
: tellMode  ( --)
        mode @ 0=  IF  jflag @  IF    ."  (julianisch)"
                                ELSE  ."  (gregorianisch)"  THEN
                                THEN ;

\ Bereitstellung der Datums-Parameter.
: Date1>  ( -- Min Std Tag Mon Jhr)
        Min1 @  Std1 @  Tag1 @  Mon1 @  Jhr1 @  ;

: Date2>  ( -- Min Std Tag Mon Jhr)
        Min2 @  Std2 @  Tag2 @  Mon2 @  Jhr2 @  ;

\ Flag-Variable wird negiert (0 zu -1 bzw. <>0 zu 0).
: toggle  ( a --)  dup @ 0= swap ! ;	

\ Automatische Kalenderwahl: TZ<578051 --> Julianischer Kalender.
\ Auf Tag 1582-10-04 (julianisch) folgt Tag 1582-10-15 (gregorianisch).
\ Eine Eingabe bis 1582-10-14 wird hier noch als julianisch gewertet.
\ ------------------------------------------------------------------------
\ Wochentag:             Di Mi Do | Fr Sa So Mo Di Mi Do Fr Sa So | Mo Di
\ Julianisch:    1582-10-02 03 04 | 05 06 07 08 09 10 11 12 13 14 | 15 16
\ Gregorianisch: 1582-10-12 13 14 | 15 16 17 18 19 20 21 22 23 24 | 25 26
\ Tageszähler (TZ):  578038 39 40 | 41 42 43 44 45 46 47 48 49 50 | 51 52
\ ------------------------------------------------------------------------
: decide  ( date --)  mode @ 0=  ( nur hybrid)
        IF     greg Date>TZ  578041e f<  IF juln THEN
        ELSE   5 drops  THEN ;

\ Erste Eingabe von Datum und Uhrzeit.
: getDate1  ( --)
    cr ."  Eingabe Datum mit Uhrzeit:"
    Jhr1 Jhr$  getItem   Mon1 Mon$  getItem   Tag1 Tag$  getItem
    Std1 Std$  getItem   Min1 Min$  getItem
    cr  ."     Eingegeben: "    Date1> displayDate
                                Date1> decide tellMode
                                Date1> Date>TZ  fdup TZ1 f!
               mode @ 0=  IF          jflag toggle
    cr  ."     Entspricht: "    fdup  TZ>Date displayDate tellMode
                                      jflag toggle
                          THEN
    cr ."      Tageszahl: TZ="  fdup  f.'
                      ."  JD="  fdup  1721119.5e f+  f.'
                                  f>s DayOfTheWeek ;

\ Zweite Eingabe von Datum und Uhrzeit.
: getDate2  ( --)
    cr ."  Eingabe zweites Datum mit Uhrzeit:"
    Jhr2 Jhr$  getItem   Mon2 Mon$  getItem   Tag2 Tag$  getItem
    Std2 Std$  getItem   Min2 Min$  getItem
    cr  ."     Eingegeben: "    Date2> displayDate
                                Date2> decide tellMode
                                Date2> Date>TZ  fdup TZ2 f!
               mode @ 0=  IF          jflag toggle
    cr  ."     Entspricht: "    fdup  TZ>Date displayDate tellMode
                                      jflag toggle
                          THEN
    cr ."      Tageszahl: TZ="  fdup  f.'
                      ."  JD="  fdup  1721119.5e f+  f.'
		                      f>s DayOfTheWeek ;

\ ------------------------------------------------------------------------
\       T A G E   B Z W .  S O N N E N J A H R E   A D D I E R E N
\ ------------------------------------------------------------------------
\ Eingabe eines Offsets in Tagen, Ausgabe des resultierenden Datums.
: newDate  ( --)  offs s"          Tage = "  getItem
                  TZ1 f@  offs @ s>f f+
                  cr ."    Neues Datum: " tellDate cr ;		  

\ Aus Vielfachen von Sonnenjahren eine Datentabelle erzeugen. 
: makeTable  ( --)           trops s"   Sonnenjahre = " getItem
    trops @ abs stepWid !  stepWid s"  Schrittgröße = " getItem
    stepWid @  trops @  abs min  abs 1 max  stepWid !
    trops @  dup 0>=  ( tropjahre f)
            IF    stepWid @ /up 1+ 0        \ vorwärts
            ELSE  stepWid @ /   1 swap      \ rückwärts
            THEN  cr
        DO      i stepWid @ *  TZ1 f@
	          i stepWid @ *  s>f ftrop f* f+
                14 .r  2 spaces  tellDate  cr
        LOOP  ;

\ ------------------------------------------------------------------------
\       Z E I T D I F F E R E N Z
\ ------------------------------------------------------------------------
\ Die Datumsdifferenz in Minuten berechnen.
: MinDiff  ( -- n)
    Tag2 @  Mon2 @  Jhr2 @  Jhr&Mon&Tag>TN  1440 *
                          Std2 @  60 * +  Min2 @ +
    Tag1 @  Mon1 @  Jhr1 @  Jhr&Mon&Tag>TN  1440 *
                          Std1 @  60 * +  Min1 @ + - abs ;

\ Aus Datumsdifferenz Tage, Stunden und Minuten berechnen.
: makeDiff  ( -- Min Std Tage) 
        getDate2  MinDiff  1440 /mod >r  60 /mod r> ;

\ Aus Datumsdifferenz die Anzahl Sonnenjahre berechnen.
: yDiff  ( --)  TZ2 f@  TZ1 f@  f- fabs ftrop f/ ; 

\ Aus Datumsdifferenz Tage, Stunden, Minuten und Sonnenjahre ausgeben.
: tellDiff  ( --)  makeDiff  cr ."      Differenz: "
        . ." Tag[e] "  . ." Stunde[n] "  . ." Minute[n] "  cr
             yDiff 16 spaces  ." (" f.' ." Sonnenjahre) "  cr ;

\ Korrektur des aktuellen Datums für den Julianischen Kalender.
: actual  ( --)
    jflag  IF     greg Date1> Date>TZ  fdup TZ1 f!  juln setDate
           THEN ;


\ ------------------------------------------------------------------------
\       H A U P T S C H L E I F E
\ ------------------------------------------------------------------------
: mainloop  ( --)
        [char] a  wahl !      \ Voreinstellung des Modus
  BEGIN
    getDate1
 cr cr 12 spaces s" a" type" ."  Eingabe eines zweiten Datums"
    cr 12 spaces s" b" type" ."  Eingabe einer Anzahl Tage"
    cr 12 spaces s" c" type" ."  Eingabe einer Anzahl Sonnenjahre"
    cr 12 spaces s" q" type" ."  quit to prompt"

                     wahl @  temp !
    cr ."    Wahl [" wahl @ emit ." ]: " key dup emit cr
    dup 13 =  IF  drop wahl @  ELSE  dup wahl !  THEN
        CASE  [char] a  OF  tellDiff       ENDOF
              [char] b  OF  newDate        ENDOF
              [char] c  OF  makeTable      ENDOF
              [char] q  OF  ."   ok" quit  ENDOF
                     temp @  wahl ! 
        ENDCASE
	
    cr ." --------------- " .s f.s ." --------------- " cr  7 emit ( beep)
  AGAIN ;              ( Stacks prüfen )

\ ------------------------------------------------------------------------
\       P R O G R A M M S T A R T
\ ------------------------------------------------------------------------
: hybrid     ( --)  0 mode !
        cr  16 spaces  ." Hybrider Kalender gewählt" ;
: julian     ( --)  1 mode !  juln  actual
        cr  16 spaces  ." Julianischer Kalender gewählt" ;
: gregorian  ( --)  2 mode !  greg
        cr  16 spaces  ." Gregorianischer Kalender gewählt" ;

: intro  ( --)
 cr cr  ."  Datum & Uhrzeit bei Programmstart: "
        Min1 @  Std1 @  Tag1 @  Mon1 @  Jhr1 @  displayDate

\ Kalenderwahl: julianisch, gregorianisch, hybrid.
 cr cr 12 spaces s" g" type" ."  Gregorianischer Kalender"
    cr 12 spaces s" j" type" ."  Julianischer Kalender"
    cr 12 spaces s" h" type" ."  Hybrid: Julianisch bis 1582-10-14"
    cr 12 spaces s" q" type" ."  quit to prompt"
        [char] g  wahl !
    BEGIN         wahl @  func !
        cr ."    Wahl [" wahl @ emit ." ]: " key dup emit
        dup 13 =  IF  drop wahl @  ELSE  dup  wahl !  THEN
            CASE  [char] j  OF  julian     -1 temp !  ENDOF
                  [char] g  OF  gregorian  -1 temp !  ENDOF
                  [char] h  OF  hybrid     -1 temp !  ENDOF
                  [char] q  OF  ."   ok" quit         ENDOF
                  func @  wahl ! 
	          0 temp ! 
            ENDCASE  temp @
    UNTIL
cr ;

\ ------------------------------------------------------------------------
        12 set-precision  ( statt 15 oder mehr)
        intro
        mainloop
	
\ finis