\ roman.fs - Roman numeral and date words \ \ Copyright 2018 David Meyer +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 ;