static int push_2_doubles (double a, double b)
{
if (-1 == SLang_push_double (a))
return -1;
return SLang_push_double (b);
}
static void getitimer_intrinsic (int *wp)
{
struct itimerval it;
if (-1 == getitimer (*wp, &it))
{
SLerrno_set_errno (errno);
SLang_verror (SL_OS_Error, "getitimer failed: %s", SLerrno_strerror (errno));
return;
}
(void) SLang_push_double (timeval_to_double (&it.it_value));
(void) SLang_push_double (timeval_to_double (&it.it_interval));
}
int user_open_source (char **argv, int argc, double area,
double cosx, double cosy, double cosz)
{
char *file;
int status;
if (-1 == init_slang ())
return -1;
file = argv[0];
if ((argc == 0) || (NULL == (file = argv[0])))
{
fprintf (stderr, "No filename specified for the slang source\n");
return -1;
}
if (0 != SLang_load_file (file))
{
fprintf (stderr, "Encountered a problem loading %s\n", file);
return -1;
}
if (NULL == (Open_Source = SLang_get_function ("user_open_source")))
{
fprintf (stderr, "%s failed to define user_open_source\n", file);
return -1;
}
if (NULL == (Create_Ray = SLang_get_function ("user_create_ray")))
{
fprintf (stderr, "%s failed to define user_create_ray\n", file);
return -1;
}
if ((-1 == SLang_start_arg_list ())
|| (-1 == push_c_string_array (argv, argc))
|| (-1 == SLang_push_double (area))
|| (-1 == SLang_push_double (cosx))
|| (-1 == SLang_push_double (cosy))
|| (-1 == SLang_push_double (cosz))
|| (-1 == SLang_end_arg_list ())
|| (-1 == SLexecute_function (Open_Source))
|| (-1 == SLang_pop_integer (&status)))
{
SLang_verror (0, "Error occured processing user_open_source in %s", file);
return -1;
}
return status;
}
static void check_intrin_double_qualifier (char *name, double *def)
{
double q;
if (-1 == SLang_get_double_qualifier (name, &q, *def))
return;
SLang_push_double (q);
}
static void intrin_atof (void)
{
char *s;
SLang_Array_Type *ats;
SLang_Array_Type *ati;
double *ip;
char **strp, **strpmax;
if (-1 == pop_array_or_string (SLANG_DOUBLE_TYPE, &s, &ats, &ati))
return;
if (s != NULL)
{
(void) SLang_push_double(_pSLang_atof(s));
SLang_free_slstring (s);
return;
}
strp = (char **) ats->data;
strpmax = strp + ats->num_elements;
ip = (double *) ati->data;
while (strp < strpmax)
{
if (*strp == NULL)
*ip++ = _pSLang_NaN;
else
*ip++ = _pSLang_atof (*strp);
strp++;
}
SLang_free_array (ats);
(void) SLang_push_array (ati, 1);
}
static void prand_array (double *rate, SLindex_Type *num) /*{{{*/
{
SLang_Array_Type *at = NULL;
double *ai;
SLindex_Type i, n;
n = *num;
if (n == 0)
return;
else if (n == 1)
{
SLang_push_double (prand (*rate));
return;
}
if (NULL == (at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
{
isis_vmesg (INTR, I_FAILED, __FILE__, __LINE__, "creating array of random values");
return;
}
ai = (double *) at->data;
for (i = 0; i < n; i++)
{
ai[i] = prand (*rate);
}
SLang_push_array (at, 1);
}
static void rand_array (SLindex_Type num, double (*rand_fun)(void)) /*{{{*/
{
SLang_Array_Type *at = NULL;
double *ad;
SLindex_Type i;
if (num <= 0)
return;
else if (num == 1)
{
SLang_push_double ((*rand_fun)());
return;
}
if (NULL == (at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &num, 1)))
{
isis_vmesg (INTR, I_FAILED, __FILE__, __LINE__, "creating array of random values");
return;
}
ad = (double *) at->data;
for (i = 0; i < num; i++)
ad[i] = (*rand_fun) ();
SLang_push_array (at, 1);
}
static int do_binary_function (double (*f)(double, double))
{
SLtype type;
Array_Or_Scalar_Type a_ast, b_ast, c_ast;
if (-1 == pop_2_arrays_or_scalar (&a_ast, &b_ast))
return -1;
c_ast.is_float = (a_ast.is_float && b_ast.is_float);
c_ast.at = NULL;
c_ast.num = 1;
c_ast.inc = 0;
if (c_ast.is_float)
{
type = SLANG_FLOAT_TYPE;
c_ast.fptr = &c_ast.f;
}
else
{
type = SLANG_DOUBLE_TYPE;
c_ast.dptr = &c_ast.d;
}
if ((a_ast.at != NULL) || (b_ast.at != NULL))
{
if (NULL == (c_ast.at = create_from_tmp_array (a_ast.at, b_ast.at, type)))
{
free_array_or_scalar (&a_ast);
free_array_or_scalar (&b_ast);
return -1;
}
c_ast.fptr = (float *) c_ast.at->data;
c_ast.dptr = (double *) c_ast.at->data;
c_ast.num = c_ast.at->num_elements;
c_ast.inc = 1;
}
if (a_ast.is_float)
{
if (b_ast.is_float)
(void) do_ff_fun (f, &a_ast, &b_ast, &c_ast);
else
(void) do_fd_fun (f, &a_ast, &b_ast, &c_ast);
}
else if (b_ast.is_float)
(void) do_df_fun (f, &a_ast, &b_ast, &c_ast);
else
(void) do_dd_fun (f, &a_ast, &b_ast, &c_ast);
free_array_or_scalar (&a_ast);
free_array_or_scalar (&b_ast);
if (c_ast.at != NULL)
return SLang_push_array (c_ast.at, 1);
if (c_ast.is_float)
return SLang_push_float (c_ast.f);
return SLang_push_double (c_ast.d);
}
static int sl_report_function (Isis_Fit_Statistic_Type *s, void *pfp, double stat, unsigned int npts, unsigned int nvpars) /*{{{*/
{
FILE *fp = (FILE *)pfp;
char *str;
if (s == NULL || s->sl_report == NULL)
return -1;
SLang_start_arg_list ();
if ((-1 == SLang_push_double (stat))
|| (-1 == SLang_push_integer ((int) npts))
|| (-1 == SLang_push_integer ((int) nvpars)))
return -1;
SLang_end_arg_list ();
if (-1 == SLexecute_function ((SLang_Name_Type *)s->sl_report))
return -1;
if (-1 == SLang_pop_slstring (&str))
return -1;
if (EOF == fputs (str, fp))
{
SLang_free_slstring (str);
return -1;
}
SLang_free_slstring (str);
return 0;
}
static int push_4_doubles (double a, double b, double c, double d)
{
if (-1 == SLang_push_double (a))
return -1;
return push_3_doubles (b, c, d);
}
static int push_3_doubles (double a, double b, double c)
{
if (-1 == SLang_push_double (a))
return -1;
return push_2_doubles (b, c);
}
static int apply_line_modifier (Model_t *m, Model_Info_Type *info, DB_line_t *line, double *emis) /*{{{*/
{
Plasma_State_Type lm_state;
lm_state.temperature = m->temperature;
lm_state.ndensity = m->density;
SLang_start_arg_list ();
SLang_push_array (info->line_emis_modifier_params, 0);
SLang_push_int (line->indx);
if (-1 == SLang_push_cstruct ((VOID_STAR)&lm_state, Plasma_State_Layout))
return -1;
SLang_push_double (*emis);
if (info->line_emis_modifier_args != NULL)
isis_push_args (info->line_emis_modifier_args);
if (info->line_emis_modifier_qualifiers == NULL)
{
SLang_end_arg_list ();
if (-1 == SLexecute_function (info->line_emis_modifier))
return -1;
}
else
{
if ((-1 == SLang_push_function (info->line_emis_modifier))
|| (-1 == SLang_push_struct (info->line_emis_modifier_qualifiers)))
return -1;
SLang_end_arg_list ();
if (-1 == SLang_execute_function ("_isis->do_eval_with_qualifiers"))
return -1;
}
if (-1 == SLang_pop_double (emis))
return -1;
return 0;
}
static void median (void) /*{{{*/
{
SLang_Array_Type *sx = NULL;
double med = DBL_MAX;
double *x;
int n;
if ((-1 == SLang_pop_array_of_type (&sx, SLANG_DOUBLE_TYPE))
|| (sx == NULL)
|| (sx->num_elements < 1))
{
isis_throw_exception (Isis_Error);
SLang_free_array (sx);
return;
}
x = (double *)sx->data;
n = sx->num_elements;
(void) find_median (x, n, &med);
SLang_push_double (med);
SLang_free_array (sx);
}
static int penalty_statistic (Isis_Fit_Statistic_Type *st, /*{{{*/
double *y, double *fx, double *w,
unsigned int npts, double *vec, double *stat)
{
SLang_Array_Type *sl_pars = NULL;
double *pars = NULL;
double old_stat, new_stat, penalty, b, vec_penalty;
SLindex_Type num;
unsigned int i, n;
if (-1 == (*st->assigned_fun)(st, y, fx, w, npts, vec, stat))
return -1;
if (st->constraint_fun == NULL)
return 0;
if (-1 == Fit_copy_fun_params ("constraint", 1, &pars, &n))
return -1;
num = n;
if (num > 0)
{
sl_pars = SLang_create_array (SLANG_DOUBLE_TYPE, 0, pars, &num, 1);
if (NULL == sl_pars)
return -1;
}
old_stat = *stat;
SLang_start_arg_list ();
/* NULL sl_pars is ok */
if ((-1 == SLang_push_double (*stat))
|| (-1 == SLang_push_array (sl_pars, 0)))
{
SLang_end_arg_list ();
SLang_free_array (sl_pars);
return -1;
}
SLang_end_arg_list ();
if ((-1 == SLexecute_function ((SLang_Name_Type *)st->constraint_fun))
|| -1 == SLang_pop_double (&new_stat))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__, "evaluating fit-constraint function");
SLang_free_array (sl_pars);
return -1;
}
SLang_free_array (sl_pars);
*stat = new_stat;
/* The penalty must also affect the vector statistic somehow.
* Try spreading it uniformly over all bins, assuming that
* the base statistic is the Euclidean norm = sum (vec^2);
* We want to define:
* new_vec = old_vec + vec_penalty
* so that
* new_stat = sum(new_vec^2) = old_stat + penalty.
*
* FIXME? This seems ok for chi-square, but perhaps something
* different would be better for max. likelihood or cash statistic?
* Maybe the statistic object should have a vec_penalty() method?
*/
b = 2 * isis_kahan_sum (vec, npts) / npts;
penalty = new_stat - old_stat;
vec_penalty = -0.5*b + sqrt (0.25*b*b + penalty / npts);
for (i = 0; i < npts; i++)
{
vec[i] += vec_penalty;
}
return 0;
}
