From 19c3feef313fd5fa85f144048a9984657a9bd0e7 Mon Sep 17 00:00:00 2001 From: David Meyer Date: Thu, 10 Feb 2022 11:03:24 +0900 Subject: [PATCH] Create wareki-datadriven.html --- wareki-datadriven.html | 242 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 242 insertions(+) create mode 100644 wareki-datadriven.html diff --git a/wareki-datadriven.html b/wareki-datadriven.html new file mode 100644 index 0000000..df15acd --- /dev/null +++ b/wareki-datadriven.html @@ -0,0 +1,242 @@ + + + + WAREKI.FS Data-Driven Refactor + + + + + + + +

WAREKI.FS Data-Driven Refactor

+ + + + + + + + +
+\ wareki.fs - Display WAREKI and Anno Domini corresponding years
+\ +JMJ 2020 David Meyer 
+\ 2020/3/31 Add Reiwa era
+
+\ help-wareki - Display module help
+: help-wareki ( -- )
+    cr ." WAREKI" cr
+    ." Display Japanese era years corresponding to A.D. years and" cr
+    ." vice versa." cr
+    ." HEISEI ( u -- ) Display A.D. year corresponding to Heisei era year." cr
+    ." MEIJI ( u -- ) Display A.D. year corresponding to Meiji era year." cr
+    ." NENGO ( u -- ) Display Japanese year in Meiji, Taishou, Shouwa," cr
+    ."                Heisei, or Reiwa eras corresponding to A.D. year." cr
+    ." REIWA ( u -- ) Display A.D. year corresponding to Reiwa era year." cr
+    ." SHOWA ( u -- ) Display A.D. year corresponding to Shouwa era year." cr
+    ." TAISHO ( u -- ) Display A.D. year corresponding to Taishou era year." cr
+;
+
+\ nengo - Display NENGO for A.D. (Meiji, Taishou, Shouwa,
+\         Heisei, Reiwa eras only)
+: nengo ( u -- )
+    dup 1868 < if
+	." ERROR: Year precedes MEIJI era " drop
+    else
+	dup 1868 = if
+	    ." MEIJI GANNEN (Sep 8 -) " drop
+	else
+	    dup 1912 < if
+		." MEIJI " 1867 - .
+	    else
+		dup 1912 = if
+		    ." MEIJI 45/TAISHO GANNEN (Jul 30-) " drop
+		else
+		    dup 1926 < if
+			." TAISHO " 1911 - .
+		    else
+			dup 1926 = if
+			    ." TAISHO 15/SHOWA GANNEN (Dec 25-) " drop
+			else
+			    dup 1989 < if
+				." SHOWA " 1925 - .
+			    else
+				dup 1989 = if
+				    ." SHOWA 64/HEISEI GANNEN (Jan 8-) " drop
+				else
+                                    dup 2019 < if
+                                        ." HEISEI " 1988 - .
+                                    else
+                                        dup 2019 = if
+                                            ." HEISEI 31/REIWA GANNEN (May 1-) " drop                        
+                                        else
+                                            ." REIWA " 2018 - .
+                                        then
+                                    then
+				then
+			    then
+			then
+		    then
+		then
+	    then
+	then
+    then
+;
+
+\ meiji - Display A.D. for Meiji era NENGO.
+: meiji ( u -- )
+    dup 0= if
+	." ERROR: NENGO < 1 " drop
+    else
+	dup 45 > if
+	    ." ERROR: NENGO > 45 " drop
+	else
+	    ." AD " 1867 + .
+	then
+    then
+;
+
+\ taisho - Display A.D. for Taishou era NENGO.
+: taisho ( u -- )
+    dup 0= if
+	." ERROR: NENGO < 1 " drop
+    else
+	dup 15 > if
+	    ." ERROR: NENGO > 15 " drop
+	else
+	    ." AD " 1911 + .
+	then
+    then
+;
+
+\ showa - Display A.D. for Shouwa era NENGO.
+: showa ( u -- )
+    dup 0= if
+	." ERROR: NENGO < 1 " drop
+    else
+	dup 64 > if
+	    ." ERROR: NENGO > 64 " drop
+	else
+	    ." AD " 1925 + .
+	then
+    then
+;
+
+\ heisei - Display A.D. for Heisei era NENGO.
+: heisei ( u -- )
+    dup 0= if
+	." ERROR: NENGO < 1 " drop
+    else
+	." AD " 1988 + .
+    then
+;
+
+\ reiwa - Display A.D. for Reiwa era NENGO.
+: reiwa ( u -- )
+    dup 0= if
+        ." ERROR: NENGO < 1 " drop
+    else
+        ." AD " 2018 + .
+    then
+;
+
+cr ." Type 'help-wareki' for help" 
+		
+\ wareki.fs - Display WAREKI and Anno Domini corresponding years
+\ +JMJ 2022 David Meyer 
+\ 2020/3/31 Add Reiwa era
+\ 2022/2/9 Refactor and convert to data-driven
+
+\ help-wareki - Display module help
+: help-wareki ( -- )
+    cr ." WAREKI" cr
+    ." Display Japanese era years corresponding to A.D. years and" cr
+    ." vice versa." cr
+    ." HEISEI ( u -- ) Display A.D. year corresponding to Heisei era year." cr
+    ." MEIJI ( u -- ) Display A.D. year corresponding to Meiji era year." cr
+    ." NENGO ( u -- ) Display Japanese year in Meiji, Taishou, Shouwa," cr
+    ."                Heisei, or Reiwa eras corresponding to A.D. year." cr
+    ." REIWA ( u -- ) Display A.D. year corresponding to Reiwa era year." cr
+    ." SHOWA ( u -- ) Display A.D. year corresponding to Shouwa era year." cr
+    ." TAISHO ( u -- ) Display A.D. year corresponding to Taishou era year." cr
+;
+
+0 constant ERAM  \ MEIJI era index
+1 constant ERAT  \ TAISHO era index
+2 constant ERAS  \ SHOWA era index
+3 constant ERAH  \ HEISEI era index
+4 constant ERAR  \ REIWA era index
+
+create ERALFGY  \ Era last full Gregorian year (M/T/S/H/R)
+1867 , 1911 , 1925 , 1988 , 2018 ,
+create ERALYR  \ Era last year (M/T/S/H)
+45 , 15 , 64 , 31 ,
+
+create ERANAME  \ Era name length/string (M/T/S/H/R)
+5 , 77 c, 69 c, 73 c, 74 c, 73 c, 0 c,   \ "MEIJI"
+6 , 84 c, 65 c, 73 c, 83 c, 72 c, 79 c,  \ "TAISHO"
+5 , 83 c, 72 c, 79 c, 87 c, 65 c, 0 c,   \ "SHOWA"
+6 , 72 c, 69 c, 73 c, 83 c, 69 c, 73 c,  \ "HEISEI"
+5 , 82 c, 69 c, 73 c, 87 c, 65 c, 0 c,   \ "REIWA"
+
+create ERADATE  \ Era start date length/string (M/T/S/H/R)
+5 , 83 c, 101 c, 112 c, 32 c, 56 c, 0 c,   \ "Sep 8"
+6 , 74 c, 117 c, 108 c, 32 c, 51 c, 48 c,  \ "Jul 30"
+6 , 68 c, 101 c, 99 c, 32 c, 50 c, 53 c,   \ "Dec 25"
+5 , 74 c, 97 c, 110 c, 32 c, 56 c, 0 c,    \ "Jan 8"
+5 , 77 c, 97 c, 121 c, 32 c, 49 c, 0 c,    \ "May 1"
+
+: []@ ( uidx a-base -- a-addr ) swap cells + @ ;
+
+: []$ ( uidx a-base -- c-addr ulen )
+    swap 1 cells 6 chars + * + dup 1 cells + swap @
+;
+
+: ng>gy ( ungy uera -- ugy ) ERALFGY []@ + ;
+
+: gy>ng ( ugy -- ungy uera )
+    ERAR begin
+	dup ERALFGY []@ rot dup rot <= while swap 1-
+    repeat
+    over ERALFGY []@ - swap
+;
+
+: prera ( uera -- ) ERANAME []$ type space ;
+
+: preradt ( uera -- ) ERADATE []$ type ;
+
+: prgy ( ug -- ) ." AD " . ;
+
+: ngyok? ( uera ungy -- f )
+    dup 0< if
+	2drop false else
+	swap ERALYR []@ 1+ > if false else true then
+    then
+;
+
+: nengo ( ugy -- )
+    dup ERAM ERALFGY []@ <= if
+	drop ." Year prior to MEIJI era unsupported " else
+	gy>ng over 1 = if
+	    dup 1- dup prera ERALYR []@ . ." / "
+	    dup prera ." GANNEN (" preradt ." -) " drop else
+	    prera . then
+	then
+;
+
+: cvtng ( ungy uera -- )
+    2dup swap ngyok? if
+	ng>gy prgy else
+	2drop ." Invalid NENGO year " then
+;
+
+: meiji ( ungy -- ) ERAM cvtng ;
+: taisho ( ungy -- ) ERAT cvtng ;
+: showa ( ungy -- ) ERAS cvtng ;
+: heisei ( ungy -- ) ERAH cvtng ;
+: reiwa ( ungy -- ) ERAR cvtng ;
+
+cr ." Type 'help-wareki' for help" 
+