redo the roman ops with smart combinators

basis/roman/roman-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel math ;
+USING: help.markup help.syntax kernel math strings ;
 IN: roman
 
 HELP: >roman
@@ -39,7 +39,7 @@ HELP: roman>
 { >roman >ROMAN roman> } related-words
 
 HELP: roman+
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Adds two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -49,7 +49,7 @@ HELP: roman+
 } ;
 
 HELP: roman-
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Subtracts two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -61,7 +61,7 @@ HELP: roman-
 { roman+ roman- } related-words
 
 HELP: roman*
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Multiplies two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -71,7 +71,7 @@ HELP: roman*
 } ;
 
 HELP: roman/i
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Computes the integer division of two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -81,7 +81,7 @@ HELP: roman/i
 } ;
 
 HELP: roman/mod
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
 { $description "Computes the quotient and remainder of two Roman numerals." }
 { $examples 
     { $example "USING: kernel io roman ;"

basis/roman/roman-tests.factor

@@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
 [ "iii" "iii"  roman- ] must-fail
 
 [ 30 ] [ ROMAN: xxx ] unit-test
+
+[ roman+ ] must-infer
+[ roman- ] must-infer
+[ roman* ] must-infer
+[ roman/i ] must-infer
+[ roman/mod ] must-infer

basis/roman/roman.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors
+USING: accessors arrays assocs fry generalizations grouping
-namespaces make quotations sequences splitting.monotonic
+kernel lexer macros make math math.order math.vectors
-sequences.private strings unicode.case lexer parser
+namespaces parser quotations sequences sequences.private
-grouping ;
+splitting.monotonic stack-checker strings unicode.case
+words effects ;
 IN: roman
 
 <PRIVATE
@@ -40,38 +41,33 @@ ERROR: roman-range-error n ;
 PRIVATE>
 
 : >roman ( n -- str )
-    dup roman-range-check
+    dup roman-range-check [ (>roman) ] "" make ;
-    [ (>roman) ] "" make ;
 
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman<= ] monotonic-split
+    >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
-    [ (roman>) ] sigma ;
 
 <PRIVATE
 
-: 2roman> ( str1 str2 -- m n )
+MACRO: binary-roman-op ( quot -- quot' )
-    [ roman> ] bi@ ;
+    dup infer [ in>> swap ] [ out>> ] bi
-
+    '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
-: binary-roman-op ( str1 str2 quot -- str3 )
-    [ 2roman> ] dip call >roman ; inline
 
 PRIVATE>
 
-: roman+ ( str1 str2 -- str3 )
+<<
-    [ + ] binary-roman-op ;
+SYNTAX: ROMAN-OP:
+    scan-word [ name>> "roman" prepend create-in ] keep
+    1quotation '[ _ binary-roman-op ]
+    dup infer [ in>> ] [ out>> ] bi
+    [ "string" <repetition> ] bi@ <effect> define-declared ;
+>>
 
-: roman- ( str1 str2 -- str3 )
+ROMAN-OP: +
-    [ - ] binary-roman-op ;
+ROMAN-OP: -
-
+ROMAN-OP: *
-: roman* ( str1 str2 -- str3 )
+ROMAN-OP: /i
-    [ * ] binary-roman-op ;
+ROMAN-OP: /mod
-
-: roman/i ( str1 str2 -- str3 )
-    [ /i ] binary-roman-op ;
-
-: roman/mod ( str1 str2 -- str3 str4 )
-    [ /mod ] binary-roman-op [ >roman ] dip ;
 
 SYNTAX: ROMAN: scan roman> parsed ;