====== 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