\ 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 ;