/*

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

Author: Laurent Perez

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_wavelet.h>
#include <gsl/gsl_wavelet2d.h>

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

#define DWT_DAUBECHIES		1
#define DWT_HAAR		2
#define DWT_BSPLINE		3

static void wavelet_transform (void)
{
   int type;
   int nargs = SLang_Num_Function_Args;
   SLang_Array_Type *at = NULL, *x = NULL;
   size_t stride = 1;
   int dir = 1, centered = 0, k, retval, non_standard = 0;
   gsl_wavelet_direction dir_overkill;
   gsl_wavelet *w = NULL;
   gsl_wavelet_workspace *work = NULL;
   const gsl_wavelet_type *wavelet;

   switch (nargs)
     {
      case 2:
	if (-1 == SLang_pop_integer (&dir))
	  return;
	if (dir == 0)
	  {
	     SLang_verror (SL_INVALID_PARM, "dwt direction cannot be zero");
	     return;
	  }
	/* fall through */
      case 1:
	if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
	  return;
	break;

      default:
	SLang_verror (SL_USAGE_ERROR, "y = dwt (x, dir)");
     }

   if (-1 == SLang_get_int_qualifier ("type", &type, DWT_HAAR))
     goto return_error;

   centered = 0;
   if (-1 == SLang_get_int_qualifier ("centered", &centered, 1))
     goto return_error;

   switch (type)
     {
      case DWT_DAUBECHIES:
	wavelet = (centered ? gsl_wavelet_daubechies_centered : gsl_wavelet_daubechies);
	break;

      case DWT_HAAR:
	wavelet = (centered ? gsl_wavelet_haar_centered : gsl_wavelet_haar);
	break;

      case DWT_BSPLINE:
	wavelet = (centered ? gsl_wavelet_bspline_centered : gsl_wavelet_bspline);
	break;

      default:
	SLang_verror (SL_INVALID_PARM, "Wavelet type `%d' is unknown", type);
        goto return_error;
     }

   if (-1 == SLang_get_int_qualifier ("k", &k, 2))
     goto return_error;

   if (1 == SLang_qualifier_exists ("nsf"))
     non_standard = 1;

   dir_overkill = (dir > 0) ?  gsl_wavelet_forward : gsl_wavelet_backward;

   if (NULL == (w = gsl_wavelet_alloc (wavelet, k)))
     {
	SLang_verror (SL_INVALID_PARM, "Wrong 'k' value or insufficient memory");
	goto return_error;
     }

   if (NULL == (work = gsl_wavelet_workspace_alloc (at->num_elements)))
     goto return_error;

   x = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, at->dims, at->num_dims);
   if (x == NULL)
     goto return_error;

   memcpy (x->data, at->data, at->num_elements * sizeof (double));

   switch (at->num_dims)
     {
      case 1:
	retval = gsl_wavelet_transform (w, (double *)x->data, stride, x->dims [0], dir_overkill, work);
	break;

      case 2:
	if (non_standard == 1)
	  retval = gsl_wavelet2d_nstransform (w, (double *)x->data, x->dims [0], x->dims[0], x->dims[1], dir_overkill, work);
	else
	  retval = gsl_wavelet2d_transform (w, (double *)x->data, x->dims[0], x->dims[0], x->dims [1], dir_overkill, work);
	break;

      default:
	SLang_verror (SL_INVALID_PARM, "Context requires a 1-d or 2-d array");
        goto return_error;
     }

   switch (retval)
     {
      case GSL_SUCCESS:
	(void) SLang_push_array (x, 0);
	break;

      case GSL_EINVAL:
	SLang_verror (SL_INVALID_PARM, "Array length(s) must be an integer power of 2");
	break;

      default:
	SLang_verror (SL_UNKNOWN_ERROR, "Error in \"gsl_wavelet_transform\" function");
	break;
     }

   /* drop */
return_error:
   SLang_free_array (x);	       /* NULL ok */
   if (work != NULL) gsl_wavelet_workspace_free (work);
   if (w != NULL) gsl_wavelet_free (w);
   SLang_free_array (at);	       /* NULL ok */
}

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

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

static SLang_IConstant_Type Module_IConstants [] =
{
   MAKE_ICONSTANT("DWT_BSPLINE", DWT_BSPLINE),
   MAKE_ICONSTANT("DWT_DAUBECHIES", DWT_DAUBECHIES),
   MAKE_ICONSTANT("DWT_HAAR", DWT_HAAR),
   MAKE_ICONSTANT("_gsldwt_module_version", MODULE_VERSION_NUMBER),
   SLANG_END_ICONST_TABLE
};

int init_gsldwt_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_gsldwt_module (void)
{
}
