\ Romeinse cijfers - an 6-III-2025

decimal
create LIJST decimal    1000 , 10 , 5 , 1 , 100 , 500 , 50 ,
: CH>X ( ch -- n )      upc 87 mod 7 mod cells lijst + @ ;

0 value &               \ voor KEY en voor de leesbaarheid

: R>A ( <keys> -- )   0.                \ subtotaal en laatste-KEYwaarde
    begin  KEY to &   bl & <            \ geen afsluiter?
    while  & emit
           & ch>x 2dup >r > ?negate + r>
    repeat + space . ;

: ROME ( -- ) begin begin r>a
    & bl    = while space repeat
    & hx 0D = while cr    repeat ;

Negeer ongeldige tekens, voor 32bits forth

decimal create LIJST decimal 1000 , 10 , 5 , 1 , 100 , 500 , 50 , : CH>X ( ch -- n ) upc 87 mod 7 mod cells lijst + @ ; 0 value & \ voor KEY en voor de leesbaarheid : GELDIG? ( ch -- geldig? ) ch A max ch z min 31 and 1 swap lshift hx 1403218 and ; ( XVMLIDC ) : R>A ( <keys> -- ) 0. \ subtotaal en laatste-KEYwaarde begin KEY to & bl & < \ geen afsluiter? while & geldig? if & emit & ch>x 2dup >r > ?negate + r> then repeat + space . ; : ROME ( -- ) begin begin r>a & bl = while space repeat & hx 0D = while cr repeat ;

\ Test voor de laatst gedefinieerde CH>X

: test ( -- ) s" MDCLXVI" 2dup type ." ---> " for count s" ' CH>X" evaluate execute . next drop ;

\ Negen CH>X versies

\ Met IF's

\ 1 \ cellen : CH>X ( ch -- n ) upc \ msp 55, arm 83, risc 44 dup ch I = if drop 1 else dup ch V = if drop 5 else dup ch X = if drop 10 else dup ch L = if drop 50 else dup ch C = if drop 100 else dup ch D = if drop 500 else ch M = if 1000 else 0 then then then then then then then ; test
\ 2 : CH>X ( ch -- n ) upc to & \ msp 52, arm 73, risc 39 & ch I = if 1 exit then & ch V = if 5 exit then & ch X = if 10 exit then & ch L = if 50 exit then & ch C = if 100 exit then & ch D = if 500 exit then & ch M = if 1000 exit then 0 ; test

\ Alfabetisch met IF's, CDI L MXV

\ 3 : CH>X ( ch -- n ) upc \ msp 40, arm 55, risc 29 dup ch L - s>d \ ch ch-L neg? if drop ch D - s>d ( CDI ) if 100 nip exit then if 1 exit then 500 exit then if ch V - s>d ( MVX ) if 1000 nip exit then if 10 exit then 5 exit then 50 nip ; ( L ) test

\ Met 2 lijsten en uitgeschreven SCAN

\ 4 create CH>X ( ch -- n ) \ msp 36, arm 34, risc 25 1 , 5 , 10 , 50 , 100 , 500 , 1000 , does> ( ch lijst ) swap upc >r s" MDCLXVI" bounds begin count r@ <> while 2dup < until then rdrop - cells + @ ; test

\ Idem met de noForth SCAN

\ 5 create CH>X ( ch -- n ) \ Q \ msp 30, arm 26, risc 21 5000 , 1 , 5 , 10 , 50 , 100 , 500 , 1000 , does> ( ch lijst ) swap upc >r s" MDCLXVI" bounds r> scan - cells + @ ; test

\ Rekenend, zonder IF's

\ 6 create CH>X ( ch -- n ) \ msp 25, arm 26, risc 19 10 , 5 , 1 , 100 , 500 , 50 , 1000 , \ XVICDLM does> swap 31 and 24 mod 7 mod \ 0123456 index cells + @ ; test
\ 7 create CH>X ( ch -- n ) \ msp 25 , arm 25, risc 19 50 , 1000 , 5 , 1 , 10 , 100 , 500 , 0 , \ LMVIXCD? does> swap upc 38 mod 7 and \ 01234567 index cells + @ ; test 
\ 8

create CH>X ( ch -- n )                              \ msp 24, arm 24, risc 18
    1000 , 10 , 5 , 1 , 100 , 500 , 50 ,            \ MXVICDL
    does> swap upc 87 mod 7 mod                     \ 0123456 index
    cells + @ ;
test

\ Het kan nog erger (past niet in 16bits forth)

\ 9 : CH>X ( ch -- n ) \ msp --, arm 37, risc 21 31 and 24 mod 7 mod 975905 swap 3 * rshift dup 4 and 1+ swap 3 and for 10 * next ; test
  \ <><>