Fixes #2966

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

diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor
index bc86db31c6444399493858c62f4ae219cc0563e5..edff040dacf15da26baae8b9f84bc7b8a0c80b1a 100644 (file)
--- a/basis/roman/roman.factor
+++ b/basis/roman/roman.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs effects fry generalizations
-grouping kernel lexer macros math math.order math.vectors
-namespaces parser quotations sequences sequences.private
-splitting.monotonic stack-checker strings unicode.case words ;
+! 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
@@ -17,19 +17,19 @@ CONSTANT: roman-values
 ERROR: roman-range-error n ;
 
 : roman-range-check ( n -- n )
-    dup 1 3999 between? [ roman-range-error ] unless ;
+    dup 1 10000 between? [ roman-range-error ] unless ;
 
 : roman-digit-index ( ch -- n )
     1string roman-digits index ; inline
 
-: roman>= ( ch1 ch2 -- ? )
+: roman-digit>= ( ch1 ch2 -- ? )
     [ roman-digit-index ] bi@ >= ;
 
-: roman>n ( ch -- n )
+: roman-digit-value ( ch -- n )
     roman-digit-index roman-values nth ;
 
-: (roman>) ( seq -- n )
-    [ [ roman>n ] map ] [ all-eq? ] bi
+: roman-value ( seq -- n )
+    [ [ roman-digit-value ] map ] [ all-eq? ] bi
     [ sum ] [ first2 swap - ] if ;
 
 PRIVATE>
@@ -43,12 +43,13 @@ PRIVATE>
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
+    >lower [ roman-digit>= ] monotonic-split
+    [ roman-value ] map-sum ;
 
 <PRIVATE
 
 MACRO: binary-roman-op ( quot -- quot' )
-    [ infer in>> ] [ ] [ infer out>> ] tri
+    [ inputs ] [ ] [ outputs ] tri
     '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
 
 PRIVATE>
@@ -56,17 +57,16 @@ PRIVATE>
 <<
 
 SYNTAX: ROMAN-OP:
-    scan-word [ name>> "roman" prepend create-in ] keep
+    scan-word [ name>> "roman" prepend create-word-in ] keep
     1quotation '[ _ binary-roman-op ]
-    dup infer [ in>> ] [ out>> ] bi
-    [ "string" <repetition> ] bi@ <effect> define-declared ;
+    scan-effect define-declared ;
 
 >>
 
-ROMAN-OP: +
-ROMAN-OP: -
-ROMAN-OP: *
-ROMAN-OP: /i
-ROMAN-OP: /mod
+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 )
 
-SYNTAX: ROMAN: scan roman> suffix! ;
+SYNTAX: ROMAN: scan-token roman> suffix! ;