1 ! Copyright (C) 2007 Doug Coleman.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators.smart effects.parser
4 generalizations grouping kernel lexer math math.order
5 parser quotations sequences splitting.monotonic strings unicode
11 CONSTANT: roman-digits
12 { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
14 CONSTANT: roman-values
15 { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
17 ERROR: roman-range-error n ;
19 : roman-range-check ( n -- n )
20 dup 1 10000 between? [ roman-range-error ] unless ;
22 : roman-digit-index ( ch -- n )
23 1string roman-digits index ; inline
25 : roman-digit>= ( ch1 ch2 -- ? )
26 [ roman-digit-index ] bi@ >= ;
28 : roman-digit-value ( ch -- n )
29 roman-digit-index roman-values nth ;
31 : roman-value ( seq -- n )
32 [ [ roman-digit-value ] map ] [ all-eq? ] bi
33 [ sum ] [ first2 swap - ] if ;
39 roman-values roman-digits [
40 [ /mod swap ] dip <repetition> concat
41 ] 2map "" concat-as nip ;
43 : >ROMAN ( n -- str ) >roman >upper ;
46 >lower [ roman-digit>= ] monotonic-split
47 [ roman-value ] map-sum ;
51 MACRO: binary-roman-op ( quot -- quot' )
52 [ inputs ] [ ] [ outputs ] tri
53 '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
60 scan-word [ name>> "roman" prepend create-word-in ] keep
61 1quotation '[ _ binary-roman-op ]
62 scan-effect define-declared ;
66 ROMAN-OP: + ( x y -- z )
67 ROMAN-OP: - ( x y -- z )
68 ROMAN-OP: * ( x y -- z )
69 ROMAN-OP: /i ( x y -- z )
70 ROMAN-OP: /mod ( x y -- z w )
72 SYNTAX: ROMAN: scan-token roman> suffix! ;