/* -*- mode: C; mode: fold; -*- */
/*
  Copyright (c) 2003, 2004, 2005 Massachusetts Institute of Technology

  This software was developed by the MIT Center for Space Research
  under contract SV1-61010 from the Smithsonian Institution.

  Permission to use, copy, modify, distribute, and sell this software
  and its documentation for any purpose is hereby granted without fee,
  provided that the above copyright notice appear in all copies and
  that both that copyright notice and this permission notice appear in
  the supporting documentation, and that the name of the Massachusetts
  Institute of Technology not be used in advertising or publicity
  pertaining to distribution of the software without specific, written
  prior permission.  The Massachusetts Institute of Technology makes
  no representations about the suitability of this software for any
  purpose.  It is provided "as is" without express or implied warranty.

  THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY DISCLAIMS ALL WARRANTIES
  WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  MERCHANTABILITY AND FITNESS.  IN NO EVENT SHALL THE MASSACHUSETTS
  INSTITUTE OF TECHNOLOGY BE LIABLE FOR ANY SPECIAL, INDIRECT OR
  CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/

/* Author: John E. Davis (jed@jedsoft.org) */

#include <stdio.h>
#include <string.h>
#include <slang.h>

#include <gsl/gsl_errno.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_spline.h>

#include "slgsl.h"
#include "version.h"

#ifdef __cplusplus
extern "C"
{
#endif
/* SLANG_MODULE(gslinterp); */
#ifdef __cplusplus
}
#endif

static int Interp_Type_Id = -1;

typedef struct
{
   gsl_interp *g;
   gsl_interp_accel *acc;
   SLang_Array_Type *at_xa;
   SLang_Array_Type *at_ya;
}
Interp_Type;

static void free_interp_type (SLtype type, VOID_STAR f)
{
   Interp_Type *it;

   (void) type;

   it = (Interp_Type *) f;
   if (it->acc != NULL)
     gsl_interp_accel_free (it->acc);
   if (it->g != NULL)
     gsl_interp_free (it->g);

   if (it->at_xa != NULL)
     SLang_free_array (it->at_xa);

   if (it->at_ya != NULL)
     SLang_free_array (it->at_ya);

   SLfree ((char *) it);
}

/* This function steals the at_xa and at_ya arrays upon sucess.  Do not
 * free the arrays if successful.  The arrays must be Double_Type and of
 * the same size.
 */
static Interp_Type *alloc_interp_type (const gsl_interp_type *ic,
				       SLang_Array_Type *at_xa,
				       SLang_Array_Type *at_ya)
{
   Interp_Type *it;
   unsigned int na;
   double *xa, *ya;

   xa = (double *)at_xa->data;
   ya = (double *)at_ya->data;
   na = at_xa->num_elements;

   /* make sure the xa values are in ascending order */
   if (na > 1)
     {
	double last = xa[0];
	unsigned int i;

	for (i = 0; i < na; i++)
	  {
	     if (xa[i] < last)
	       {
		  SLang_verror (SL_INVALID_PARM,
				"The gsl interpolation routines require the xa array to be in ascending order.");
		  return NULL;
	       }
	     last = xa[i];
	  }
     }

   if (NULL == (it = (Interp_Type *) SLmalloc (sizeof (Interp_Type))))
     return NULL;

   memset ((char *) it, 0, sizeof (Interp_Type));

   if (NULL == (it->g = gsl_interp_alloc (ic, na)))
     {
	free_interp_type (Interp_Type_Id, (VOID_STAR) it);
	return NULL;
     }

   if (gsl_interp_min_size (it->g) > na)
     {
	SLang_verror (SL_INVALID_PARM, "%s interpolation requires at least %u points.",
		      gsl_interp_name (it->g), gsl_interp_min_size (it->g));
	free_interp_type (Interp_Type_Id, (VOID_STAR) it);
	return NULL;
     }

   if ((NULL == (it->acc = gsl_interp_accel_alloc ()))
       || (GSL_SUCCESS != gsl_interp_init (it->g, xa, ya, na)))
     {
	free_interp_type (Interp_Type_Id, (VOID_STAR) it);
	return NULL;
     }

   it->at_xa = at_xa;
   it->at_ya = at_ya;

   return it;
}

static int do_interp_1 (double (*fun)(const gsl_interp *, const double [], const double [], double, gsl_interp_accel *),
			Interp_Type *it,
			double *x, double *fx, unsigned int numx)
{
   gsl_interp *g;
   gsl_interp_accel *acc;
   unsigned int i;
   double *xa, *ya;

   g = it->g;
   acc = it->acc;
   xa = (double *) it->at_xa->data;
   ya = (double *) it->at_ya->data;

   for (i = 0; i < numx; i++)
     fx[i] = (*fun) (g, xa, ya, x[i], acc);

   return 0;
}

static int do_interp_integ_1 (Interp_Type *it,
			      double *a, double *b, unsigned int num_a,
			      double *result)
{
   gsl_interp *g;
   gsl_interp_accel *acc;
   unsigned int i;
   double *xa, *ya;

   g = it->g;
   acc = it->acc;
   xa = (double *) it->at_xa->data;
   ya = (double *) it->at_ya->data;

   for (i = 0; i < num_a; i++)
     result[i] = gsl_interp_eval_integ (g, xa, ya, a[i], b[i], acc);

   return 0;
}

/* Syntax: y = interp_eval (GSL_Interp_Type, Double_Type x[]); */
static void do_interp_eval (double (*fun)(const gsl_interp *, const double [], const double [], double, gsl_interp_accel *))
{
   SLGSL_Double_Array_Type x, fx;
   SLang_MMT_Type *mmt;
   Interp_Type *it;

   if (-1 == slgsl_pop_d_array (&x, 0))
     return;

   if (NULL == (mmt = SLang_pop_mmt (Interp_Type_Id)))
     {
	slgsl_free_d_array (&x);
	return;
     }
   if (NULL == (it = (Interp_Type *) SLang_object_from_mmt (mmt)))
     {
	SLang_free_mmt (mmt);
	slgsl_free_d_array (&x);
	return;
     }

   if (-1 == slgsl_create_d_array (&x, &fx))
     {
	SLang_free_mmt (mmt);
	slgsl_free_d_array (&x);
	return;
     }

   if (0 == do_interp_1 (fun, it, x.xp, fx.xp, fx.num_elements))
     (void) slgsl_push_d_array (&fx, 0);

   slgsl_free_d_array (&fx);
   slgsl_free_d_array (&x);
   SLang_free_mmt (mmt);
}

/* Usage: y = interp_integ (GSL_Interp_Type, a, b) */
static void interp_eval_integ (void)
{
   SLGSL_Double_Array_Type y, a, b;
   SLang_MMT_Type *mmt;
   Interp_Type *it;

   if (SLang_Num_Function_Args != 3)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: y = interp_eval_integ (double x, double xa[], double ya[])");
	return;
     }

   if (-1 == slgsl_pop_dd_array (&a, &b, 0))
     return;

   if (NULL == (mmt = SLang_pop_mmt (Interp_Type_Id)))
     {
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }
   if (NULL == (it = (Interp_Type *) SLang_object_from_mmt (mmt)))
     {
	SLang_free_mmt (mmt);
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }

   if (-1 == slgsl_create_d_array (&a, &y))
     {
	SLang_free_mmt (mmt);
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }

   if (0 == do_interp_integ_1 (it, a.xp, b.xp, a.num_elements, y.xp))
     (void) slgsl_push_d_array (&y, 0);

   slgsl_free_d_array (&y);
   SLang_free_mmt (mmt);
   slgsl_free_d_array (&a);
   slgsl_free_d_array (&b);
}

/* Syntax: interp (newx, oldx, oldy) */

static void do_interp (double (*fun)(const gsl_interp *, const double [], const double [], double, gsl_interp_accel *),
		       const gsl_interp_type *type)
{
   SLGSL_Double_Array_Type xa, ya, x, fx;
   Interp_Type *it;

   if (-1 == slgsl_pop_dd_array (&xa, &ya, 1))
     return;

   if (-1 == slgsl_pop_d_array (&x, 0))
     {
	slgsl_free_d_array (&xa);
	slgsl_free_d_array (&ya);
	return;
     }

   if (-1 == slgsl_create_d_array (&x, &fx))
     {
	slgsl_free_d_array (&x);
	slgsl_free_d_array (&xa);
	slgsl_free_d_array (&ya);
	return;
     }

   if (NULL == (it = alloc_interp_type (type, xa.at, ya.at)))
     {
	slgsl_free_d_array (&fx);
	slgsl_free_d_array (&x);
	slgsl_free_d_array (&xa);
	slgsl_free_d_array (&ya);
	return;
     }

   /* 'it' now owns xa->at and ya->at */

   if (0 == do_interp_1 (fun, it, x.xp, fx.xp, fx.num_elements))
     (void) slgsl_push_d_array (&fx, 0);

   slgsl_free_d_array (&fx);
   slgsl_free_d_array (&x);

   free_interp_type (Interp_Type_Id, (VOID_STAR) it);
   /* slgsl_free_d_array (&xa); */
   /* slgsl_free_d_array (&ya); */
}

#define INTERP_FUN(fun,type,name) \
  static void name (void) \
  { \
     if (SLang_Num_Function_Args != 3) \
       { \
	  SLang_verror (SL_USAGE_ERROR, "Usage: y=%s(double x, double xa[], double ya[])", #name); \
	  return; \
       } \
     slgsl_reset_errors (); \
     do_interp (fun, type); \
     slgsl_check_errors (#name); \
  }

INTERP_FUN(gsl_interp_eval, gsl_interp_linear, interp_linear)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_linear, interp_linear_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_linear, interp_linear_deriv2)

INTERP_FUN(gsl_interp_eval, gsl_interp_polynomial, interp_polynomial)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_polynomial, interp_polynomial_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_polynomial, interp_polynomial_deriv2)

INTERP_FUN(gsl_interp_eval, gsl_interp_cspline, interp_cspline)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_cspline, interp_cspline_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_cspline, interp_cspline_deriv2)

INTERP_FUN(gsl_interp_eval, gsl_interp_cspline_periodic, interp_cspline_periodic)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_cspline_periodic, interp_cspline_periodic_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_cspline_periodic, interp_cspline_periodic_deriv2)

INTERP_FUN(gsl_interp_eval, gsl_interp_akima, interp_akima)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_akima, interp_akima_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_akima, interp_akima_deriv2)

INTERP_FUN(gsl_interp_eval, gsl_interp_akima_periodic, interp_akima_periodic)
INTERP_FUN(gsl_interp_eval_deriv, gsl_interp_akima_periodic, interp_akima_periodic_deriv)
INTERP_FUN(gsl_interp_eval_deriv2, gsl_interp_akima_periodic, interp_akima_periodic_deriv2)

static void do_interp_init (const gsl_interp_type *type)
{
   SLGSL_Double_Array_Type x, y;
   Interp_Type *it;
   SLang_MMT_Type *mmt;

   if (-1 == slgsl_pop_dd_array (&x, &y, 1))
     return;

   if (NULL == (it = alloc_interp_type (type, x.at, y.at)))
     return;

   if (NULL == (mmt = SLang_create_mmt (Interp_Type_Id, (VOID_STAR) it)))
     {
	free_interp_type (Interp_Type_Id, (VOID_STAR) it);
	return;
     }

   /* Unfortunately, SLang_create_mmt sets the ref_count to 0, which means
    * that no free is necessary if the push is successful.  This is an
    * _undesirable_ slang feature that I ought to correct for slang 2.
    */
   if (0 == SLang_push_mmt (mmt))
     return;

   SLang_free_mmt (mmt);
}

/* Syntax: interp_integ (xa, ya, a, b) */

static void do_interp_integ (const gsl_interp_type *type)
{
   SLGSL_Double_Array_Type xa, ya, a, b, result;
   Interp_Type *it;

   if (-1 == slgsl_pop_dd_array (&a, &b, 0))
     return;

   if (-1 == slgsl_pop_dd_array (&xa, &ya, 1))
     {
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }

   if (-1 == slgsl_create_d_array (&a, &result))
     {
	slgsl_free_d_array (&xa);
	slgsl_free_d_array (&ya);
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }

   if (NULL == (it = alloc_interp_type (type, xa.at, ya.at)))
     {
	slgsl_free_d_array (&result);
	slgsl_free_d_array (&xa);
	slgsl_free_d_array (&ya);
	slgsl_free_d_array (&a);
	slgsl_free_d_array (&b);
	return;
     }

   /* 'it' now owns xa, ya */
   if (0 == do_interp_integ_1 (it,
			       a.xp, b.xp, a.num_elements,
			       result.xp))
     (void) slgsl_push_d_array (&result, 0);

   slgsl_free_d_array (&result);

   free_interp_type (Interp_Type_Id, (VOID_STAR) it);
   /* slgsl_free_d_array (&xa); */
   /* slgsl_free_d_array (&ya); */
   slgsl_free_d_array (&a);
   slgsl_free_d_array (&b);
}

#define INTEG_FUN(type,name) \
  static void name (void) \
  { \
     if (SLang_Num_Function_Args != 4) \
       { \
	  SLang_verror (SL_USAGE_ERROR, "Usage: y=%s(double xa[], double ya[], double a, double b)", #name); \
	  return; \
       } \
     slgsl_reset_errors (); \
     do_interp_integ (type); \
     slgsl_check_errors (#name); \
  }

INTEG_FUN(gsl_interp_linear,interp_linear_integ)
INTEG_FUN(gsl_interp_polynomial,interp_polynomial_integ)
INTEG_FUN(gsl_interp_cspline,interp_cspline_integ)
INTEG_FUN(gsl_interp_cspline_periodic,interp_cspline_periodic_integ)
INTEG_FUN(gsl_interp_akima,interp_akima_integ)
INTEG_FUN(gsl_interp_akima_periodic,interp_akima_periodic_integ)

#define INTERP_INIT_FUN(type,name) \
  static void name (void) \
  { \
     if (SLang_Num_Function_Args != 2) \
       { \
	  SLang_verror (SL_USAGE_ERROR, "Usage: y=%s(double xa[], double ya[])", #name); \
	  return; \
       } \
     slgsl_reset_errors (); \
     do_interp_init (type); \
     slgsl_check_errors (#name); \
  }
INTERP_INIT_FUN(gsl_interp_linear, interp_linear_init)
INTERP_INIT_FUN(gsl_interp_polynomial,interp_polynomial_init)
INTERP_INIT_FUN(gsl_interp_cspline,interp_cspline_init)
INTERP_INIT_FUN(gsl_interp_cspline_periodic,interp_cspline_periodic_init)
INTERP_INIT_FUN(gsl_interp_akima,interp_akima_init)
INTERP_INIT_FUN(gsl_interp_akima_periodic,interp_akima_periodic_init)

#define INTERP_EVAL_FUN(fun,name) \
  static void name (void) \
  { \
     if (SLang_Num_Function_Args != 2) \
       { \
	  SLang_verror (SL_USAGE_ERROR, "Usage: y=%s(GSL_Interp_Type c, double x)", #name); \
	  return; \
       } \
     slgsl_reset_errors (); \
     do_interp_eval (fun); \
     slgsl_check_errors (#name); \
  }

INTERP_EVAL_FUN(gsl_interp_eval, interp_eval)
INTERP_EVAL_FUN(gsl_interp_eval_deriv, interp_eval_deriv)
INTERP_EVAL_FUN(gsl_interp_eval_deriv2, interp_eval_deriv2)

#define V SLANG_VOID_TYPE
static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_0("interp_linear", interp_linear, V),
   MAKE_INTRINSIC_0("interp_linear_deriv", interp_linear_deriv, V),
   MAKE_INTRINSIC_0("interp_linear_deriv2", interp_linear_deriv2, V),
   MAKE_INTRINSIC_0("interp_linear_integ", interp_linear_integ, V),
   MAKE_INTRINSIC_0("interp_polynomial", interp_polynomial, V),
   MAKE_INTRINSIC_0("interp_polynomial_deriv", interp_polynomial_deriv, V),
   MAKE_INTRINSIC_0("interp_polynomial_deriv2", interp_polynomial_deriv2, V),
   MAKE_INTRINSIC_0("interp_polynomial_integ", interp_polynomial_integ, V),
   MAKE_INTRINSIC_0("interp_cspline", interp_cspline, V),
   MAKE_INTRINSIC_0("interp_cspline_deriv", interp_cspline_deriv, V),
   MAKE_INTRINSIC_0("interp_cspline_deriv2", interp_cspline_deriv2, V),
   MAKE_INTRINSIC_0("interp_cspline_integ", interp_cspline_integ, V),
   MAKE_INTRINSIC_0("interp_cspline_periodic", interp_cspline_periodic, V),
   MAKE_INTRINSIC_0("interp_cspline_periodic_deriv", interp_cspline_periodic_deriv, V),
   MAKE_INTRINSIC_0("interp_cspline_periodic_deriv2", interp_cspline_periodic_deriv2, V),
   MAKE_INTRINSIC_0("interp_cspline_periodic_integ", interp_cspline_periodic_integ, V),
   MAKE_INTRINSIC_0("interp_akima", interp_akima, V),
   MAKE_INTRINSIC_0("interp_akima_deriv", interp_akima_deriv, V),
   MAKE_INTRINSIC_0("interp_akima_deriv2", interp_akima_deriv2, V),
   MAKE_INTRINSIC_0("interp_akima_integ", interp_akima_integ, V),
   MAKE_INTRINSIC_0("interp_akima_periodic", interp_akima_periodic, V),
   MAKE_INTRINSIC_0("interp_akima_periodic_deriv", interp_akima_periodic_deriv, V),
   MAKE_INTRINSIC_0("interp_akima_periodic_deriv2", interp_akima_periodic_deriv2, V),
   MAKE_INTRINSIC_0("interp_akima_periodic_integ", interp_akima_periodic_integ, V),
   MAKE_INTRINSIC_0("interp_linear_init", interp_linear_init, V),
   MAKE_INTRINSIC_0("interp_polynomial_init", interp_polynomial_init, V),
   MAKE_INTRINSIC_0("interp_cspline_init", interp_cspline_init, V),
   MAKE_INTRINSIC_0("interp_cspline_periodic_init", interp_cspline_periodic_init, V),
   MAKE_INTRINSIC_0("interp_akima_init", interp_akima_init, V),
   MAKE_INTRINSIC_0("interp_akima_periodic_init", interp_akima_periodic_init, V),

   MAKE_INTRINSIC_0("interp_eval", interp_eval, V),
   MAKE_INTRINSIC_0("interp_eval_deriv", interp_eval_deriv, V),
   MAKE_INTRINSIC_0("interp_eval_deriv2", interp_eval_deriv2, V),
   MAKE_INTRINSIC_0("interp_eval_integ", interp_eval_integ, V),
   SLANG_END_INTRIN_FUN_TABLE
};
#undef V

static SLang_Intrin_Var_Type Module_Variables [] =
{
   MAKE_VARIABLE("_gslinterp_module_version_string", &Module_Version_String, SLANG_STRING_TYPE, 1),
   SLANG_END_INTRIN_VAR_TABLE
};

static SLang_IConstant_Type Module_IConstants [] =
{
   MAKE_ICONSTANT("_gslinterp_module_version", MODULE_VERSION_NUMBER),
   SLANG_END_ICONST_TABLE
};

int init_gslinterp_module_ns (char *ns_name)
{
   SLang_Class_Type *cl;

   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
   if (ns == NULL)
     return -1;

   if (Interp_Type_Id == -1)
     {
	if (NULL == (cl = SLclass_allocate_class ("GSL_Interp_Type")))
	  return -1;

	(void) SLclass_set_destroy_function (cl, free_interp_type);

	if (-1 == SLclass_register_class (cl, SLANG_VOID_TYPE,
					  sizeof (Interp_Type),
					  SLANG_CLASS_TYPE_MMT))
	  return -1;

	Interp_Type_Id = SLclass_get_class_id (cl);
     }

   if (
       (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL))
       || (-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, NULL))
       || (-1 == SLns_add_iconstant_table (ns, Module_IConstants, NULL))
       )
     return -1;

   return 0;
}

/* This function is optional */
void deinit_gslinterp_module (void)
{
}
