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