\ roman 98.8.12 7:22 pm NAB
needs toolkit
needs core-ext
needs graphics
decimal 127 array romantable
: set ( n <c> -- ) char romantable ! ;
\ uppercase symbols return values
\ lowercase returns symbol*10
1 set I char X set i
10 set X char C set x
100 set C char M set c
1000 set M char ? set m
5 set V char L set v
50 set L char D set l
500 set D char ? set d
: symbol>value ( char -- value )
>upper romantable @ ;
: symbol10x ( sym -- sym*10 )
>lower romantable @ ;
: rn ( <digit> <string> -- )
here set bl parse place, ;
\ 0..9 returns Roman string
\ note: next line must end after the 0
rn 0
rn 1 I rn 2 II rn 3 III rn 4 IV
rn 5 V rn 6 VI rn 7 VII rn 8 VIII rn 9 IX
: digit>roman ( c -- addr )
romantable @ ;
\ Decode a Roman number string:
( Malformed strings are accepted )
: roman> ( addr u -- n )
0 0 2swap ( n prev addr u )
bounds ?do ( n prev )
i c@ symbol>value ( n prev d )
\ If prev is 1/10th or 1/5th, adjust d:
over 10 * 2dup = >r
2/ over = r> or ( n prev d flag )
rot 2* and - ( n d-2*prev? )
dup under+ ( n+d prev )
loop drop ( n ) ;
\ Multiply a Roman number by 10:
( String is modified in place )
: roman10x ( addr u -- )
bounds ?do
i c@ symbol10x i c!
loop ;
\ max length = 15 chars,
\ 3888 = MMMDCCCLXXXVIII
create romanbuf 16 allot
\ Compute Roman representation:
( u1 must be [0..3999]--not checked )
( Output is in fixed buffer )
: >roman ( u1 -- addr u2 )
base @ >r decimal 0 <# #s #>
r> base !
romanbuf 0 2swap bounds ?do
2dup roman10x
i c@ digit>roman count append
loop ;
\ Display type with overscore:
: bartype ( u -- )
cursor-position
2swap tuck type
cursor-position rot if 2 - line
else 2drop 2drop then ;
: split-roman ( u -- nnn 1000's )
dup 0 1000 um/mod ( n r q )
dup 3 > if
rot drop
else 2drop 0 then ;
: romantype ( +n -- )
split-roman
>roman bartype
>roman type ;