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; }