331 lines
8.0 KiB
Forth
Executable File
331 lines
8.0 KiB
Forth
Executable File
\ roman.fs - Roman numeral and date words
|
|
\
|
|
\ Copyright 2018 David Meyer <papa@sdf.org> +JMJ
|
|
\
|
|
\ Licensed under the Apache License, Version 2.0 (the "License");
|
|
\ you may not use this file except in compliance with the License.
|
|
\ You may obtain a copy of the License at
|
|
\
|
|
\ http://www.apache.org/licenses/LICENSE-2.0
|
|
\
|
|
\ Unless required by applicable law or agreed to in writing, software
|
|
\ distributed under the License is distributed on an "AS IS" BASIS,
|
|
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
\ See the License for the specific language governing permissions and
|
|
\ limitations under the License.
|
|
\
|
|
|
|
include mymath.fs
|
|
|
|
0 constant KALENDS
|
|
1 constant NONES
|
|
2 constant IDES
|
|
3 constant NEXTKAL
|
|
|
|
create NONESDAY 5 , 5 , 7 , 5 , 7 , 5 , 7 , 5 , 5 , 7 , 5 , 5 ,
|
|
create IDESDAY 13 , 13 , 15 , 13 , 15 , 13 , 15 , 13 , 13 , 15 , 13 , 13 ,
|
|
create EOMDAY 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ,
|
|
|
|
\ numeral9 - superstring and accessor/printer for roman numerals "9";
|
|
\ u = power of 10 [0, 2]
|
|
: "numeral9" c" IXXCCM" ;
|
|
: numeral9 ( u -- ) 2 * "numeral9" 1+ + 2 type ;
|
|
|
|
\ numeral5 - superstring and accessor/printer for roman numerals "5";
|
|
\ u = power of 10 [0, 2]
|
|
: "numeral5" c" VLD" ;
|
|
: numeral5 ( u -- ) "numeral5" 1+ + 1 type ;
|
|
|
|
\ numeral4 - superstring and accessor/printer for roman numerals "4";
|
|
\ u = power of 10 [0, 2]
|
|
: "numeral4" c" IVXLCD" ;
|
|
: numeral4 ( u -- ) 2 * "numeral4" 1+ + 2 type ;
|
|
|
|
\ numeral1 - superstring and accessor/printer for roman numerals "1";
|
|
\ u = power of 10 [0, 3]
|
|
: "numeral1" c" IXCM" ;
|
|
: numeral1 ( u -- ) "numeral1" 1+ + 1 type ;
|
|
|
|
\ pvnumeral - type roman numeral for given power of 10 [0, 3] and place value
|
|
\ [1, 9]
|
|
: pvnumeral ( upow uval -- )
|
|
dup 9 = if
|
|
drop numeral9
|
|
else
|
|
dup 4 = if
|
|
drop numeral4
|
|
else
|
|
dup 4 > if
|
|
over numeral5
|
|
5 -
|
|
then
|
|
0 u+do dup numeral1 loop
|
|
drop
|
|
then
|
|
then
|
|
;
|
|
|
|
\ romnumeral - print Roman numeral for given number [1, 3999]
|
|
: romnumeral ( u -- )
|
|
-1 3 -do
|
|
10 i u** /mod ( u%10^i u/10^i )
|
|
dup if
|
|
i swap pvnumeral
|
|
else drop
|
|
then
|
|
1 -loop
|
|
drop
|
|
;
|
|
\ range check
|
|
: romnumeral ( u -- )
|
|
dup 0>
|
|
over 4000 <
|
|
and if
|
|
romnumeral
|
|
else
|
|
." ERROR romnumeral: argument out of range: " .
|
|
then
|
|
;
|
|
|
|
\ bisyear - Determine if A.D. year is bissextile (leap) year
|
|
: bisyear ( uyear -- fbissextile )
|
|
dup 4 mod 0= swap
|
|
dup 100 mod 0<> swap
|
|
400 mod 0=
|
|
or and
|
|
;
|
|
|
|
\ knidays - Determine Kalends/Nones/Ides and before-day count for date
|
|
: knidays ( bis m d -- ukni uantediem )
|
|
dup 1 = if
|
|
nip nip KALENDS
|
|
else 2dup swap 1- cells NONESDAY + @ 2dup <= if ( bis m d d nd )
|
|
swap - 1+ nip nip nip NONES
|
|
else 2drop 2dup swap 1- cells IDESDAY + @ 2dup <= if ( bis m d d id )
|
|
swap - 1+ nip nip nip IDES
|
|
else
|
|
2drop over 1- cells EOMDAY + @ ( bis m d eom )
|
|
swap - 2 +
|
|
swap 2 = rot and if 1+ then
|
|
NEXTKAL
|
|
then then then
|
|
swap
|
|
;
|
|
|
|
\ monthnones - Nones day-of-month
|
|
: monthnones ( umonth -- unones )
|
|
1- cells NONESDAY + @ ;
|
|
|
|
\ monthides - Ides day-of-month
|
|
: monthides ( umonth -- uides )
|
|
1- cells IDESDAY + @ ;
|
|
|
|
\ monthend - Last day of month
|
|
: monthend ( umonth -- ueom )
|
|
1- cells EOMDAY + @ ;
|
|
|
|
\ mdkni - Closest Kalends/Nones/Ides on or following date
|
|
: mdkni ( umonth uday -- ukni )
|
|
dup 1 = if
|
|
2drop KALENDS
|
|
else 2dup swap monthnones <= if
|
|
2drop NONES
|
|
else over monthides <= if
|
|
drop IDES
|
|
else
|
|
drop NEXTKAL
|
|
then then then
|
|
;
|
|
|
|
\ antediem - Roman day count before Kalends/Nones/Ides
|
|
: antediem ( fbis umonth uday ukni -- uad )
|
|
dup KALENDS = if \ Kalends (a.d. always 1)
|
|
2drop 2drop 1
|
|
else dup NONES = if \ Nones
|
|
drop swap monthnones swap - 1+ nip
|
|
else IDES = if \ Ides
|
|
swap monthides swap - 1+ nip
|
|
else \ Next month Kalends
|
|
over monthend swap - 2 +
|
|
swap 2 = if \ February
|
|
swap if 1+ then \ bissextile year
|
|
else nip
|
|
then
|
|
then then then
|
|
;
|
|
|
|
\ kniablat - Print Kalends/Nones/Ides ablative case
|
|
: kniablat ( ukni -- )
|
|
dup KALENDS = if
|
|
." Kalendis "
|
|
else dup NONES = if
|
|
." Nonis "
|
|
else dup IDES = if
|
|
." Idebus "
|
|
else ." Kalendis " \ Kalends of next month
|
|
then then then
|
|
drop
|
|
;
|
|
|
|
\ kniaccus - Print Kalends/Nones/Ides accusative case
|
|
: kniaccus ( ukni -- )
|
|
dup KALENDS = if
|
|
." Kalendas "
|
|
else dup NONES = if
|
|
." Nonas "
|
|
else dup IDES = if
|
|
." Idus "
|
|
else ." Kalendas " \ Kalends of next month
|
|
then then then
|
|
drop
|
|
;
|
|
|
|
\ monablat - Print Latin month name ablative case
|
|
: monablat ( umonth -- )
|
|
dup 1 = if
|
|
." Januariis "
|
|
else dup 2 = if
|
|
." Februariis "
|
|
else dup 3 = if
|
|
." Martiis "
|
|
else dup 4 = if
|
|
." Aprilibus "
|
|
else dup 5 = if
|
|
." Maiis "
|
|
else dup 6 = if
|
|
." Juniis "
|
|
else dup 7 = if
|
|
." Juliis "
|
|
else dup 8 = if
|
|
." Augustis "
|
|
else dup 9 = if
|
|
." Septembribus "
|
|
else dup 10 = if
|
|
." Octobribus "
|
|
else dup 11 = if
|
|
." Novembribus "
|
|
else dup 12 = if
|
|
." Decembribus "
|
|
else
|
|
." Januariis "
|
|
then then then then then then then then then then then then
|
|
drop
|
|
;
|
|
|
|
\ monaccus - Print Latin month name accusative case
|
|
: monaccus ( umonth -- )
|
|
dup 1 = if
|
|
." Januarias "
|
|
else dup 2 = if
|
|
." Februarias "
|
|
else dup 3 = if
|
|
." Martias "
|
|
else dup 4 = if
|
|
." Apriles "
|
|
else dup 5 = if
|
|
." Maias "
|
|
else dup 6 = if
|
|
." Junias "
|
|
else dup 7 = if
|
|
." Julias "
|
|
else dup 8 = if
|
|
." Augustas "
|
|
else dup 9 = if
|
|
." Septembres "
|
|
else dup 10 = if
|
|
." Octobres "
|
|
else dup 11 = if
|
|
." Novembres "
|
|
else dup 12 = if
|
|
." Decembres "
|
|
else
|
|
." Januarias "
|
|
then then then then then then then then then then then then
|
|
drop
|
|
;
|
|
|
|
\ ordaccus - Print Latin ordinal number accusative case [1, 20]
|
|
: ordaccus ( unum -- )
|
|
dup 1 = if ." primum "
|
|
else dup 2 = if ." secundum "
|
|
else dup 3 = if ." tertium "
|
|
else dup 4 = if ." quartum "
|
|
else dup 5 = if ." quintum "
|
|
else dup 6 = if ." sextus "
|
|
else dup 7 = if ." septimum "
|
|
else dup 8 = if ." octavum "
|
|
else dup 9 = if ." nonum "
|
|
else dup 10 = if ." decimum "
|
|
else dup 11 = if ." undecimum "
|
|
else dup 12 = if ." duodecimum "
|
|
else dup 13 = if ." tertium decimum "
|
|
else dup 14 = if ." quartum decimum "
|
|
else dup 15 = if ." quintum decimum "
|
|
else dup 16 = if ." sextum decimum "
|
|
else dup 17 = if ." septimum decimum "
|
|
else dup 18 = if ." duodevicensimum "
|
|
else dup 19 = if ." undevicensimum "
|
|
else dup 20 = if ." vicensimum "
|
|
else ." ERROR: ordaccus argument out of range " dup .
|
|
then then then then then then then then then then then then then then then then then then then then
|
|
drop
|
|
;
|
|
|
|
\ diemense - Print day/month portion of Roman date
|
|
: diemense ( fbis umonth ukni uad -- )
|
|
dup 1 = if
|
|
drop dup kniablat
|
|
NEXTKAL = if 1+ then
|
|
monablat drop
|
|
else dup 2 = if
|
|
." pridie "
|
|
drop dup kniaccus
|
|
NEXTKAL = if 1+ then
|
|
monaccus drop
|
|
else
|
|
." ante diem "
|
|
2over 2 = and
|
|
over 6 > and
|
|
rot dup >r NEXTKAL = and if ( bis m ad ) ( R: kni )
|
|
dup 7 = if ." bis " then
|
|
1-
|
|
then
|
|
ordaccus ( bis m ) ( R: kni )
|
|
r> dup NEXTKAL = if ( bis m kni )
|
|
swap 1+ swap
|
|
then
|
|
kniaccus
|
|
monaccus
|
|
drop
|
|
then then
|
|
;
|
|
|
|
\ anno - Print year for Roman date format
|
|
: anno ( uyear -- )
|
|
." anno Domini "
|
|
romnumeral
|
|
;
|
|
|
|
\ romdate - print date in Roman format
|
|
: romdate ( uday umonth uyear -- )
|
|
dup bisyear ( d m y bis )
|
|
dup >r ( R: bis )
|
|
2swap dup >r ( y bis d m ) ( R: bis m )
|
|
swap 2dup mdkni ( y bis m d kni )
|
|
dup >r antediem ( y ad ) ( R: bis m kni )
|
|
r> swap r> r> swap 2swap ( y bis m kni ad )
|
|
diemense ( y )
|
|
anno
|
|
;
|
|
|
|
\ hodie - Print current date in Roman format
|
|
: hodie ( -- )
|
|
cr
|
|
time&date ( sec min hour day month year )
|
|
romdate
|
|
drop drop drop
|
|
;
|
|
|
|
|
|
|