unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
From: Kevin Ryde <user42@zip.com.au>
Subject: Re: real == frac
Date: Wed, 10 Dec 2003 06:34:38 +1000	[thread overview]
Message-ID: <87r7zdenmp.fsf@zip.com.au> (raw)
In-Reply-To: 87vfp2abh2.fsf@zagadka.ping.de

[-- Attachment #1: Type: text/plain, Size: 452 bytes --]

Marius Vollmer <mvo@zagadka.de> writes:
>
> Yes, that would be an improvement.  Could you implement it?

Starting with less_p,

        * numbers.c (scm_less_p): Don't convert frac to float for compares,
        that can give wrong results through rounding.

        * tests/numbers.test (<): Add tests inum/bignum/flonum/frac with frac.

For min and max, I'd be inclined to have them call scm_less_p for
their comparison, to avoid duplicating code.



[-- Attachment #2: numbers.c.less-frac.diff --]
[-- Type: text/plain, Size: 3725 bytes --]

--- numbers.c.~1.219.~	2003-12-03 07:37:10.000000000 +1000
+++ numbers.c	2003-12-09 14:50:46.000000000 +1000
@@ -3074,6 +3074,12 @@
 }
 
 
+/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
+   done are good for inums, but for bignums an answer can almost always be
+   had by just examining a few high bits of the operands, as done in GMP by
+   mpq_cmp.  flonum/frac compares likewise, but with the slight complication
+   of the float exponent to take into account.  */
+
 SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
 /* "Return @code{#t} if the list of parameters is monotonically\n"
  * "increasing."
@@ -3081,6 +3087,7 @@
 SCM
 scm_less_p (SCM x, SCM y)
 {
+ again:
   if (SCM_INUMP (x))
     {
       long xx = SCM_INUM (x);
@@ -3098,7 +3105,13 @@
       else if (SCM_REALP (y))
 	return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
       else if (SCM_FRACTIONP (y))
-	return SCM_BOOL ((double) xx < scm_i_fraction2double (y));
+        {
+          /* "x < a/b" becomes "x*b < a" */
+        int_frac:
+          x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
+          y = SCM_FRACTION_NUMERATOR (y);
+          goto again;
+        }
       else
 	SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
     }
@@ -3126,12 +3139,7 @@
 	  return SCM_BOOL (cmp < 0);
 	}
       else if (SCM_FRACTIONP (y))
-	{
-	  int cmp;
-	  cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y));
-	  scm_remember_upto_here_1 (x);
-	  return SCM_BOOL (cmp < 0);
-	}
+        goto int_frac;
       else
 	SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
     }
@@ -3151,25 +3159,48 @@
       else if (SCM_REALP (y))
 	return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
       else if (SCM_FRACTIONP (y))
-	return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y));
+        {
+          double  xx = SCM_REAL_VALUE (x);
+	  if (xisnan (xx))
+	    return SCM_BOOL_F;
+          if (xisinf (xx))
+            return SCM_BOOL (xx < 0.0);
+          x = scm_inexact_to_exact (x);  /* with x as frac or int */
+          goto again;
+        }
       else
 	SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
     }
   else if (SCM_FRACTIONP (x))
     {
-      if (SCM_INUMP (y))
-	return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y));
-      else if (SCM_BIGP (y))
-	{
-	  int cmp;
-	  cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x));
-	  scm_remember_upto_here_1 (y);
-	  return SCM_BOOL (cmp > 0);
-	}
+      if (SCM_INUMP (y) || SCM_BIGP (y))
+        {
+          /* "a/b < y" becomes "a < y*b" */
+          y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
+          x = SCM_FRACTION_NUMERATOR (x);
+          goto again;
+        }
       else if (SCM_REALP (y))
-	return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y));
+        {
+          double yy = SCM_REAL_VALUE (y);
+          if (xisnan (yy))
+            return SCM_BOOL_F;
+          if (xisinf (yy))
+            return SCM_BOOL (0.0 < yy);
+          y = scm_inexact_to_exact (y);  /* with y as frac or int */
+          goto again;
+        }
       else if (SCM_FRACTIONP (y))
-	return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y));
+        {
+          /* "a/b < c/d" becomes "a*d < c*b" */
+          SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
+                                   SCM_FRACTION_DENOMINATOR (y));
+          SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
+                                   SCM_FRACTION_DENOMINATOR (x));
+          x = new_x;
+          y = new_y;
+          goto again;
+        }
       else
 	SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
     }

[-- Attachment #3: numbers.test.less-frac.diff --]
[-- Type: text/plain, Size: 3078 bytes --]

--- numbers.test.~1.39.~	2003-11-25 08:11:18.000000000 +1000
+++ numbers.test	2003-12-09 15:06:40.000000000 +1000
@@ -1684,7 +1684,95 @@
   (pass-if (not (< (1- (ash 3 1023)) +nan.0)))
   (pass-if (not (< +nan.0 (ash 3 1023))))
   (pass-if (not (< +nan.0 (1+ (ash 3 1023)))))
-  (pass-if (not (< +nan.0 (1- (ash 3 1023))))))
+  (pass-if (not (< +nan.0 (1- (ash 3 1023)))))
+
+  (with-test-prefix "inum/frac"
+    (pass-if (< 2 9/4))
+    (pass-if (< -2 9/4))
+    (pass-if (< -2 7/4))
+    (pass-if (< -2 -7/4))
+    (pass-if (eq? #f (< 2 7/4)))
+    (pass-if (eq? #f (< 2 -7/4)))
+    (pass-if (eq? #f (< 2 -9/4)))
+    (pass-if (eq? #f (< -2 -9/4))))
+
+  (with-test-prefix "bignum/frac"
+    (let ((x (ash 1 2048)))
+      (pass-if (< x (* 4/3 x)))
+      (pass-if (< (- x) (* 4/3 x)))
+      (pass-if (< (- x) (* 2/3 x)))
+      (pass-if (< (- x) (* -2/3 x)))
+      (pass-if (eq? #f (< x (* 2/3 x))))
+      (pass-if (eq? #f (< x (* -2/3 x))))
+      (pass-if (eq? #f (< x (* -4/3 x))))
+      (pass-if (eq? #f (< (- x) (* -4/3 x))))))
+
+  (with-test-prefix "flonum/frac"
+    (pass-if (< 0.75 4/3))
+    (pass-if (< -0.75 4/3))
+    (pass-if (< -0.75 2/3))
+    (pass-if (< -0.75 -2/3))
+    (pass-if (eq? #f (< 0.75 2/3)))
+    (pass-if (eq? #f (< 0.75 -2/3)))
+    (pass-if (eq? #f (< 0.75 -4/3)))
+    (pass-if (eq? #f (< -0.75 -4/3)))
+
+    (pass-if (< -inf.0 4/3))
+    (pass-if (< -inf.0 -4/3))
+    (pass-if (eq? #f (< +inf.0 4/3)))
+    (pass-if (eq? #f (< +inf.0 -4/3)))
+
+    (pass-if (eq? #f (< +nan.0 4/3)))
+    (pass-if (eq? #f (< +nan.0 -4/3))))
+
+  (with-test-prefix "frac/inum"
+    (pass-if (< 7/4 2))
+    (pass-if (< -7/4 2))
+    (pass-if (< -9/4 2))
+    (pass-if (< -9/4 -2))
+    (pass-if (eq? #f (< 9/4 2)))
+    (pass-if (eq? #f (< 9/4 -2)))
+    (pass-if (eq? #f (< 7/4 -2)))
+    (pass-if (eq? #f (< -7/4 -2))))
+
+  (with-test-prefix "frac/bignum"
+    (let ((x (ash 1 2048)))
+      (pass-if (< (* 2/3 x) x))
+      (pass-if (< (* -2/3 x) x))
+      (pass-if (< (* -4/3 x) x))
+      (pass-if (< (* -4/3 x) (- x)))
+      (pass-if (eq? #f (< (* 4/3 x) x)))
+      (pass-if (eq? #f (< (* 4/3 x) (- x))))
+      (pass-if (eq? #f (< (* 2/3 x) (- x))))
+      (pass-if (eq? #f (< (* -2/3 x) (- x))))))
+
+  (with-test-prefix "frac/flonum"
+    (pass-if (< 2/3 0.75))
+    (pass-if (< -2/3 0.75))
+    (pass-if (< -4/3 0.75))
+    (pass-if (< -4/3 -0.75))
+    (pass-if (eq? #f (< 4/3 0.75)))
+    (pass-if (eq? #f (< 4/3 -0.75)))
+    (pass-if (eq? #f (< 2/3 -0.75)))
+    (pass-if (eq? #f (< -2/3 -0.75)))
+
+    (pass-if (< 4/3 +inf.0))
+    (pass-if (< -4/3 +inf.0))
+    (pass-if (eq? #f (< 4/3 -inf.0)))
+    (pass-if (eq? #f (< -4/3 -inf.0)))
+
+    (pass-if (eq? #f (< 4/3 +nan.0)))
+    (pass-if (eq? #f (< -4/3 +nan.0))))
+
+  (with-test-prefix "frac/frac"
+    (pass-if (< 2/3 6/7))
+    (pass-if (< -2/3 6/7))
+    (pass-if (< -4/3 6/7))
+    (pass-if (< -4/3 -6/7))
+    (pass-if (eq? #f (< 4/3 6/7)))
+    (pass-if (eq? #f (< 4/3 -6/7)))
+    (pass-if (eq? #f (< 2/3 -6/7)))
+    (pass-if (eq? #f (< -2/3 -6/7)))))
 
 ;;;
 ;;; >

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel

  reply	other threads:[~2003-12-09 20:34 UTC|newest]

Thread overview: 4+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2003-11-21 20:58 real == frac Kevin Ryde
2003-11-30  1:31 ` Marius Vollmer
2003-12-09 20:34   ` Kevin Ryde [this message]
2004-02-16 23:09 ` Kevin Ryde

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87r7zdenmp.fsf@zip.com.au \
    --to=user42@zip.com.au \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body. 
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).