Fixes #2966

[factor.git] / basis / roman / roman.factor

diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor
index 24713545b136a92064b058569f5719cae4c05716..edff040dacf15da26baae8b9f84bc7b8a0c80b1a 100644 (file)
--- a/basis/roman/roman.factor
+++ b/basis/roman/roman.factor
@@ -1,77 +1,72 @@
 ! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors
-namespaces make quotations sequences splitting.monotonic
-sequences.private strings unicode.case lexer parser
-grouping ;
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.smart effects.parser
+generalizations grouping kernel lexer math math.order
+parser quotations sequences splitting.monotonic strings unicode
+words ;
 IN: roman
 
 <PRIVATE
 
-: roman-digits ( -- seq )
-    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
+CONSTANT: roman-digits
+    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
 
-: roman-values ( -- seq )
-    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
+CONSTANT: roman-values
+    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
 
 ERROR: roman-range-error n ;
 
-: roman-range-check ( n -- )
-    dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
+: roman-range-check ( n -- n )
+    dup 1 10000 between? [ roman-range-error ] unless ;
 
-: roman<= ( ch1 ch2 -- ? )
-    [ 1string roman-digits index ] bi@ >= ;
+: roman-digit-index ( ch -- n )
+    1string roman-digits index ; inline
 
-: roman>n ( ch -- n )
-    1string roman-digits index roman-values nth ;
+: roman-digit>= ( ch1 ch2 -- ? )
+    [ roman-digit-index ] bi@ >= ;
 
-: (>roman) ( n -- )
-    roman-values roman-digits [
-        [ /mod swap ] dip <repetition> concat %
-    ] 2each drop ;
+: roman-digit-value ( ch -- n )
+    roman-digit-index roman-values nth ;
 
-: (roman>) ( seq -- n )
-    [ [ roman>n ] map ] [ all-eq? ] bi [
-        sum
-    ] [
-        first2 swap -
-    ] if ;
+: roman-value ( seq -- n )
+    [ [ roman-digit-value ] map ] [ all-eq? ] bi
+    [ sum ] [ first2 swap - ] if ;
 
 PRIVATE>
 
 : >roman ( n -- str )
-    dup roman-range-check
-    [ (>roman) ] "" make ;
+    roman-range-check
+    roman-values roman-digits [
+        [ /mod swap ] dip <repetition> concat
+    ] 2map "" concat-as nip ;
 
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman<= ] monotonic-split
-    [ (roman>) ] sigma ;
+    >lower [ roman-digit>= ] monotonic-split
+    [ roman-value ] map-sum ;
 
 <PRIVATE
 
-: 2roman> ( str1 str2 -- m n )
-    [ roman> ] bi@ ;
-
-: binary-roman-op ( str1 str2 quot -- str3 )
-    [ 2roman> ] dip call >roman ; inline
+MACRO: binary-roman-op ( quot -- quot' )
+    [ inputs ] [ ] [ outputs ] tri
+    '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
 
 PRIVATE>
 
-: roman+ ( str1 str2 -- str3 )
-    [ + ] binary-roman-op ;
-
-: roman- ( str1 str2 -- str3 )
-    [ - ] binary-roman-op ;
+<<
 
-: roman* ( str1 str2 -- str3 )
-    [ * ] binary-roman-op ;
+SYNTAX: ROMAN-OP:
+    scan-word [ name>> "roman" prepend create-word-in ] keep
+    1quotation '[ _ binary-roman-op ]
+    scan-effect define-declared ;
 
-: roman/i ( str1 str2 -- str3 )
-    [ /i ] binary-roman-op ;
+>>
 
-: roman/mod ( str1 str2 -- str3 str4 )
-    [ /mod ] binary-roman-op [ >roman ] dip ;
+ROMAN-OP: + ( x y -- z )
+ROMAN-OP: - ( x y -- z )
+ROMAN-OP: * ( x y -- z )
+ROMAN-OP: /i ( x y -- z )
+ROMAN-OP: /mod ( x y -- z w )
 
-: ROMAN: scan roman> parsed ; parsing
+SYNTAX: ROMAN: scan-token roman> suffix! ;