//
// This file contains the code that handles converting
// to/from S-Lang.
//
// Although written in C++, the code does not make use of the
// features provided by the language.
//

#include <string.h>

#include "slang.h"

//
// This is the routine that evaluates the model. It is
// defined in gauss2d_model.cc
//
extern void evaluate_gauss2d(double fwhm,
			     double xpos,
			     double ypos,
			     double ellip,
			     double theta,
			     double ampl,
			     double *x0,
			     double *x1,
			     double *y,
			     int nelem);

// The following routine is the code that handles the interface
// between S-Lang and your model (in this example the
// evaluate_gauss2d routine).
//
// It has to handle converting the parameter and axis
// information from S-Lang, calling the model evaluation
// routine, and then converting the result into a S-Lang array.
//
// The handling of the arguments depends on how the routine
// is registered with S-Lang (the SLadd_intrinsic_function
// routine below). In this case we grab the values directly
// from the S-Lang stack. The 1D case was easier but that
// only works for routines with 7 or less arguments and
// we have 8 here.
//
// See the "Intrinsic Functions" section of the
// "S-Lang Library C Programmer's Guide" available from
//      http://www.jedsoft.org/slang/docs.html
// for further information on how to add routines to S-Lang
// (although these docs are for S-Lang v2 and CIAO uses
//  S-Lang v1 the interface has not changed).
//
static void gauss2d_interface(void)
{
  SLang_Array_Type* x0;
  SLang_Array_Type* x1;
  double fwhm, xpos, ypos, ellip, theta, ampl;

  // Grab the arguments from the S-Lang stack
  //
  if (
      (-1==SLang_pop_array_of_type (&x1, SLANG_DOUBLE_TYPE)) ||
      (-1==SLang_pop_array_of_type (&x0, SLANG_DOUBLE_TYPE)) ||
      (-1==SLang_pop_double (&ampl, NULL, NULL)) ||
      (-1==SLang_pop_double (&theta, NULL, NULL)) ||
      (-1==SLang_pop_double (&ellip, NULL, NULL)) ||
      (-1==SLang_pop_double (&ypos, NULL, NULL)) ||
      (-1==SLang_pop_double (&xpos, NULL, NULL)) ||
      (-1==SLang_pop_double (&fwhm, NULL, NULL))
      )
  {
    SLang_verror (SL_USAGE_ERROR,
		  (char *) "Usage: _gauss2d_um_cc (fwhm, xpos, ypos, ellip, theta, ampl, Double_Type x0[n], Double_Type x1[n]);");
    SLang_push_null (); // so that things will fail
  }
  
  // Safety check. Should not be needed in production code.
  //
  if (x0->num_elements != x1->num_elements)
  {
    SLang_verror (SL_USAGE_ERROR,
		  (char *) "Usage: _gauss2d_um_cc (fwhm, xpos, ypos, ellip, theta, ampl, Double_Type x0[n], Double_Type x1[n]);");
    SLang_push_null (); // so that things will fail
  }

  // Create memory for output
  //
  int nelem = x0->num_elements;
  SLang_Array_Type* y = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &nelem, 1);
  if (NULL==y)
  {
    SLang_verror (SL_MALLOC_ERROR,
		  (char *) "Unable to create an array of %d doubles",
		  nelem);
    SLang_push_null (); // so that things will fail
  }

  // Evaluate the model
  evaluate_gauss2d(fwhm,
		   xpos,
		   ypos,
		   ellip,
		   theta,
		   ampl,
		   (double *)(x0->data),
		   (double *)(x1->data),
		   (double *)(y->data),
		   nelem);
  
  // Return the calculated values to S-Lang.
  // The second argument is set to 1 to avoid memory leaks.
  //
  (void) SLang_push_array (y, 1);
}


//
// This routine is used to tell S-Lang what routines should
// be available from S-Lang.
//
// It must be called init_<name of module>_module_ns
// where the shared library is called
// <name of module>-module.so
//

extern "C" {

SLANG_MODULE(gauss2d_um_cc);

int init_gauss2d_um_cc_module_ns(char *ns_name)
{
  SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
  if (ns == NULL)
    return -1;

  // We want Sherpa to call the gauss2d_interface routine,
  // using the name "_gauss2d_um_cc". The leading underscore is
  // not required but does indicate this is a routine that
  // is not expected to be called directly by the user.
  //
  if (-1 == SLadd_intrinsic_function ((char *) "_gauss2d_um_cc",
				      (FVOID_STAR) &gauss2d_interface,
				      SLANG_VOID_TYPE,
				      0))
    return -1;
  
   return 0;
}

} // extern "C" block

// end
