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);
}
Lisp_Object make_complex(Lisp_Object r, Lisp_Object i)
{
Lisp_Object v, nil = C_nil;
/*
* Here r and i are expected to be either both rational (which in this
* context includes the case of integer values) or both of the same
* floating point type. It is assumed that this has already been
* arranged by here.
*/
if (i == fixnum_of_int(0)) return r;
stackcheck2(0, r, i);
push2(r, i);
v = getvector(TAG_NUMBERS, TYPE_COMPLEX_NUM, sizeof(Complex_Number));
/*
* The vector r has uninitialized contents here - dodgy. If the call
* to getvector succeeded then I fill it in, otherwise I will not
* refer to it again, and I think that unreferenced vectors containing junk
* are OK.
*/
pop2(i, r);
errexit();
real_part(v) = r;
imag_part(v) = i;
return v;
}
static Lisp_Object Limagpart(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!is_number(a)) return aerror1("imagpart", a);
if (is_numbers(a) && is_complex(a))
return onevalue(imag_part(a));
/* /* the 0.0 returned here ought to be the same type as a has */
else return onevalue(fixnum_of_int(0));
}
// If x is real then Im(e).diff(x) is equal to Im(e.diff(x))
static ex imag_part_expl_derivative(const ex & arg, const symbol & s)
{
if (s.info(info_flags::real))
return imag_part_function(arg.diff(s));
else {
exvector vec_arg;
vec_arg.push_back(arg);
return fderivative(ex_to<function>(imag_part(arg)).get_serial(),0,vec_arg).hold()*arg.diff(s);
}
}
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 register_abs_entry( size_type const ug_index, value_type const ug_value, value_type progress_ratio )
{
size_type const m = ug_size;
matrix_type real_part(m, 1);
matrix_type imag_part(m, 1);
std::fill( real_part.begin(), real_part.end(), value_type{} );
std::fill( imag_part.begin(), imag_part.end(), value_type{} );
value_type const weigh = ( value_type{1} - progress_ratio ) * std::sqrt( static_cast<value_type>(m) );
value_type const intensity = value_type{2} * weigh * ug_value * weigh * ug_value;
real_part[ug_index][0] = weigh;
imag_part[ug_index][0] = weigh;
dsm.register_entry( intensity, real_part.begin(), imag_part.begin() );
}
CSLbool onep(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return (a == fixnum_of_int(1));
case TAG_NUMBERS:
/* #C(r i) must satisfy onep(r) and zerop(i) */
if (is_complex(a) && onep(real_part(a)))
return zerop(imag_part(a));
else return NO;
case TAG_SFLOAT:
{ Float_union w;
w.f = (float)1.0;
return (a == (w.i & ~(int32_t)0xf) + TAG_SFLOAT);
}
case TAG_BOXFLOAT:
return (float_of_number(a) == 1.0);
default:
return NO;
}
}
CSLbool zerop(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return (a == fixnum_of_int(0));
case TAG_NUMBERS:
/* #C(r i) must satisfy zerop is r and i both do */
if (is_complex(a) && zerop(real_part(a)))
return zerop(imag_part(a));
else return NO;
case TAG_SFLOAT:
/*
* The code here assumes that the the floating point number zero
* is represented by a zero bit-pattern... see onep() for a more
* cautious way of coding things.
*/
return ((a & 0x7ffffff8) == 0); /* Strip sign bit as well as tags */
case TAG_BOXFLOAT:
return (float_of_number(a) == 0.0);
default:
return NO;
}
}
void register_entry( size_matrix_type const& ar,
value_type alpha, complex_matrix_type const& lhs_matrix, complex_matrix_type const& rhs_matrix,
value_type beta, complex_matrix_type const& expm_matrix,
matrix_type const& intensity, size_type const column_index = 0 )
{
assert( ar.row() == ar.col() );
assert( ar.row() == lhs_matrix.row() );
assert( lhs_matrix.row() == lhs_matrix.col() );
assert( ar.row() == rhs_matrix.row() );
assert( ar.row() == intensity.row() );
assert( 1 == intensity.col() );
assert( (*(std::max_element(ar.begin(), ar.end()))) < ug_size );
assert( alpha >= value_type{0} );
assert( beta >= value_type{0} );
assert( alpha <= value_type{1} );
assert( beta <= value_type{1} );
assert( std::abs(alpha+beta-value_type{1}) < value_type{ 1.0e-10} );
//assert( c1_matrix.row() == ar.row() );
//assert( c1_matrix.col() == 1 );
assert( expm_matrix.row() == ar.row() );
assert( expm_matrix.col() == 1 );
assert( column_index < ar.row() );
size_type const n = ar.row();
size_type const m = ug_size;
matrix_type real_part(m, 1);
matrix_type imag_part(m, 1);
value_type norm_factor{0};
//norm only one column
//std::for_each( expm_matrix.col_begin( column_index ), expm_matrix.col_end( column_index ), [&norm_factor]( complex_type const& c ){ norm_factor += std::norm(c); } );
std::for_each( expm_matrix.begin(), expm_matrix.end(), [&norm_factor]( complex_type const& c ){ norm_factor += std::norm(c); } );
norm_factor /= static_cast<value_type>( expm_matrix.row() );
for ( size_type r = 0; r != ar.row(); ++r )
{
//for \beta C/2 C/2 part
extract_inner_product_coefficients( m, n, ar.row_begin(r), lhs_matrix.row_begin(r), rhs_matrix.col_begin(column_index), real_part.begin(), imag_part.begin() );
real_part *= alpha;
imag_part *= alpha;
//for \gamma E part
real_part[0][0] += beta * std::real( expm_matrix[r][column_index] );
imag_part[0][0] += beta * std::imag( expm_matrix[r][column_index] );
//real_part[0][0] += beta * std::real( expm_matrix[r][column_index] ) / norm_factor;
//imag_part[0][0] += beta * std::imag( expm_matrix[r][column_index] ) / norm_factor;
//needs modifying here
dsm.register_entry( intensity[r][0], real_part.begin(), imag_part.begin() );
}
#if 0
//register lambda, ensuring lambda to be 1
std::fill( real_part.begin(), real_part.end(), value_type{} );
value_type const factor = value_type{1.0};
value_type const weigh = factor * std::sqrt( static_cast<value_type>( intensity.row() ) );
real_part[0][0] = weigh;
imag_part[0][0] = weigh;
dsm.register_entry( value_type{2} * weigh * weigh, real_part.begin(), imag_part.begin() );
#endif
}
static CSLbool numeqic(Lisp_Object a, Lisp_Object b)
{
if (!zerop(imag_part(b))) return NO;
else return numeq2(a, real_part(b));
}
static CSLbool numeqcc(Lisp_Object a, Lisp_Object b)
{
return numeq2(real_part(a), real_part(b)) &&
numeq2(imag_part(a), imag_part(b));
}
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);
}
}
boost::multi_array<double, DIMENSION>
get_imag_parts(const boost::multi_array<SCALAR, DIMENSION> &data) {
boost::multi_array<double, DIMENSION> imag_part(data.shape());
std::transform(data.begin(), data.end(), imag_part.begin(), get_imag);
return imag_part;
}
