1 ! Copyright (C) 2007 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs kernel math math.order math.vectors
4 namespaces make quotations sequences sequences.lib
5 sequences.private strings unicode.case ;
9 : roman-digits ( -- seq )
10 { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
12 : roman-values ( -- seq )
13 { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
15 ERROR: roman-range-error n ;
17 : roman-range-check ( n -- )
18 dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
20 : roman<= ( ch1 ch2 -- ? )
21 [ 1string roman-digits index ] bi@ >= ;
24 1string roman-digits index roman-values nth ;
27 roman-values roman-digits [
28 >r /mod swap r> <repetition> concat %
31 : (roman>) ( seq -- n )
32 dup [ roman>n ] map swap all-eq? [
40 dup roman-range-check [
44 : >ROMAN ( n -- str ) >roman >upper ;
47 >lower [ roman<= ] monotonic-split [
52 : 2roman> ( str1 str2 -- m n )
55 : binary-roman-op ( str1 str2 quot -- str3 )
56 >r 2roman> r> call >roman ; inline
59 : roman+ ( str1 str2 -- str3 )
60 [ + ] binary-roman-op ;
62 : roman- ( str1 str2 -- str3 )
63 [ - ] binary-roman-op ;
65 : roman* ( str1 str2 -- str3 )
66 [ * ] binary-roman-op ;
68 : roman/i ( str1 str2 -- str3 )
69 [ /i ] binary-roman-op ;
71 : roman/mod ( str1 str2 -- str3 str4 )
72 [ /mod ] binary-roman-op >r >roman r> ;