Scheme_Object *scheme_rational_multiply(const Scheme_Object *a, const Scheme_Object *b)
{
Scheme_Rational *ra = (Scheme_Rational *)a;
Scheme_Rational *rb = (Scheme_Rational *)b;
Scheme_Object *gcd_ps, *gcd_rq, *p_, *r_, *q_, *s_;
/* From Brad Lucier: */
/* (* p/q r/s) => (make-rational (* (quotient p (gcd p s))
(quotient r (gcd r q)))
(* (quotient q (gcd r q))
(quotient s (gcd p s)))) */
gcd_ps = scheme_bin_gcd(ra->num, rb->denom);
gcd_rq = scheme_bin_gcd(rb->num, ra->denom);
p_ = scheme_bin_quotient(ra->num, gcd_ps);
r_ = scheme_bin_quotient(rb->num, gcd_rq);
q_ = scheme_bin_quotient(ra->denom, gcd_rq);
s_ = scheme_bin_quotient(rb->denom, gcd_ps);
p_ = scheme_bin_mult(p_, r_);
q_ = scheme_bin_mult(q_, s_);
return scheme_make_rational(p_, q_);
}
Scheme_Object *scheme_rational_add(const Scheme_Object *a, const Scheme_Object *b)
{
Scheme_Rational *ra = (Scheme_Rational *)a;
Scheme_Rational *rb = (Scheme_Rational *)b;
Scheme_Object *ac, *bd, *sum, *cd;
int no_normalize = 0;
if (SCHEME_INTP(ra->denom) && (SCHEME_INT_VAL(ra->denom) == 1)) {
/* Swap, to take advantage of the next optimization */
Scheme_Rational *rx = ra;
ra = rb;
rb = rx;
}
if (SCHEME_INTP(rb->denom) && (SCHEME_INT_VAL(rb->denom) == 1)) {
/* From Brad Lucier: */
/* (+ p/q n) = (make-rational (+ p (* n q)) q), no normalize */
ac = ra->num;
cd = ra->denom;
no_normalize = 1;
} else {
ac = scheme_bin_mult(ra->num, rb->denom);
cd = scheme_bin_mult(ra->denom, rb->denom);
}
bd = scheme_bin_mult(ra->denom, rb->num);
sum = scheme_bin_plus(ac, bd);
if (no_normalize)
return make_rational(sum, cd, 0);
else
return scheme_make_rational(sum, cd);
}
Scheme_Object *scheme_complex_sqrt(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
Scheme_Object *r, *i, *ssq, *srssq, *nrsq, *prsq, *nr, *ni;
r = c->r;
i = c->i;
if (scheme_is_zero(i)) {
/* Special case for x+0.0i: */
r = scheme_sqrt(1, &r);
if (!SCHEME_COMPLEXP(r))
return scheme_make_complex(r, i);
else {
c = (Scheme_Complex *)r;
if (SAME_OBJ(c->r, zero)) {
/* need an inexact-zero real part: */
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(c->i))
r = scheme_make_float(0.0);
else
#endif
r = scheme_make_double(0.0);
return scheme_make_complex(r, c->i);
} else
return r;
}
}
ssq = scheme_bin_plus(scheme_bin_mult(r, r),
scheme_bin_mult(i, i));
srssq = scheme_sqrt(1, &ssq);
if (SCHEME_FLOATP(srssq)) {
/* We may have lost too much precision, if i << r. The result is
going to be inexact, anyway, so switch to using expt. */
Scheme_Object *a[2];
a[0] = (Scheme_Object *)o;
a[1] = scheme_make_double(0.5);
return scheme_expt(2, a);
}
nrsq = scheme_bin_div(scheme_bin_minus(srssq, r),
scheme_make_integer(2));
nr = scheme_sqrt(1, &nrsq);
if (scheme_is_negative(i))
nr = scheme_bin_minus(zero, nr);
prsq = scheme_bin_div(scheme_bin_plus(srssq, r),
scheme_make_integer(2));
ni = scheme_sqrt(1, &prsq);
return scheme_make_complex(ni, nr);
}
Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Object *b)
{
Scheme_Complex *ca = (Scheme_Complex *)a;
Scheme_Complex *cb = (Scheme_Complex *)b;
return scheme_make_complex(scheme_bin_minus(scheme_bin_mult(ca->r, cb->r),
scheme_bin_mult(ca->i, cb->i)),
scheme_bin_plus(scheme_bin_mult(ca->r, cb->i),
scheme_bin_mult(ca->i, cb->r)));
}
static int rational_lt(const Scheme_Object *a, const Scheme_Object *b, int or_eq)
{
Scheme_Rational *ra = (Scheme_Rational *)a;
Scheme_Rational *rb = (Scheme_Rational *)b;
Scheme_Object *ma, *mb;
ma = scheme_bin_mult(ra->num, rb->denom);
mb = scheme_bin_mult(rb->num, ra->denom);
if (SCHEME_INTP(ma) && SCHEME_INTP(mb)) {
if (or_eq)
return (SCHEME_INT_VAL(ma) <= SCHEME_INT_VAL(mb));
else
return (SCHEME_INT_VAL(ma) < SCHEME_INT_VAL(mb));
} else if (SCHEME_BIGNUMP(ma) && SCHEME_BIGNUMP(mb)) {
if (or_eq)
return scheme_bignum_le(ma, mb);
else
return scheme_bignum_lt(ma, mb);
} else if (SCHEME_BIGNUMP(mb)) {
return SCHEME_BIGPOS(mb);
} else
return !SCHEME_BIGPOS(ma);
}
Scheme_Object *scheme_rational_round(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
Scheme_Object *q, *qd, *delta, *half;
int more = 0, can_eq_half, negative;
negative = !scheme_is_rational_positive(o);
q = scheme_bin_quotient(r->num, r->denom);
/* Get remainder absolute value: */
qd = scheme_bin_mult(q, r->denom);
if (negative)
delta = scheme_bin_minus(qd, r->num);
else
delta = scheme_bin_minus(r->num, qd);
half = scheme_bin_quotient(r->denom, scheme_make_integer(2));
can_eq_half = SCHEME_FALSEP(scheme_odd_p(1, &r->denom));
if (SCHEME_INTP(half) && SCHEME_INTP(delta)) {
if (can_eq_half && (SCHEME_INT_VAL(delta) == SCHEME_INT_VAL(half)))
more = SCHEME_TRUEP(scheme_odd_p(1, &q));
else
more = (SCHEME_INT_VAL(delta) > SCHEME_INT_VAL(half));
} else if (SCHEME_BIGNUMP(delta) && SCHEME_BIGNUMP(half)) {
if (can_eq_half && (scheme_bignum_eq(delta, half)))
more = SCHEME_TRUEP(scheme_odd_p(1, &q));
else
more = !scheme_bignum_lt(delta, half);
} else
more = SCHEME_BIGNUMP(delta);
if (more) {
if (negative)
q = scheme_sub1(1, &q);
else
q = scheme_add1(1, &q);
}
return q;
}
Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Object *_d)
{
Scheme_Complex *cn = (Scheme_Complex *)_n;
Scheme_Complex *cd = (Scheme_Complex *)_d;
Scheme_Object *den, *r, *i, *a, *b, *c, *d, *cm, *dm, *aa[1];
int swap;
if ((cn->r == zero) && (cn->i == zero))
return zero;
a = cn->r;
b = cn->i;
c = cd->r;
d = cd->i;
/* Check for exact-zero simplifications in d: */
if (c == zero) {
i = scheme_bin_minus(zero, scheme_bin_div(a, d));
r = scheme_bin_div(b, d);
return scheme_make_complex(r, i);
} else if (d == zero) {
r = scheme_bin_div(a, c);
i = scheme_bin_div(b, c);
return scheme_make_complex(r, i);
}
if (!SCHEME_FLOATP(c) && !SCHEME_FLOATP(d)) {
/* The simple way: */
cm = scheme_bin_plus(scheme_bin_mult(c, c),
scheme_bin_mult(d, d));
r = scheme_bin_div(scheme_bin_plus(scheme_bin_mult(c, a),
scheme_bin_mult(d, b)),
cm);
i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(c, b),
scheme_bin_mult(d, a)),
cm);
return scheme_make_complex(r, i);
}
if (scheme_is_zero(d)) {
/* This is like dividing by a real number, except that
the inexact 0 imaginary part can interact with +inf.0 and +nan.0 */
r = scheme_bin_plus(scheme_bin_div(a, c),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, b));
i = scheme_bin_minus(scheme_bin_div(b, c),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, a));
return scheme_make_complex(r, i);
}
if (scheme_is_zero(c)) {
r = scheme_bin_plus(scheme_bin_div(b, d),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(c, a));
i = scheme_bin_minus(scheme_bin_mult(c, b), /* either 0.0 or +nan.0 */
scheme_bin_div(a, d));
return scheme_make_complex(r, i);
}
aa[0] = c;
cm = scheme_abs(1, aa);
aa[0] = d;
dm = scheme_abs(1, aa);
if (scheme_bin_lt(cm, dm)) {
cm = a;
a = b;
b = cm;
cm = c;
c = d;
d = cm;
swap = 1;
} else
swap = 0;
r = scheme_bin_div(c, d);
den = scheme_bin_plus(d, scheme_bin_mult(c, r));
if (swap)
i = scheme_bin_div(scheme_bin_minus(a, scheme_bin_mult(b, r)), den);
else
i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(b, r), a), den);
r = scheme_bin_div(scheme_bin_plus(b, scheme_bin_mult(a, r)), den);
return scheme_make_complex(r, i);
}