forth/roman.fs

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
;