Improved syntax for ratios

core/math/parser/parser-tests.factor

@@ -95,16 +95,6 @@ unit-test
 
 [ f ] [ "\0." string>number ] unit-test
 
-! [ t ] [
-!     { "1.0/0.0" "-1.0/0.0" "0.0/0.0" }
-!     [ dup string>number number>string = ] all?
-! ] unit-test
-! 
-! [ t ] [
-!     { 1.0/0.0 -1.0/0.0 0.0/0.0 }
-!     [ dup number>string string>number = ] all?
-! ] unit-test
-
 [ 1 1 >base ] must-fail
 [ 1 0 >base ] must-fail
 [ 1 -1 >base ] must-fail

core/math/parser/parser.factor

@@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays
 combinators splitting math assocs ;
 IN: math.parser
 
-DEFER: base>
-
-: string>ratio ( str radix -- a/b )
-    >r "/" split1 r> tuck base> >r base> r>
-    2dup and [ / ] [ 2drop f ] if ;
-
 : digit> ( ch -- n )
     H{
         { CHAR: 0 0 }
@@ -36,30 +30,54 @@ DEFER: base>
         { CHAR: f 15 }
     } at ;
 
-: digits>integer ( radix seq -- n )
-    0 rot [ swapd * + ] curry reduce ;
-
-: valid-digits? ( radix seq -- ? )
-    {
-        { [ dup empty? ] [ 2drop f ] }
-        { [ f over memq? ] [ 2drop f ] }
-        { [ t ] [ swap [ < ] curry all? ] }
-    } cond ;
-
 : string>digits ( str -- digits )
     [ digit> ] { } map-as ;
 
-: string>integer ( str radix -- n/f )
-    swap "-" ?head >r
-    string>digits 2dup valid-digits?
-    [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ;
+DEFER: base>
+
+<PRIVATE
+
+SYMBOL: radix
+
+: with-radix ( radix quot -- )
+    radix swap with-variable ; inline
+
+: (base>) ( str -- n ) radix get base> ;
+
+: whole-part ( str -- m n )
+    "+" split1 >r (base>) r>
+    dup [ (base>) ] [ drop 0 swap ] if ;
+
+: string>ratio ( str -- a/b )
+    "/" split1 (base>) >r whole-part r>
+    3dup and and [ / + ] [ 3drop f ] if ;
+
+: digits>integer ( seq -- n )
+    0 radix get [ swapd * + ] curry reduce ;
+
+: valid-digits? ( seq -- ? )
+    {
+        { [ dup empty? ] [ drop f ] }
+        { [ f over memq? ] [ drop f ] }
+        { [ t ] [ radix get [ < ] curry all? ] }
+    } cond ;
+
+: string>integer ( str -- n/f )
+    string>digits dup valid-digits?
+    [ digits>integer ] [ drop f ] if ;
+
+PRIVATE>
 
 : base> ( str radix -- n/f )
+    [
+        "-" ?head >r
         {
-        { [ CHAR: / pick member? ] [ string>ratio ] }
-        { [ CHAR: . pick member? ] [ drop string>float ] }
+            { [ CHAR: / over member? ] [ string>ratio ] }
+            { [ CHAR: . over member? ] [ string>float ] }
             { [ t ] [ string>integer ] }
-    } cond ;
+        } cond
+        r> [ dup [ neg ] when ] when
+    ] with-radix ;
 
 : string>number ( str -- n/f ) 10 base> ;
 : bin> ( str -- n/f ) 2 base> ;
@@ -74,8 +92,16 @@ DEFER: base>
     dup >r /mod >digit , dup 0 >
     [ r> integer, ] [ r> 2drop ] if ;
 
+PRIVATE>
+
 GENERIC# >base 1 ( n radix -- str )
 
+<PRIVATE
+
+: (>base) ( n -- str ) radix get >base ;
+
+PRIVATE>
+
 M: integer >base
     [
         over 0 < [
@@ -87,10 +113,15 @@ M: integer >base
 
 M: ratio >base
     [
-        over numerator over >base %
-        CHAR: / ,
-        swap denominator swap >base %
-    ] "" make ;
+        [
+            dup 0 < [ "-" % neg ] when
+            1 /mod
+            >r dup zero? [ drop ] [ (>base) % "+" % ] if r>
+            dup numerator (>base) %
+            "/" %
+            denominator (>base) %
+        ] "" make
+    ] with-radix ;
 
 : fix-float ( str -- newstr )
     {

extra/math/ratios/ratios-tests.factor

@@ -105,3 +105,8 @@ unit-test
 [ "33/100" ]
 [ "66/200" string>number number>string ]
 unit-test
+
+[ 3 ] [ "1+1/2" string>number 2 * ] unit-test
+[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
+[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
+[ "1/8" ] [ 1 8 / number>string ] unit-test

extra/math/ratios/ratios.factor

@@ -48,3 +48,4 @@ M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;
+M: ratio /mod [ /i ] 2keep mod ;