/* -*- mode: C; mode: fold; -*- */
/* This file was automatically generated. */

/*
  Copyright (c) 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_fft_complex.h>

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

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

#if SLANG_VERSION < 20000
typedef int SLindex_Type;
typedef unsigned int SLuindex_Type;
static int SLang_get_error (void)
{
   return SLang_Error;
}
#endif

static int pop_reusable_complex_array (SLang_Array_Type **atp)
{
   SLang_Array_Type *at, *bt;
   SLtype type;

   *atp = NULL;

   type = SLang_peek_at_stack1 ();

   if (-1 == SLang_pop_array_of_type (&at, SLANG_COMPLEX_TYPE))
     return -1;

   if ((type != SLANG_COMPLEX_TYPE)
       || ((at->num_refs == 1) && (0 == (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY))))
     {
	*atp = at;
	return 0;
     }

   if (NULL == (bt = SLang_create_array (SLANG_COMPLEX_TYPE, 0, NULL, at->dims, at->num_dims)))
     {
	SLang_free_array (at);
	return -1;
     }
   memcpy ((char *)bt->data, (char *)at->data, at->num_elements * at->sizeof_type);
   SLang_free_array (at);
   *atp = bt;
   return 0;
}
#if 0
static int do_fft_1d (SLang_Array_Type *at)
{
   gsl_fft_complex_workspace *ws;
   gsl_fft_complex_wavetable *wt;
   SLindex_Type n = at->dims[0];
   unsigned int stride = 1;
   int status;

   if (NULL == (wt = gsl_fft_complex_wavetable_alloc (n)))
     return -1;
   if (NULL == (ws = gsl_fft_complex_workspace_alloc (n)))
     {
	gsl_fft_complex_wavetable_free (wt);
	return -1;
     }

   status = gsl_fft_complex_forward ((double *)at->data, stride, n, wt, ws);

   gsl_fft_complex_wavetable_free (wt);
   gsl_fft_complex_workspace_free (ws);

   return status;
}
#endif
static void fft_complex_intrin (void)
{
   SLang_Array_Type *at;
   unsigned int stride;
   double norm;
   int dir;
   gsl_fft_direction dir_overkill;
   SLuindex_Type i;

   if (SLang_Num_Function_Args == 1)
     dir = 1;
   else if (SLang_Num_Function_Args == 2)
     {
	if (-1 == SLang_pop_integer (&dir))
	  return;

	if (dir == 0)
	  {
	     SLang_verror (SL_INVALID_PARM, "fft direction cannot be zero");
	     return;
	  }
     }
   else
     {
	SLang_verror (SL_USAGE_ERROR, "y = fft (x, dir)");
	return;
     }

   dir_overkill = (dir < 0) ?  gsl_fft_forward : gsl_fft_backward;

   if (-1 == pop_reusable_complex_array (&at))
     return;

   if (at->num_elements == 0)
     {
	(void) SLang_push_array (at, 1);
	return;
     }

   stride = 1;
   i = at->num_dims;
   norm = 1.0;
   while (i != 0)
     {
	SLuindex_Type nloops;
	SLindex_Type dims_i;
	SLuindex_Type data_jump, inc, count, count_max;
	gsl_fft_complex_workspace *ws;
	gsl_fft_complex_wavetable *wt;
	double *data;

	i--;
	dims_i = at->dims[i];
	norm /= (double)dims_i;
	nloops = at->num_elements / (SLuindex_Type)dims_i;

	if (NULL == (wt = gsl_fft_complex_wavetable_alloc (dims_i)))
	  goto return_error;
	if (NULL == (ws = gsl_fft_complex_workspace_alloc (dims_i)))
	  {
	     gsl_fft_complex_wavetable_free (wt);
	     goto return_error;
	  }

	data = (double *)at->data;
	count = 0;
	data_jump = 2*stride*(dims_i-1);
	count_max = stride;
	inc = 2;
	while (nloops)
	  {
	     nloops--;
	     if ((0 != gsl_fft_complex_transform (data, stride, dims_i, wt, ws, dir_overkill))
		 || (0 != SLang_get_error ()))
	       {
		  gsl_fft_complex_wavetable_free (wt);
		  gsl_fft_complex_workspace_free (ws);
		  goto return_error;
	       }
	     data += inc;
	     count++;
	     if (count == count_max)
	       {
		  count = 0;
		  data += data_jump;
	       }
	  }
	gsl_fft_complex_wavetable_free (wt);
	gsl_fft_complex_workspace_free (ws);
	stride *= dims_i;
     }

   if (dir == -1)
     {
	double *data = (double *)at->data;
	double *data_max = data + 2 * at->num_elements;
	while (data < data_max)
	  {
	     *data *= norm;
	     data++;
	  }
     }

   (void) SLang_push_array (at, 0);
   /* drop */

   return_error:
   SLang_free_array (at);
}

#define V SLANG_VOID_TYPE
static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_0("_gsl_fft_complex", fft_complex_intrin, V),
   SLANG_END_INTRIN_FUN_TABLE
};
#undef V

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

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

int init_gslfft_module_ns (char *ns_name)
{
   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
   if (ns == NULL)
     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_gslfft_module (void)
{
}
