path: root/k_guile.c

/* --------------------------- k_guile  ----------------------------------- */
/*   ;; Kjetil S. Matheussen, 2004.                                             */
/*                                                                              */
/* This program 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.                       */
/*                                                                              */
/* This program 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 program; if not, write to the Free Software                  */
/* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.  */
/*                                                                              */
/* ---------------------------------------------------------------------------- */



#include "libguile.h"

/* Need some more macros. */

#define POINTER_P(x) (((int) (x) & 3) == 0)
#define INTEGER_P(x) (! POINTER_P (x))

#define GET_INTEGER SCM_INUM 
#define MAKE_INTEGER  SCM_MAKINUM

#define MAKE_STRING(a) scm_mem2string(a,strlen(a))
#define EVAL(a) scm_eval_string(MAKE_STRING(a))
#define EVALINT(a) do{char tempstring[500];sprintf(tempstring,"%d",a);EVAL(tempstring);}while(0)

#define MAKE_SYM(a) gensym(SCM_SYMBOL_CHARS(a))

#define MAKE_POINTER(a) scm_ulong2num((unsigned long)a)
#define GET_POINTER(a) (void *)scm_num2ulong(a,0,"GET_POINTER()")

#define GET_X(a) ((t_k_guile *)GET_POINTER(a))

#define RU_ return SCM_UNSPECIFIED



#include "m_pd.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <stdbool.h>
#include <stdarg.h>


struct k_guile_workaround;

typedef struct k_guile
{
  t_object x_ob;

  int num_ins;
  int num_outs;

  struct k_guile_workaround **inlets;
  t_outlet **outlets;

  SCM inlet_func;
  SCM cleanup_func;

  char *filename;

  bool isinited;
} t_k_guile;

typedef struct k_guile_workaround{
  t_object x_ob;
  t_k_guile *x;
  t_inlet *inlet;
  int index;
  SCM func;
} t_k_guile_workaround;




#define KG_MAX(a,b) (((a)>(b))?(a):(b))
#define KG_MIN(a,b) (((a)<(b))?(a):(b))



static char *version = 
"k_guile v0.0.1, written by Kjetil S. Matheussen, k.s.matheussen@notam02.no";

static t_class *k_guile_class, *k_guile_workaroundclass;

static SCM pd_backtrace_run;
static SCM pd_backtrace_run1;
static SCM pd_backtrace_run2;
static SCM pd_backtrace_run3;
static SCM pd_backtrace_run4;




/*****************************************************************************************************
 *****************************************************************************************************
 *    Functions to evaluate large amount of scheme code from C.
 *****************************************************************************************************
 *****************************************************************************************************/

static char *evalstring=NULL;
static void eval2(char *string){
  char *new;
  if(evalstring==NULL){
    new=malloc(strlen(string)+1);
    sprintf(new,"%s",string);
  }else{
    new=malloc(strlen(evalstring)+strlen(string)+1);
    sprintf(new,"%s%s",evalstring,string);
    free(evalstring);
  }
  evalstring=new;
}
static void eval_file(FILE *file){
  char line[50000];
  for(;;){
    int c=fgetc(file);
    if(c==EOF) break;
    ungetc(c,file);
    fgets(line,49999,file);
    eval2(line);
  }
}
static SCM eval_do(void){
  //post(evalstring);
  SCM ret=EVAL(evalstring);
  free(evalstring);
  evalstring=NULL;
  return ret;
}





/*****************************************************************************************************
 *****************************************************************************************************
 *    Sending data to the guile side. Called either via bind or an inlet.
 *****************************************************************************************************
 *****************************************************************************************************/

static void k_guile_anything_do(t_k_guile *x,int index,SCM func,t_symbol *s, t_int argc, t_atom* argv){
  int lokke;
  SCM applyarg=SCM_EOL;

  for(lokke=argc-1;lokke>=0;lokke--){
    SCM to=SCM_BOOL_F;
    switch(argv[lokke].a_type){
    case A_NULL:
      to=SCM_EOL;
      break;
    case A_FLOAT:
      to=scm_make_real(atom_getfloatarg(lokke,argc,argv));
      break;
    case A_SYMBOL:
      to=scm_string_to_symbol(MAKE_STRING(atom_getsymbolarg(lokke,argc,argv)->s_name));
      break;
    default:
      post("Strange");
      break;
    }
    applyarg=scm_cons(to,applyarg);
  }

  if(index>=0){
    // Inlet
    scm_call_4(pd_backtrace_run3,x->inlet_func,MAKE_INTEGER(index),scm_string_to_symbol(MAKE_STRING(s->s_name)),applyarg);
  }else{
    // Binding
    if(s!=&s_float && s!=&s_list && s!=&s_symbol){
      applyarg=scm_cons(scm_string_to_symbol(MAKE_STRING(s->s_name)),applyarg);
    }
    if(s!=&s_list && GET_INTEGER(scm_length(applyarg))==1)
      applyarg=SCM_CAR(applyarg);
    scm_call_2(pd_backtrace_run1,func,applyarg);
  }
}

// Handles inlet>0 and bindings
static void k_guile_anything(t_k_guile_workaround *x2,t_symbol *s, t_int argc, t_atom* argv){
  if(x2->index>=0){
    // Inlet
    k_guile_anything_do(x2->x,x2->index,0,s,argc,argv);
  }else{
    // Binding
    k_guile_anything_do(NULL,x2->index,x2->func,s,argc,argv);
  }
}

// Handles first inlet
static void k_guile_anything_first(t_k_guile *x,t_symbol *s, t_int argc, t_atom* argv){
  k_guile_anything_do(x,0,0,s,argc,argv);
}






/*****************************************************************************************************
 *****************************************************************************************************
 *    Initialization, called from the guile side.
 *****************************************************************************************************
 *****************************************************************************************************/

static SCM gpd_set_inlet_func(SCM instance,SCM func){
  t_k_guile *x=GET_X(instance);
  x->inlet_func=func;
  scm_gc_protect_object(x->inlet_func);
  RU_;
}
static SCM gpd_set_cleanup_func(SCM instance,SCM func){
  t_k_guile *x=GET_X(instance);
  x->cleanup_func=func;
  scm_gc_protect_object(x->cleanup_func);
  RU_;
}
static SCM gpd_inlets(SCM instance,SCM num_ins){
  int lokke;
  t_k_guile *x=GET_X(instance);

  if(x->isinited==true) goto exit;

  x->num_ins=GET_INTEGER(num_ins);
  x->inlets=calloc(sizeof(t_k_guile_workaround*),x->num_ins);

  for(lokke=1;lokke<x->num_ins;lokke++){
    t_k_guile_workaround *x2;
    x2=(t_k_guile_workaround*)pd_new(k_guile_workaroundclass);
    x->inlets[lokke]=x2;
    x2->x=x;
    x2->index=lokke;
    x2->inlet=inlet_new(&x->x_ob,(t_pd*)x2,0,0);
  }

 exit:
  RU_;
}
static SCM gpd_outlets(SCM instance,SCM num_outs){
  int lokke;
  t_k_guile *x=GET_X(instance);

  if(x->isinited==true) goto exit;

  x->num_outs=GET_INTEGER(num_outs);
  x->outlets=calloc(sizeof(t_outlet*),x->num_outs);

  for(lokke=0;lokke<x->num_outs;lokke++){
    x->outlets[lokke] = outlet_new(&x->x_ob, gensym("anything"));
  }

 exit:
  RU_;
}

static SCM gpd_inited_p(SCM instance){
  t_k_guile *x=GET_X(instance);
  if(x->isinited==true) return SCM_BOOL_T;
  return SCM_BOOL_F;
}
static SCM gpd_get_num_inlets(SCM instance){
  t_k_guile *x=GET_X(instance);
  return MAKE_INTEGER(x->num_ins);
}
static SCM gpd_get_num_outlets(SCM instance){
  t_k_guile *x=GET_X(instance);
  return MAKE_INTEGER(x->num_outs);
}


/*****************************************************************************************************
 *****************************************************************************************************
 *    Binding and unbinding. Called from the guile side. 
 *****************************************************************************************************
 *****************************************************************************************************/

static SCM gpd_bind(SCM symname,SCM func){
  t_k_guile_workaround *x2;
  x2=(t_k_guile_workaround*)pd_new(k_guile_workaroundclass);
  x2->index=-1;
  x2->func=func;
  scm_protect_object(x2->func);
  pd_bind((t_pd *)x2, MAKE_SYM(symname));
  return MAKE_POINTER(x2);
}
static SCM gpd_unbind(SCM scm_x2,SCM symname){
  t_k_guile_workaround *x2=GET_POINTER(scm_x2);
  pd_unbind((t_pd *)x2,MAKE_SYM(symname));
  scm_unprotect_object(x2->func);
  pd_free((t_pd*)x2);
  RU_;
}






/*****************************************************************************************************
 *****************************************************************************************************
 *    Got data from the guile side. Distributing to outlets or receivers.
 *    The guile side is responsible for checking that the arguments are correct.
 *****************************************************************************************************
 *****************************************************************************************************/

#define GET_CLASS() (INTEGER_P(symbol)?(t_symbol*)GET_POINTER(symbol):MAKE_SYM(symbol))->s_thing
#define CLASS_INIT t_class **s=GET_CLASS();if(s==NULL) post("no receiver"); else 
#define GET_OUTLET() GET_X(instance)->outlets[GET_INTEGER(outlet)]


/* Number -> float */
static SCM gpd_outlet_number(SCM instance,SCM outlet,SCM val){
  outlet_float(GET_OUTLET(),scm_num2dbl(val,"gpd_outlet"));
  RU_;
}


static SCM gpd_send_number(SCM symbol,SCM val){
  CLASS_INIT
    pd_float(s,scm_num2dbl(val,"gpd_send_number"));
  RU_;
}


/* List -> list */
static t_atom *make_list(t_atom *atom,SCM val){
  int lokke;
  int length=GET_INTEGER(scm_length(val));

  for(lokke=0;lokke<length;lokke++){
    SCM el=scm_list_ref(val,MAKE_INTEGER(lokke));
    t_atom *to=&atom[lokke];
    if(SCM_INUMP(el)){
      SETFLOAT(to,(float)GET_INTEGER(el));
    }else{
      if(SCM_UNBNDP(el)){
	SETSYMBOL(to,gensym("undefined"));
      }else{
	if(SCM_STRINGP(el)){
	  SETSYMBOL(to,gensym(SCM_STRING_CHARS(el)));
	}else{
	  if(SCM_SYMBOLP(el)){
	    SETSYMBOL(to,MAKE_SYM(el));
	  }else{
	    if(scm_number_p(el)){
	      if(scm_real_p(el)){
		SETFLOAT(to,(float)scm_num2dbl(el,"gpd_outlet_or_send_list"));
	      }else{
		post("Illegal argument to gdp_outlet_or_send_list. Setting atom to 0.");
		SETFLOAT(to,0.0f);
	      }
	    }
	  }
	}
      }
    }
  }
  return atom;
}
static SCM gpd_outlet_list(SCM instance,SCM outlet,SCM val){
  int length=GET_INTEGER(scm_length(val));
  t_atom atom[length];
  outlet_list(GET_OUTLET(), &s_list,length,make_list(atom,val));
  RU_;
}
static SCM gpd_send_list(SCM symbol,SCM val){
  int length=GET_INTEGER(scm_length(val));
  t_atom atom[length];
  CLASS_INIT
    pd_list(s, &s_list,length,make_list(atom,val));
  RU_;
}

/* Symbol -> symbol */
static SCM gpd_outlet_symbol(SCM instance,SCM outlet,SCM val){
  outlet_symbol(GET_OUTLET(),MAKE_SYM(val));
  RU_;
}
static SCM gpd_send_symbol(SCM symbol,SCM val){
  CLASS_INIT
    pd_symbol(s,MAKE_SYM(val));
  RU_;
}

/* String -> symbol */
static SCM gpd_outlet_string(SCM instance,SCM outlet,SCM val){
  outlet_symbol(GET_OUTLET(),gensym(SCM_STRING_CHARS(val)));
  RU_;
}
static SCM gpd_send_string(SCM symbol,SCM val){
  CLASS_INIT
    pd_symbol(s,gensym(SCM_STRING_CHARS(val)));
  RU_;
}

/* Bang -> bang */
static SCM gpd_outlet_bang(SCM instance,SCM outlet){
  outlet_bang(GET_OUTLET());
  RU_;
}
static SCM gpd_send_bang(SCM symbol){
  CLASS_INIT
    pd_bang(s);
  RU_;
}

/* <- symbol */
static SCM gpd_get_symbol(SCM symname){
  return MAKE_POINTER(MAKE_SYM(symname));
}




/*****************************************************************************************************
 *****************************************************************************************************
 *    Setting up global guile functions.
 *****************************************************************************************************
 *****************************************************************************************************/

static void k_guile_init(void){
  char *command=
#include "global_scm.txt"
    ;

  scm_init_guile();
  scm_c_define_gsubr("pd-c-outlets",2,0,0,gpd_outlets);
  scm_c_define_gsubr("pd-c-inlets",2,0,0,gpd_inlets);
  scm_c_define_gsubr("pd-c-inited?",1,0,0,gpd_inited_p);
  scm_c_define_gsubr("pd-c-get-num-inlets",1,0,0,gpd_get_num_inlets);
  scm_c_define_gsubr("pd-c-get-num-outlets",1,0,0,gpd_get_num_outlets);
  scm_c_define_gsubr("pd-c-set-inlet-func",2,0,0,gpd_set_inlet_func);
  scm_c_define_gsubr("pd-c-set-cleanup-func",2,0,0,gpd_set_cleanup_func);
  scm_c_define_gsubr("pd-c-bind",2,0,0,gpd_bind);
  scm_c_define_gsubr("pd-c-unbind",2,0,0,gpd_unbind);
  scm_c_define_gsubr("pd-c-outlet-number",3,0,0,gpd_outlet_number);
  scm_c_define_gsubr("pd-c-outlet-list",3,0,0,gpd_outlet_list);
  scm_c_define_gsubr("pd-c-outlet-symbol",3,0,0,gpd_outlet_symbol);
  scm_c_define_gsubr("pd-c-outlet-string",3,0,0,gpd_outlet_string);
  scm_c_define_gsubr("pd-c-outlet-bang",2,0,0,gpd_outlet_bang);
  scm_c_define_gsubr("pd-c-send-number",2,0,0,gpd_send_number);
  scm_c_define_gsubr("pd-c-send-list",2,0,0,gpd_send_list);
  scm_c_define_gsubr("pd-c-send-symbol",2,0,0,gpd_send_symbol);
  scm_c_define_gsubr("pd-c-send-string",2,0,0,gpd_send_string);
  scm_c_define_gsubr("pd-c-send-bang",1,0,0,gpd_send_bang);
  scm_c_define_gsubr("pd-c-get-symbol",1,0,0,gpd_get_symbol);

  EVAL(command);

  pd_backtrace_run=EVAL("pd-backtrace-run");
  scm_permanent_object(pd_backtrace_run);

  pd_backtrace_run1=EVAL("pd-backtrace-run1");
  scm_permanent_object(pd_backtrace_run1);

  pd_backtrace_run2=EVAL("pd-backtrace-run2");
  scm_permanent_object(pd_backtrace_run2);

  pd_backtrace_run3=EVAL("pd-backtrace-run3");
  scm_permanent_object(pd_backtrace_run3);

  pd_backtrace_run4=EVAL("pd-backtrace-run4");
  scm_permanent_object(pd_backtrace_run4);
}





/*****************************************************************************************************
 *****************************************************************************************************
 *    Starting and stopping new guile script
 *****************************************************************************************************
 *****************************************************************************************************/

static bool k_guile_load(t_k_guile *x,char *filename){
  bool ret=true;
  
  FILE *file=fopen(filename,"r");
  if(file==NULL){
    post("file \"%s\" not found.\n",filename);
    return false;
  }


  // Let the file live in its own name-space, or something like that.
  eval2("(define (pd-instance-func pd-instance)");
  eval2(
#include "local_scm.txt"
);
  eval_file(file);
  eval2("  (pd-set-inlet-func)(pd-set-cleanup-func))");
  eval2("1");

  if(
     1!=GET_INTEGER(eval_do())
     || 1!=GET_INTEGER(scm_call_2(pd_backtrace_run1,EVAL("pd-instance-func"),MAKE_POINTER(x)))
     )
    {
      post("Failed.");
      ret=false;
    }

  fclose(file);

  return ret;
}

static void *k_guile_new(t_symbol *s){
  int lokke;
  t_k_guile *x = (t_k_guile *)pd_new(k_guile_class);
  x->filename=s->s_name;
  x->isinited=false;

  if(k_guile_load(x,x->filename)==true){
    x->isinited=true;
    return x;
  }

  return NULL;
}

static void k_guile_free(t_k_guile *x){
  int lokke;
  scm_call_1(pd_backtrace_run,x->cleanup_func);
  for(lokke=1;lokke<x->num_ins;lokke++){
    inlet_free(x->inlets[lokke]->inlet);
    pd_free((t_pd*)x->inlets[lokke]);
  }
  for(lokke=0;lokke<x->num_outs;lokke++){
    outlet_free(x->outlets[lokke]);
  }
  scm_gc_unprotect_object(x->inlet_func);
  scm_gc_unprotect_object(x->cleanup_func);

  free(x->inlets);
  free(x->outlets);
}


static void k_guile_reload(t_k_guile *x){
  scm_call_1(pd_backtrace_run,x->cleanup_func);
  scm_gc_unprotect_object(x->inlet_func);
  scm_gc_unprotect_object(x->cleanup_func);
  k_guile_load(x,x->filename);
}



/*****************************************************************************************************
 *****************************************************************************************************
 *    Das setup
 *****************************************************************************************************
 *****************************************************************************************************/
void k_guile_setup(void){

  k_guile_init();

  k_guile_class = class_new(gensym("k_guile"), (t_newmethod)k_guile_new,
			   (t_method)k_guile_free, sizeof(t_k_guile), 0, A_DEFSYM, 0);

  class_addanything(k_guile_class, (t_method)k_guile_anything_first);
  class_addmethod(k_guile_class, (t_method)k_guile_reload, gensym("reload"), 0);
  class_sethelpsymbol(k_guile_class, gensym("help-k_guile.pd"));


  /* This trick(?) is taken from the flext source. (I don't understand what happens...) */
  k_guile_workaroundclass=class_new(gensym("indexworkaround"),NULL,NULL,sizeof(t_k_guile_workaround),CLASS_PD|CLASS_NOINLET, A_NULL);
  class_addanything(k_guile_workaroundclass,k_guile_anything);

 
  post(version);
}