void mzeros1 (header *hd)
{ header *st=hd,*hd1,*result;
int r,c;
double *m,xr,xi;
hd1=nextof(hd);
hd=getvalue(hd); if (error) return;
if (hd->type==s_matrix)
{ make_complex(st); if (error) return;
hd=getvalue(st); if (error) return;
}
hd1=getvalue(hd1); if (error) return;
if (hd1->type==s_real)
{ xr=*realof(hd1); xi=0;
}
else if (hd1->type==s_complex)
{ xr=*realof(hd1); xi=*(realof(hd1)+1);
}
else
{ output("Need a starting value!\n"); error=300; return; }
if (hd->type!=s_cmatrix || dimsof(hd)->r!=1 || dimsof(hd)->c<2)
{ output("Need a complex polynomial\n"); error=300; return; }
getmatrix(hd,&r,&c,&m);
result=new_complex(0,0,""); if (error) return;
bauhuber(m,c-1,realof(result),0,xr,xi);
moveresult(st,result);
}
static Lisp_Object Lcomplex_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
/* /* Need to coerce a and b to the same type here... */
a = make_complex(a, b);
errexit();
return onevalue(a);
}
static void make_filter(T *result_b, T *result_a, const complex4c *alpha, const complex4c *beta, int K, T sigma)
{
const double denom = sigma * M_SQRT2PI;
complex4c b[DERICHE_MAX_K], a[DERICHE_MAX_K + 1];
int k, j;
b[0] = alpha[0]; /* Initialize b/a = alpha[0] / (1 + beta[0] z^-1) */
a[0] = make_complex(1, 0);
a[1] = beta[0];
for (k = 1; k < K; ++k)
{ /* Add kth term, b/a += alpha[k] / (1 + beta[k] z^-1) */
b[k] = c_mul(beta[k], b[k-1]);
for (j = k - 1; j > 0; --j)
b[j] = c_add(b[j], c_mul(beta[k], b[j - 1]));
for (j = 0; j <= k; ++j)
b[j] = c_add(b[j], c_mul(alpha[k], a[j]));
a[k + 1] = c_mul(beta[k], a[k]);
for (j = k; j > 0; --j)
a[j] = c_add(a[j], c_mul(beta[k], a[j - 1]));
}
for (k = 0; k < K; ++k)
{
result_b[k] = (T)(b[k].real / denom);
result_a[k + 1] = (T)a[k + 1].real;
}
return;
}
static Lisp_Object Lcomplex_1(Lisp_Object nil, Lisp_Object a)
{
/* /* Need to make zero of same type as a */
a = make_complex(a, fixnum_of_int(0));
errexit();
return onevalue(a);
}
/**
* \brief Expand pole product
* \param c resulting filter coefficients
* \param poles pole locations
* \param K number of poles
* \ingroup vyv_gaussian
*
* This routine expands the product to obtain the filter coefficients:
* \f[ \prod_{k=0}^{K-1}\frac{\mathrm{poles}[k]-1}{\mathrm{poles}[k]-z^{-1}}
= \frac{c[0]}{1+\sum_{k=1}^K c[k] z^{-k}}. \f]
*/
static void expand_pole_product(double *c, const complex4c *poles, int K)
{
complex4c denom[VYV_MAX_K + 1];
int k, j;
assert(K <= VYV_MAX_K);
denom[0] = poles[0];
denom[1] = make_complex(-1, 0);
for (k = 1; k < K; ++k)
{
denom[k + 1] = c_neg(denom[k]);
for (j = k; j > 0; --j)
denom[j] = c_sub(c_mul(denom[j], poles[k]), denom[j - 1]);
denom[0] = c_mul(denom[0], poles[k]);
}
for (k = 1; k <= K; ++k)
c[k] = c_div(denom[k], denom[0]).real;
for (c[0] = 1, k = 1; k <= K; ++k)
c[0] += c[k];
return;
}
Complex* add(Complex* a, Complex* b) {
int real = a->real + b->real,
imaginary = a->imaginary + b->imaginary;
Complex* result = make_complex(real, imaginary);
return result;
}
Scheme_Object *scheme_complex_negate(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
return make_complex(scheme_bin_minus(scheme_make_integer(0),
c->r),
scheme_bin_minus(scheme_make_integer(0),
c->i),
0);
}
Complex* divide(Complex* a, Complex* b) {
x = a->real; y = a->imaginary;
xi = b->real; yi = b->imaginary;
int real = (x * xi + y * yi) / (xi * xi + yi * yi),
imaginary = (x * yi - y * xi) / (xi * xi + yi * yi);
Complex* result = make_complex(real, imaginary);
return result;
}
Complex* product(Complex* a, Complex* b) {
x = a->real; y = a->imaginary;
xi = b->real; yi = b->imaginary;
int real = (x * xi) - (y * yi),
imaginary = (x * yi) - (y * xi);
Complex* result = make_complex(real, imaginary);
return result;
}
static Lisp_Object pluscc(Lisp_Object a, Lisp_Object b)
/*
* Add complex values.
*/
{
Lisp_Object c, nil;
push2(a, b);
c = plus2(imag_part(a), imag_part(b));
pop2(b, a);
errexit();
a = plus2(real_part(a), real_part(b));
errexit();
return make_complex(a, c);
}
static Lisp_Object plusic(Lisp_Object a, Lisp_Object b)
/*
* real of any sort plus complex.
*/
{
Lisp_Object nil;
push(b);
a = plus2(a, real_part(b));
pop(b);
errexit();
/*
* make_complex() takes responsibility for mapping #C(n 0) onto n
*/
return make_complex(a, imag_part(b));
}
static Lisp_Object Lconjugate(Lisp_Object nil, Lisp_Object a)
{
if (!is_number(a)) return aerror1("conjugate", a);
if (is_numbers(a) && is_complex(a))
{ Lisp_Object r = real_part(a),
i = imag_part(a);
push(r);
i = negate(i);
pop(r);
errexit();
a = make_complex(r, i);
errexit();
return onevalue(a);
}
else return onevalue(a);
}
void mzeros (header *hd)
{ header *st=hd,*result;
int r,c;
double *m;
hd=getvalue(hd); if (error) return;
if (hd->type==s_matrix)
{ make_complex(st); if (error) return;
hd=getvalue(st); if (error) return;
}
if (hd->type!=s_cmatrix || dimsof(hd)->r!=1 || dimsof(hd)->c<2)
{ output("Need a complex polynomial\n"); error=300; return; }
getmatrix(hd,&r,&c,&m);
result=new_cmatrix(1,c-1,""); if (error) return;
bauhuber(m,c-1,matrixof(result),1,0,0);
moveresult(st,result);
}
main () {
// main function
int finished = 0;
char command [100];
double re, im, angle,x,y;
MY_COMPLEX * z;
while (!finished) {
scanf ("%s",command);
if (strncmp(command, "make",6) == 0) {
scanf("%lf",&re);
scanf("%lf",&im);
z = make_complex(re,im);
printf("make ");
print_complex(z);
}
else if (strncmp(command,"translate",8) == 0) {
check_complex(z);
scanf ("%lf", &x);
scanf ("%lf", &y);
printf("translate (%g,%g) ",x,y);
z = translate(z,x,y);
print_complex(z);
}
else if (strncmp(command, "rotate",6) == 0) {
check_complex(z);
scanf("%lf", &angle);
printf("rotate %g degrees ",angle);
z = rotate(z,angle);
printf("result ");
print_complex(z);
}
else if (strncmp(command,"print",5) == 0) {
check_complex(z);
printf("print ");
print_complex(z);
}
else if (strncmp(command,"quit",4) == 0)
finished = 1;
else
printf ("unrecognised command\n");
}
printf("Quitting\n");
}
Complex add_complex(const Complex c1, const Complex c2){
return make_complex(c1.real + c2.real, c1.imag + c2.imag);
}
Complex mul_complex(const Complex c1, const Complex c2){
return make_complex(c1.real * c2.real - c1.imag * c2.imag,
c1.real * c2.imag + c1.imag * c2.real);
}
Scheme_Object *scheme_real_to_complex(const Scheme_Object *n)
{
return make_complex(n, zero, 0);
}
Scheme_Object *scheme_make_complex(const Scheme_Object *r, const Scheme_Object *i)
{
return make_complex(r, i, 1);
}
Lisp_Object negate(Lisp_Object a)
{
#ifdef COMMON
Lisp_Object nil; /* needed for errexit() */
#endif
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
{ int32_t aa = -int_of_fixnum(a);
/*
* negating the number -#x8000000 (which is a fixnum) yields a value
* which just fails to be a fixnum.
*/
if (aa != 0x08000000) return fixnum_of_int(aa);
else return make_one_word_bignum(aa);
}
#ifdef COMMON
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
aa.f = (float) (-aa.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
#endif
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
return negateb(a);
#ifdef COMMON
case TYPE_RATNUM:
{ Lisp_Object n = numerator(a),
d = denominator(a);
push(d);
n = negate(n);
pop(d);
errexit();
return make_ratio(n, d);
}
case TYPE_COMPLEX_NUM:
{ Lisp_Object r = real_part(a),
i = imag_part(a);
push(i);
r = negate(r);
pop(i);
errexit();
push(r);
i = negate(i);
pop(r);
errexit();
return make_complex(r, i);
}
#endif
default:
return aerror1("bad arg for minus", a);
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return make_boxfloat(-d, type_of_header(flthdr(a)));
}
default:
return aerror1("bad arg for minus", a);
}
}
void deriche_precomp_(deriche_coeffs<T> *c, T sigma, int K, T tol)
{
/* Deriche's optimized filter parameters. */
static const complex4c alpha[DERICHE_MAX_K - DERICHE_MIN_K + 1][4] = {
{{0.48145, 0.971}, {0.48145, -0.971}},
{{-0.44645, 0.5105}, {-0.44645, -0.5105}, {1.898, 0}},
{{0.84, 1.8675}, {0.84, -1.8675},
{-0.34015, -0.1299}, {-0.34015, 0.1299}}
};
static const complex4c lambda[DERICHE_MAX_K - DERICHE_MIN_K + 1][4] = {
{{1.26, 0.8448}, {1.26, -0.8448}},
{{1.512, 1.475}, {1.512, -1.475}, {1.556, 0}},
{{1.783, 0.6318}, {1.783, -0.6318},
{1.723, 1.997}, {1.723, -1.997}}
};
complex4c beta[DERICHE_MAX_K];
int k;
double accum, accum_denom = 1.0;
assert(c && sigma > 0 && DERICHE_VALID_K(K) && 0 < tol && tol < 1);
for (k = 0; k < K; ++k)
{
double temp = exp(-lambda[K - DERICHE_MIN_K][k].real / sigma);
beta[k] = make_complex(
-temp * cos(lambda[K - DERICHE_MIN_K][k].imag / sigma),
temp * sin(lambda[K - DERICHE_MIN_K][k].imag / sigma));
}
/* Compute the causal filter coefficients */
make_filter<T>(c->b_causal, c->a, alpha[K - DERICHE_MIN_K], beta, K, sigma);
/* Numerator coefficients of the anticausal filter */
c->b_anticausal[0] = (T)(0.0);
for (k = 1; k < K; ++k)
c->b_anticausal[k] = c->b_causal[k] - c->a[k] * c->b_causal[0];
c->b_anticausal[K] = -c->a[K] * c->b_causal[0];
/* Impulse response sums */
for (k = 1; k <= K; ++k)
accum_denom += c->a[k];
for (k = 0, accum = 0.0; k < K; ++k)
accum += c->b_causal[k];
c->sum_causal = (T)(accum / accum_denom);
for (k = 1, accum = 0.0; k <= K; ++k)
accum += c->b_anticausal[k];
c->sum_anticausal = (T)(accum / accum_denom);
c->sigma = (T)sigma;
c->K = K;
c->tol = tol;
c->max_iter = (int)ceil(10.0 * sigma);
return;
}
Complex add_complex(Complex c1, Complex c2){
return make_complex(c1.real + c2.real, c1.img + c2.img);
}
Complex add_complex_by_reference(Complex *c1, Complex *c2){
return make_complex(c1->real + c2->real, c1->img + c2->img);
// return make_complex((*c1).real + (*c2).real, (*c1).img + (*c2).img);
}
Complex add_complex_by_const_reference(const Complex *c1, const Complex *c2){
return make_complex(c1->real + c2->real, c1->img + c2->img);
}
