/* -*- mode: c; mode: fold; -*- */
/*
Copyright (C) 2021 John E. Davis

This file is part of the GSL S-Lang module.

The S-Lang Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.

The S-Lang Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/

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

#include <gsl/gsl_errno.h>
#include <gsl/gsl_integration.h>

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

typedef struct
{
   SLang_Name_Type *slfunc;
   SLang_List_Type *parms;
   double a, b, c;
   SLang_Array_Type *pts_array;
   int limit_type;
   double epsabs;
   double epsrel;
   unsigned long neval;
}
Func_Callback_Type;

static double integrand_func_callback (double x, void *parms)
{
   Func_Callback_Type *f = (Func_Callback_Type *)parms;
   double y;

   f->neval++;

   if ((-1 == SLang_start_arg_list ())
       || (-1 == SLang_push_double (x))
       || ((f->parms != NULL) && (-1 == SLang_push_list (f->parms, 0)))
       || (-1 == SLang_end_arg_list ())
       || (-1 == SLexecute_function (f->slfunc))
       || (-1 == SLang_pop_double (&y)))
     return -1.0;

   return y;
}

static void free_func_callback (Func_Callback_Type *f)
{
   SLang_free_list (f->parms);	       /* NULL ok */
   SLang_free_array (f->pts_array);    /* NULL ok */
   SLang_free_function (f->slfunc);
}

#define LIMIT_TYPE_NONE   (0)
#define LIMIT_TYPE_BOTH   (1)
#define LIMIT_TYPE_UPPER  (2)
#define LIMIT_TYPE_LOWER  (3)
#define LIMIT_TYPE_C      (4)
#define LIMIT_TYPE_PTS    (5)

static int pop_func_callback (Func_Callback_Type *f, int has_eps, int has_parms, int limit_type)
{
   memset ((char *)f, 0, sizeof (Func_Callback_Type));

   switch (has_eps)
     {
      case 2:
	if (-1 == SLang_pop_double (&f->epsrel)) return -1;
	/* fall through */
      case 1:
	if (-1 == SLang_pop_double (&f->epsabs)) return -1;
	break;

      default:
	break;
     }

   switch (limit_type)
     {
      case LIMIT_TYPE_NONE:
	break;
      case LIMIT_TYPE_UPPER:
	if (-1 == SLang_pop_double (&f->b))
	  return -1;
	break;

      case LIMIT_TYPE_C:
	if (-1 == SLang_pop_double (&f->c))
	  return -1;
	/* fall through */
      case LIMIT_TYPE_BOTH:
	if (-1 == SLang_pop_double (&f->b))
	  return -1;
	/* fall through */
      case LIMIT_TYPE_LOWER:
	if (-1 == SLang_pop_double (&f->a))
	  return -1;
	break;

      case LIMIT_TYPE_PTS:
	  {
	     SLang_Array_Type *at;
	     SLuindex_Type i, n;
	     double *pts;

	     if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
	       return -1;
	     n = at->num_elements;
	     if (n < 2)
	       {
		  SLang_verror (SL_InvalidParm_Error, "pts array must have at least 2 values");
		  return -1;
	       }
	     pts = (double *) at->data;
	     for (i = 1; i < n; i++)
	       {
		  if (pts[i-1] >= pts[i])
		    {
		       SLang_verror (SL_InvalidParm_Error, "The pts array must be monotonically increasing");
		       SLang_free_array (at);
		       return -1;
		    }
	       }
	     f->pts_array = at;
	  }
	break;
     }
   f->limit_type = limit_type;

   if ((has_parms && (-1 == SLang_pop_list (&f->parms)))
       || (NULL == (f->slfunc = SLang_pop_function ())))
     {
	free_func_callback (f);
	return -1;
     }
   return 0;
}

typedef struct
{
   double result;
   double abserr;
   unsigned long neval;
   int status;
}
Integ_Result_Type;

static SLang_CStruct_Field_Type Integ_Result_Type_Struct [] =
{
   MAKE_CSTRUCT_FLOAT_FIELD(Integ_Result_Type, result, "result", 0),
   MAKE_CSTRUCT_FLOAT_FIELD(Integ_Result_Type, abserr, "abserr", 0),
   MAKE_CSTRUCT_INT_FIELD(Integ_Result_Type, neval, "neval", 0),
   MAKE_CSTRUCT_INT_FIELD(Integ_Result_Type, status, "status", 0),
   SLANG_END_CSTRUCT_TABLE
};

static int push_integ_result (Func_Callback_Type *f, double result, double abserr, int status)
{
   Integ_Result_Type r;

   r.result = result;
   r.abserr = abserr;
   r.status = status;
   r.neval = f->neval;
   return SLang_push_cstruct ((VOID_STAR) &r, Integ_Result_Type_Struct);
}

/* args: (func, {parms}, a, b,  epsabs, epsrel) */
static void integrate_qng (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   size_t neval;
   double y, abserr;
   int status, has_parms;

   if ((SLang_Num_Function_Args < 5) || (SLang_Num_Function_Args > 6))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qng (&func, [{opt-parms-list},] a, b, epsabs, relabs)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 6);

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   status = gsl_integration_qng (&f, fc.a, fc.b, fc.epsabs, fc.epsrel, &y, &abserr, &neval);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, b, epsabs, epsrel, limit, key */
static void integrate_qag (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int key, has_parms, status;

   if ((SLang_Num_Function_Args < 7) || (SLang_Num_Function_Args > 8))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qag (&func, [{opt-parms-list},] a, b, epsabs, relabs, limit, key)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 8);

   if (-1 == SLang_pop_int (&key))
     return;

   switch (key)
     {
      case GSL_INTEG_GAUSS15:
      case GSL_INTEG_GAUSS21:
      case GSL_INTEG_GAUSS31:
      case GSL_INTEG_GAUSS41:
      case GSL_INTEG_GAUSS51:
      case GSL_INTEG_GAUSS61:
	break;
      default:
	SLang_verror (SL_InvalidParm_Error, "Unsupported key in qag: %d\n", key);
	return;
     }
   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qag (&f, fc.a, fc.b, fc.epsabs, fc.epsrel, limit, key,
				 w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, b, epsabs, epsrel, limit */
static void integrate_qags (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 6) || (SLang_Num_Function_Args > 7))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qags (&func, [{opt-parms-list},] a, b, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 7);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qags (&f, fc.a, fc.b, fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] [pts-array], epsabs, epsrel, limit */
static void integrate_qagp (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 5) || (SLang_Num_Function_Args > 6))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qagp (&func, [{opt-parms-list},] pts-array, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 6);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_PTS))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qagp (&f, (double *)fc.pts_array->data, fc.pts_array->num_elements,
				  fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] epsabs, epsrel, limit */
static void integrate_qagi (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 4) || (SLang_Num_Function_Args > 5))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qagi (&func, [{opt-parms-list},] epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 5);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_NONE))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qagi (&f, fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, epsabs, epsrel, limit */
static void integrate_qagiu (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 5) || (SLang_Num_Function_Args > 6))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qagiu (&func, [{opt-parms-list},] a, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 6);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_LOWER))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qagiu (&f, fc.a, fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] b, epsabs, epsrel, limit */
static void integrate_qagil (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 5) || (SLang_Num_Function_Args > 6))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qagil (&func, [{opt-parms-list},] b, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 6);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_UPPER))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qagiu (&f, fc.b, fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, b, c, epsabs, epsrel, limit */
static void integrate_qawc (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 7) || (SLang_Num_Function_Args > 8))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_qawc (&func, [{opt-parms-list},] a, b, c, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 8);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_C))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_qawc (&f, fc.a, fc.b, fc.c, fc.epsabs, fc.epsrel, limit, w, &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, b, epsabs, epsrel, limit */
static void integrate_cquad (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_cquad_workspace *w;
   double y, abserr;
   size_t nevals;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 6) || (SLang_Num_Function_Args > 7))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_cquad (&func, [{opt-parms-list},] a, b, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 7);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_cquad_workspace_alloc(limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_cquad (&f, fc.a, fc.b, fc.epsabs, fc.epsrel, w, &y, &abserr, &nevals);
   gsl_integration_cquad_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);
   free_func_callback (&fc);
}

/*}}}*/

/* args: func, [parms,] a, b, epsabs, epsrel, limit */
static void integrate_romberg (void) /*{{{*/
{
   Func_Callback_Type fc;
   gsl_function f;
   gsl_integration_romberg_workspace *w;
   double y;
   size_t nevals;
   unsigned int limit;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 6) || (SLang_Num_Function_Args > 7))
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: res = integrate_romberg (&func, [{opt-parms-list},] a, b, epsabs, epsrel, limit)");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 7);

   if (-1 == SLang_pop_uint (&limit))
     return;

   if (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH))
     return;

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   if (NULL == (w = gsl_integration_romberg_alloc(limit)))
     {
	free_func_callback (&fc);
	return;
     }

   status = gsl_integration_romberg (&f, fc.a, fc.b, fc.epsabs, fc.epsrel, &y, &nevals, w);
   gsl_integration_romberg_free (w);

   (void) push_integ_result (&fc, y, -1, status);
   free_func_callback (&fc);
}

/*}}}*/

/*{{{ Fixed Point Quadratures */

typedef struct
{
   gsl_integration_fixed_workspace *workspace;
   const gsl_integration_fixed_type *obj;    /* not malloced */
   const char *name;
   double a, b, alpha, beta;
   size_t n;
}
Fixed_Integ_Type;
static int Fixed_Integ_Type_Id = -1;

typedef struct
{
   const char *name;
   const gsl_integration_fixed_type **fixedobj;
   int id;
}
Fixed_Type_Def_Table_Type;

static Fixed_Type_Def_Table_Type Fixed_Type_Def_Table[] =
{
#define FIXED_TYPE_LEGENDRE   (1)
   {"legendre", &gsl_integration_fixed_legendre, FIXED_TYPE_LEGENDRE},
#define FIXED_TYPE_CHEBYSHEV  (2)
   {"chebyshev", &gsl_integration_fixed_chebyshev, FIXED_TYPE_CHEBYSHEV},
#define FIXED_TYPE_GEGENBAUER (3)
   {"gegenbauer", &gsl_integration_fixed_gegenbauer, FIXED_TYPE_GEGENBAUER},
#define FIXED_TYPE_JACOBI     (4)
   {"jacobi", &gsl_integration_fixed_jacobi, FIXED_TYPE_JACOBI},
#define FIXED_TYPE_LAGUERRE   (5)
   {"laguerre", &gsl_integration_fixed_laguerre, FIXED_TYPE_LAGUERRE},
#define FIXED_TYPE_HERMITE    (6)
   {"hermite", &gsl_integration_fixed_hermite, FIXED_TYPE_HERMITE},
#define FIXED_TYPE_EXPONENTIAL (7)
   {"exponential", &gsl_integration_fixed_exponential, FIXED_TYPE_EXPONENTIAL},
#define FIXED_TYPE_RATIONAL   (8)
   {"rational", &gsl_integration_fixed_rational, FIXED_TYPE_RATIONAL},
#define FIXED_TYPE_CHEBYSHEV2 (9)
   {"chebyshev2", &gsl_integration_fixed_chebyshev2, FIXED_TYPE_CHEBYSHEV2},
   {NULL, NULL, -1}
};

static Fixed_Type_Def_Table_Type *lookup_fixed_type (const char *name)
{
   Fixed_Type_Def_Table_Type *ent;

   ent = Fixed_Type_Def_Table;
   while (ent->name != NULL)
     {
	if (0 == strcmp (ent->name, name))
	  return ent;
	ent++;
     }
   SLang_verror (SL_InvalidParm_Error, "fixed integration type %s is unknown/unsupported", name);
   return NULL;
}

static Fixed_Integ_Type *
alloc_fixed_integration_type (const char *name, double a, double b,
			      double alpha, double beta, size_t n)
{
   Fixed_Integ_Type *ft;
   Fixed_Type_Def_Table_Type *ent;

   if (NULL == (ent = lookup_fixed_type (name)))
     return NULL;

   switch (ent->id)
     {
      case FIXED_TYPE_LEGENDRE:
	if (b <= a) goto constraint_error;
	break;

      case FIXED_TYPE_CHEBYSHEV:
	if (b <= a) goto constraint_error;
	break;

      case FIXED_TYPE_GEGENBAUER:
	if ((a <= -1) || (a <= b)) goto constraint_error;
	break;

      case FIXED_TYPE_JACOBI:
	if ((alpha <= -1) || (beta <= -1) || (b <= a)) goto constraint_error;
	break;

      case FIXED_TYPE_LAGUERRE:
	if ((alpha <= -1) || (b <= 0)) goto constraint_error;
	break;

      case FIXED_TYPE_HERMITE:
	if ((alpha <= -1) || (b <= 0)) goto constraint_error;
	break;

      case FIXED_TYPE_EXPONENTIAL:
	if ((alpha <= -1) || (b <= a)) goto constraint_error;
	break;

      case FIXED_TYPE_RATIONAL:
	if ((alpha <= 1) || (alpha + beta + 2*n >= 0) || (a + b <= 0))
	  goto constraint_error;
	break;

      case FIXED_TYPE_CHEBYSHEV2:
	if (b <= a) goto constraint_error;
	break;

      default:
	SLang_verror (SL_INTERNAL_ERROR, "Fixed Type %s is not implemented", ent->name);
	return NULL;
     }

   if (NULL == (ft = (Fixed_Integ_Type *) SLmalloc (sizeof (Fixed_Integ_Type))))
     return NULL;
   memset ((char *) ft, 0, sizeof (Fixed_Integ_Type));

   ft->obj = *ent->fixedobj;
   ft->a = a; ft->b = b;
   ft->alpha = alpha; ft->beta = beta;
   ft->n = n;
   ft->name = ent->name;

   if (NULL == (ft->workspace = gsl_integration_fixed_alloc (ft->obj, n, a, b, alpha, beta)))
     {
	SLang_verror (SL_Malloc_Error, "gsl_integration_fixed_alloc failed");
	SLfree ((char *)ft);
	return NULL;
     }
   return ft;

constraint_error:

   SLang_verror (SL_InvalidParm_Error, "Constraints for fixed integration type %s are not satisfied", ent->name);
   return NULL;
}

static void free_fixed_integ_type (SLtype type, VOID_STAR f)
{
   Fixed_Integ_Type *ft;

   (void) type;

   ft = (Fixed_Integ_Type *) f;
   if (ft->workspace != NULL) gsl_integration_fixed_free (ft->workspace);
   SLfree ((char *) ft);
}

static void new_fixed_integ_type (void)
{
   Fixed_Integ_Type *ft;
   SLang_MMT_Type *mmt;
   double a, b, alpha, beta;
   unsigned long n;
   char *name;

   if (SLang_Num_Function_Args != 6)
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: obj = integration_fixed_alloc (fixedtype, n, a, b, alpha, beta);\n\
fixedtype is one of:\n\
 \"legendre\", \"chebyshev\", \"gegenbauer\", \"jacobi\", \"laguerre\",\n\
 \"hermite\", \"exponential\", \"rational\", \"chebyshev2\"");
	return;
     }
   if ((-1 == SLang_pop_double (&beta))
       || (-1 == SLang_pop_double (&alpha))
       || (-1 == SLang_pop_double (&b))
       || (-1 == SLang_pop_double (&a))
       || (-1 == SLang_pop_ulong (&n))
       || (-1 == SLang_pop_slstring (&name)))
     return;

   if (NULL == (ft = alloc_fixed_integration_type (name, a, b, alpha, beta, n)))
     {
	SLang_free_slstring (name);
	return;
     }

   if (NULL == (mmt = SLang_create_mmt (Fixed_Integ_Type_Id, (VOID_STAR) ft)))
     {
	free_fixed_integ_type (Fixed_Integ_Type_Id, (VOID_STAR) ft);
	SLang_free_slstring (name);
	return;
     }

   if (-1 == SLang_push_mmt (mmt))
     {
	SLang_free_mmt (mmt);
	/* drop */
     }
   SLang_free_slstring (name);
}

static void integrate_fixed (void)
{
   Func_Callback_Type fc;
   gsl_function f;
   SLang_MMT_Type *mmt;
   Fixed_Integ_Type *ft;
   double y;
   int has_parms, status;

   if ((SLang_Num_Function_Args < 2 ) || (SLang_Num_Function_Args > 3))
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: res = integration_fixed (&func, [{opt-parms-list},] fixed_obj);\n\
fixed_obj is the object previously created by the integration_fixed function");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 3);

   if (NULL == (mmt = SLang_pop_mmt (Fixed_Integ_Type_Id)))
     return;

   if (NULL == (ft = (Fixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     {
	SLang_free_mmt (mmt);
	return;
     }

   if (-1 == pop_func_callback (&fc, 0, has_parms, LIMIT_TYPE_NONE))
     {
	SLang_free_mmt (mmt);
	return;
     }

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   status = gsl_integration_fixed (&f, &y, ft->workspace);
   (void) push_integ_result (&fc, y, -1, status);

   free_func_callback (&fc);
   SLang_free_mmt (mmt);
}

static char *fixed_integ_type_string_method (SLtype type, VOID_STAR f)
{
   SLang_MMT_Type *mmt;
   Fixed_Integ_Type *ft;
   char buf[256];

   (void) type;
   mmt = *(SLang_MMT_Type **)f;
   if (NULL == (ft = (Fixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     return NULL;

   (void) SLsnprintf (buf, sizeof (buf), "GSL_Integ_Fixed_Type:%s", ft->name);
   return SLmake_string (buf);
}

static int register_fixed_integ_type (void)
{
   SLang_Class_Type *cl;

   if (NULL == (cl = SLclass_allocate_class ("GSL_Integ_Fixed_Type")))
     return -1;

   (void) SLclass_set_destroy_function (cl, free_fixed_integ_type);
   (void) SLclass_set_string_function (cl, fixed_integ_type_string_method);

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

   Fixed_Integ_Type_Id = SLclass_get_class_id (cl);
   return 0;
}

/*}}}*/

/*{{{ Gauss-Legendre integration */

typedef struct
{
   gsl_integration_glfixed_table *glfixed_table;
   size_t n;
}
GLFixed_Integ_Type;

static int GLFixed_Integ_Type_Id = -1;

static void free_glfixed_integ_type (SLtype type, VOID_STAR f)
{
   GLFixed_Integ_Type *gl;

   (void) type;

   gl = (GLFixed_Integ_Type *) f;
   if (gl->glfixed_table != NULL) gsl_integration_glfixed_table_free (gl->glfixed_table);
   SLfree ((char *) gl);
}

static void new_glfixed_integ_type (void)
{
   GLFixed_Integ_Type *gl;
   SLang_MMT_Type *mmt;
   unsigned long n;

   if (SLang_Num_Function_Args != 1)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: obj = integration_glfixed_alloc(n)");
	return;
     }
   if (-1 == SLang_pop_ulong (&n))
     return;

   if (NULL == (gl = (GLFixed_Integ_Type *) SLmalloc (sizeof (GLFixed_Integ_Type))))
     return;
   memset ((char *) gl, 0, sizeof (GLFixed_Integ_Type));

   if (NULL == (gl->glfixed_table = gsl_integration_glfixed_table_alloc (n)))
     {
	SLang_verror (SL_RunTime_Error, "gsl_integration_glfixed_table failed");
	SLfree ((char *)gl);
	return;
     }
   gl->n = n;

   if (NULL == (mmt = SLang_create_mmt (GLFixed_Integ_Type_Id, (VOID_STAR) gl)))
     {
	free_glfixed_integ_type (GLFixed_Integ_Type_Id, (VOID_STAR) gl);
	return;
     }

   if (-1 == SLang_push_mmt (mmt))
     SLang_free_mmt (mmt);
}

static void integrate_glfixed (void)
{
   Func_Callback_Type fc;
   gsl_function f;
   SLang_MMT_Type *mmt;
   GLFixed_Integ_Type *gl;
   double y;
   int has_parms;

   if ((SLang_Num_Function_Args < 4 ) || (SLang_Num_Function_Args > 5))
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: res = integration_glfixed (&func, [{opt-parms-list},] a, b, glfixed_obj);\n\
glfixed_table is the table previously created by the integration_glfixed_alloc function");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 5);

   if (NULL == (mmt = SLang_pop_mmt (GLFixed_Integ_Type_Id)))
     return;

   if (NULL == (gl = (GLFixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     {
	SLang_free_mmt (mmt);
	return;
     }

   if (-1 == pop_func_callback (&fc, 0, has_parms, LIMIT_TYPE_BOTH))
     {
	SLang_free_mmt (mmt);
	return;
     }

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   y = gsl_integration_glfixed (&f, fc.a, fc.b, gl->glfixed_table);
   (void) push_integ_result (&fc, y, -1, 0);

   free_func_callback (&fc);
   SLang_free_mmt (mmt);
}

static char *glfixed_integ_type_string_method (SLtype type, VOID_STAR f)
{
   SLang_MMT_Type *mmt;
   GLFixed_Integ_Type *gl;
   char buf[256];

   (void) type;
   mmt = *(SLang_MMT_Type **)f;
   if (NULL == (gl = (GLFixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     return NULL;

   (void) SLsnprintf (buf, sizeof (buf), "GSL_Integ_GLFixed_Type:%lu", gl->n);
   return SLmake_string (buf);
}

static int register_glfixed_integ_type (void)
{
   SLang_Class_Type *cl;

   if (NULL == (cl = SLclass_allocate_class ("GSL_Integ_GLFixed_Type")))
     return -1;

   (void) SLclass_set_destroy_function (cl, free_glfixed_integ_type);
   (void) SLclass_set_string_function (cl, glfixed_integ_type_string_method);

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

   GLFixed_Integ_Type_Id = SLclass_get_class_id (cl);
   return 0;
}

/*}}}*/

/*{{{ QAWS adaptive integration for singular functions */

typedef struct
{
   gsl_integration_qaws_table *qaws_table;
   double alpha, beta;
   int mu, nu;
}
QAWS_Integ_Type;

static int QAWS_Integ_Type_Id = -1;

static void free_qaws_integ_type (SLtype type, VOID_STAR f)
{
   QAWS_Integ_Type *q;

   (void) type;

   q = (QAWS_Integ_Type *) f;
   if (q->qaws_table != NULL) gsl_integration_qaws_table_free (q->qaws_table);
   SLfree ((char *) q);
}

static void new_qaws_integ_type (void)
{
   QAWS_Integ_Type *q;
   double alpha, beta;
   int mu, nu;
   SLang_MMT_Type *mmt;

   if (SLang_Num_Function_Args != 4)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: qaws_table = integration_qaws_alloc(alpha, beta, mu, nu)");
	return;
     }
   if ((-1 == SLang_pop_int (&nu))
       || (-1 == SLang_pop_int (&mu))
       || (-1 == SLang_pop_double (&beta))
       || (-1 == SLang_pop_double (&alpha)))
     return;

   if (((mu != 1) && (mu != 0))
	|| ((nu != 1) && (nu != 0))
	|| (alpha <= -1) || (beta <= -1))
     {
	SLang_verror (SL_InvalidParm_Error, "QAWS integration table parameters are invalid");
	return;
     }

   if (NULL == (q = (QAWS_Integ_Type *) SLmalloc (sizeof (QAWS_Integ_Type))))
     return;
   memset ((char *) q, 0, sizeof (QAWS_Integ_Type));

   if (NULL == (q->qaws_table = gsl_integration_qaws_table_alloc (alpha, beta, mu, nu)))
     {
	SLang_verror (SL_RunTime_Error, "gsl_integration_qaws_table_alloc failed");
	SLfree ((char *)q);
	return;
     }
   q->alpha = alpha;
   q->beta = beta;
   q->mu = mu;
   q->nu = nu;

   if (NULL == (mmt = SLang_create_mmt (QAWS_Integ_Type_Id, (VOID_STAR) q)))
     {
	free_qaws_integ_type (QAWS_Integ_Type_Id, (VOID_STAR) q);
	return;
     }

   if (-1 == SLang_push_mmt (mmt))
     SLang_free_mmt (mmt);
}

static void integrate_qaws (void)
{
   Func_Callback_Type fc;
   gsl_function f;
   SLang_MMT_Type *mmt;
   QAWS_Integ_Type *q;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int status, has_parms;

   if ((SLang_Num_Function_Args < 7 ) || (SLang_Num_Function_Args > 8))
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: res = integration_qaws (&func, [{opt-parms-list},] a, b, epsabs, epsrel, limit, qaws_table);\n\
qaws_table is the table previously created by the integration_qaws_alloc function");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 8);

   if (NULL == (mmt = SLang_pop_mmt (QAWS_Integ_Type_Id)))
     return;

   if ((NULL == (q = (QAWS_Integ_Type *) SLang_object_from_mmt (mmt)))
       || (-1 == SLang_pop_uint (&limit))
       || (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_BOTH)))
     {

	SLang_free_mmt (mmt);
	return;
     }

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	SLang_free_mmt (mmt);
	return;
     }

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   status = gsl_integration_qaws (&f, fc.a, fc.b, q->qaws_table,
				  fc.epsabs, fc.epsrel, limit, w,
				  &y, &abserr);

   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);

   free_func_callback (&fc);
   SLang_free_mmt (mmt);
}

static char *qaws_integ_type_string_method (SLtype type, VOID_STAR f)
{
   SLang_MMT_Type *mmt;
   GLFixed_Integ_Type *gl;
   char buf[256];

   (void) type;
   mmt = *(SLang_MMT_Type **)f;
   if (NULL == (gl = (GLFixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     return NULL;

   (void) SLsnprintf (buf, sizeof (buf), "GSL_QAWS_Integ_Type");
   return SLmake_string (buf);
}

static int register_qaws_integ_type (void)
{
   SLang_Class_Type *cl;

   if (NULL == (cl = SLclass_allocate_class ("GSL_QAWS_Integ_Type")))
     return -1;

   (void) SLclass_set_destroy_function (cl, free_qaws_integ_type);
   (void) SLclass_set_string_function (cl, qaws_integ_type_string_method);

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

   QAWS_Integ_Type_Id = SLclass_get_class_id (cl);
   return 0;
}

/*}}}*/

/*{{{ QAWO adaptive integration for oscillatory functions */

typedef struct
{
   gsl_integration_qawo_table *qawo_table;
   double omega, L;
   int type;
   size_t n;
}
QAWO_Integ_Type;

static int QAWO_Integ_Type_Id = -1;

static void free_qawo_integ_type (SLtype type, VOID_STAR f)
{
   QAWO_Integ_Type *q;

   (void) type;

   q = (QAWO_Integ_Type *) f;
   if (q->qawo_table != NULL) gsl_integration_qawo_table_free (q->qawo_table);
   SLfree ((char *) q);
}

static void new_qawo_integ_type (void)
{
   QAWO_Integ_Type *q;
   double omega, L;
   unsigned long n;
   int type;
   SLang_MMT_Type *mmt;

   if (SLang_Num_Function_Args != 4)
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: qawo_table = integration_qawo_alloc(omega, L, type, n);\n\
  type is one of: GSL_INTEG_COSINE, GSL_INTEG_SINE");
	return;
     }

   if ((-1 == SLang_pop_ulong (&n))
       || (-1 == SLang_pop_int (&type))
       || (-1 == SLang_pop_double (&L))
       || (-1 == SLang_pop_double (&omega)))
     return;

   if ((type != (int)GSL_INTEG_SINE) && (type != (int)GSL_INTEG_COSINE))
     {
	SLang_verror (SL_InvalidParm_Error, "integration_qawo_alloc: type must be one of GSL_INTEG_SINE/COSINE");
	return;
     }

   if (NULL == (q = (QAWO_Integ_Type *) SLmalloc (sizeof (QAWO_Integ_Type))))
     return;
   memset ((char *) q, 0, sizeof (QAWO_Integ_Type));

   if (NULL == (q->qawo_table = gsl_integration_qawo_table_alloc (omega, L, (enum gsl_integration_qawo_enum)type, n)))
     {
	SLang_verror (SL_RunTime_Error, "gsl_integration_qawo_table_alloc failed");
	SLfree ((char *)q);
	return;
     }
   q->omega = omega;
   q->L = L;
   q->type = type;
   q->n = n;

   if (NULL == (mmt = SLang_create_mmt (QAWO_Integ_Type_Id, (VOID_STAR) q)))
     {
	free_qawo_integ_type (QAWO_Integ_Type_Id, (VOID_STAR) q);
	return;
     }

   if (-1 == SLang_push_mmt (mmt))
     SLang_free_mmt (mmt);
}

static void integrate_qawo (void)
{
   Func_Callback_Type fc;
   gsl_function f;
   SLang_MMT_Type *mmt;
   QAWO_Integ_Type *q;
   gsl_integration_workspace *w;
   double y, abserr;
   unsigned int limit;
   int status, has_parms;

   if ((SLang_Num_Function_Args < 6 ) || (SLang_Num_Function_Args > 7))
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: res = integration_qawo (&func, [{opt-parms-list},] a, epsabs, epsrel, limit, qawo_table);\n\
qawo_table is the table previously created by the integration_qawo_alloc function");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 7);

   if (NULL == (mmt = SLang_pop_mmt (QAWO_Integ_Type_Id)))
     return;

   if ((NULL == (q = (QAWO_Integ_Type *) SLang_object_from_mmt (mmt)))
       || (-1 == SLang_pop_uint (&limit))
       || (-1 == pop_func_callback (&fc, 2, has_parms, LIMIT_TYPE_LOWER)))
     {
	SLang_free_mmt (mmt);
	return;
     }

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	SLang_free_mmt (mmt);
	return;
     }

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   status = gsl_integration_qawo (&f, fc.a, fc.epsabs, fc.epsrel,
				  limit, w, q->qawo_table,
				  &y, &abserr);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);

   free_func_callback (&fc);
   SLang_free_mmt (mmt);
}

static void integrate_qawf (void)
{
   Func_Callback_Type fc;
   gsl_function f;
   SLang_MMT_Type *mmt;
   QAWO_Integ_Type *q;
   gsl_integration_workspace *w, *w_cycle;
   double y, abserr;
   unsigned int limit;
   int status, has_parms;

   if ((SLang_Num_Function_Args < 5 ) || (SLang_Num_Function_Args > 6))
     {
	SLang_verror (SL_USAGE_ERROR, "\
Usage: res = integration_qawf (&func, [{opt-parms-list},] a, epsabs, limit, qawo_table);\n\
qawo_table is the table previously created by the integration_qawo_alloc function");
	return;
     }
   has_parms = (SLang_Num_Function_Args == 6);

   if (NULL == (mmt = SLang_pop_mmt (QAWO_Integ_Type_Id)))
     return;

   if ((NULL == (q = (QAWO_Integ_Type *) SLang_object_from_mmt (mmt)))
       || (-1 == SLang_pop_uint (&limit))
       || (-1 == pop_func_callback (&fc, 1, has_parms, LIMIT_TYPE_LOWER)))
     {
	SLang_free_mmt (mmt);
	return;
     }

   if (NULL == (w = gsl_integration_workspace_alloc (limit)))
     {
	free_func_callback (&fc);
	SLang_free_mmt (mmt);
	return;
     }

   if (NULL == (w_cycle = gsl_integration_workspace_alloc (limit)))
     {
	gsl_integration_workspace_free (w);
	free_func_callback (&fc);
	SLang_free_mmt (mmt);
	return;
     }

   f.function = integrand_func_callback;
   f.params = (void *)&fc;

   status = gsl_integration_qawf (&f, fc.a, fc.epsabs,
				  limit, w, w_cycle, q->qawo_table,
				  &y, &abserr);
   gsl_integration_workspace_free (w_cycle);
   gsl_integration_workspace_free (w);

   (void) push_integ_result (&fc, y, abserr, status);

   free_func_callback (&fc);
   SLang_free_mmt (mmt);
}

static char *qawo_integ_type_string_method (SLtype type, VOID_STAR f)
{
   SLang_MMT_Type *mmt;
   GLFixed_Integ_Type *gl;
   char buf[256];

   (void) type;
   mmt = *(SLang_MMT_Type **)f;
   if (NULL == (gl = (GLFixed_Integ_Type *) SLang_object_from_mmt (mmt)))
     return NULL;

   (void) SLsnprintf (buf, sizeof (buf), "GSL_QAWO_Integ_Type");
   return SLmake_string (buf);
}

static int register_qawo_integ_type (void)
{
   SLang_Class_Type *cl;

   if (NULL == (cl = SLclass_allocate_class ("GSL_QAWO_Integ_Type")))
     return -1;

   (void) SLclass_set_destroy_function (cl, free_qawo_integ_type);
   (void) SLclass_set_string_function (cl, qawo_integ_type_string_method);

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

   QAWO_Integ_Type_Id = SLclass_get_class_id (cl);
   return 0;
}

/*}}}*/

#define V SLANG_VOID_TYPE
static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_0("integration_qng", integrate_qng, V),
   MAKE_INTRINSIC_0("integration_qag", integrate_qag, V),
   MAKE_INTRINSIC_0("integration_qags", integrate_qags, V),
   MAKE_INTRINSIC_0("integration_qagp", integrate_qagp, V),
   MAKE_INTRINSIC_0("integration_qagi", integrate_qagi, V),
   MAKE_INTRINSIC_0("integration_qagiu", integrate_qagiu, V),
   MAKE_INTRINSIC_0("integration_qagil", integrate_qagil, V),
   MAKE_INTRINSIC_0("integration_qawc", integrate_qawc, V),
   MAKE_INTRINSIC_0("integration_cquad", integrate_cquad, V),
   MAKE_INTRINSIC_0("integration_romberg", integrate_romberg, V),
   MAKE_INTRINSIC_0("integration_fixed_alloc", new_fixed_integ_type, V),
   MAKE_INTRINSIC_0("integration_fixed", integrate_fixed, V),
   MAKE_INTRINSIC_0("integration_glfixed_alloc", new_glfixed_integ_type, V),
   MAKE_INTRINSIC_0("integration_glfixed", integrate_glfixed, V),
   MAKE_INTRINSIC_0("integration_qaws_alloc", new_qaws_integ_type, V),
   MAKE_INTRINSIC_0("integration_qaws", integrate_qaws, V),
   MAKE_INTRINSIC_0("integration_qawo_alloc", new_qawo_integ_type, V),
   MAKE_INTRINSIC_0("integration_qawo", integrate_qawo, V),
   MAKE_INTRINSIC_0("integration_qawf", integrate_qawf, V),
   SLANG_END_INTRIN_FUN_TABLE
};
#undef V

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

static SLang_IConstant_Type Module_IConstants [] =
{
   MAKE_ICONSTANT("_gslinteg_module_version", MODULE_VERSION_NUMBER),
   MAKE_ICONSTANT("GSL_INTEG_SINE", GSL_INTEG_SINE),
   MAKE_ICONSTANT("GSL_INTEG_COSINE", GSL_INTEG_COSINE),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS15", GSL_INTEG_GAUSS15),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS21", GSL_INTEG_GAUSS21),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS31", GSL_INTEG_GAUSS31),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS41", GSL_INTEG_GAUSS41),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS51", GSL_INTEG_GAUSS51),
   MAKE_ICONSTANT("GSL_INTEG_GAUSS61", GSL_INTEG_GAUSS61),
   SLANG_END_ICONST_TABLE
};

int init_gslinteg_module_ns (char *ns_name)
{
   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);

   if (ns == NULL)
     return -1;

   if (Fixed_Integ_Type_Id == -1)
     {
	if (-1 == register_fixed_integ_type ())
	  return -1;

	if (-1 == register_glfixed_integ_type ())
	  return -1;

	if (-1 == register_qaws_integ_type ())
	  return -1;

	if (-1 == register_qawo_integ_type ())
	  return -1;
     }

   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_gslinteg_module (void)
{
}
