From e1da63276dc159532c0e5258f69a5365568f598f Mon Sep 17 00:00:00 2001 From: Hans-Christoph Steiner Date: Thu, 15 Dec 2005 07:43:25 +0000 Subject: This commit was generated by cvs2svn to compensate for changes in r4219, which included commits to RCS files with non-trunk default branches. svn path=/trunk/externals/pdp/; revision=4220 --- guile/Makefile | 24 ++ guile/README | 73 ++++++ guile/example.pd | 36 +++ guile/example.scm | 12 + guile/pdp_guile.c | 705 ++++++++++++++++++++++++++++++++++++++++++++++++++++ guile/pdp_guile.scm | 37 +++ guile/testguile.pd | 38 +++ 7 files changed, 925 insertions(+) create mode 100644 guile/Makefile create mode 100644 guile/README create mode 100644 guile/example.pd create mode 100644 guile/example.scm create mode 100644 guile/pdp_guile.c create mode 100644 guile/pdp_guile.scm create mode 100644 guile/testguile.pd (limited to 'guile') diff --git a/guile/Makefile b/guile/Makefile new file mode 100644 index 0000000..269f339 --- /dev/null +++ b/guile/Makefile @@ -0,0 +1,24 @@ +current: pd_linux + +pd_linux: pdp_guile.pd_linux + +.SUFFIXES: .pd_linux + +LINUXCFLAGS = -DPD -O2 -funroll-loops -fomit-frame-pointer \ + -Wall -W -Wstrict-prototypes -Werror \ + -Wno-unused -Wno-parentheses -Wno-switch # -Wshadow + +LINUXINCLUDE = -I../distro/pd/src -Idbot -I../include + +.c.pd_linux: + gcc $(LINUXCFLAGS) $(LINUXINCLUDE) -o $*.o -c $*.c + gcc -export_dynamic -shared -o $*.pd_linux $*.o -lm \ + -lguile #-lguile-ltdl -lqthreads -lpthread -lcrypt + + strip --strip-unneeded $*.pd_linux + rm $*.o + +clean: + rm -f *.pd_linux + rm -f *~ + diff --git a/guile/README b/guile/README new file mode 100644 index 0000000..8a90cd9 --- /dev/null +++ b/guile/README @@ -0,0 +1,73 @@ +PDP_GUILE - a scheme interpreter for pd/pdp + +Copyright (c) by Tom Schouten + +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., 675 Mass Ave, Cambridge, MA 02139, USA. + +The GNU Public Licence can be found in the file COPYING + +--- + +pdp_guile starts a scheme interpreter is started on pd's standard io. +there is a simple send/receive interface in pd to communicate with the +running scheme interpreter trough an input and output queue. pd can +send messages, including pdp packets, to guile with the [ss tag] object. + +guile can read using the (in) fuction, which returs a two element list: +the tag and the object (a float, a symbol, a list or a packet) i.e. if +you connect a [pdp_v4l] object to a [ss some-tag-symbol] object and bang +the v4l object, you can retreive the packet in guile using something +like this: + +(in) +=> (some-tag-symbol #) + +(in) retreives the oldest message from the input queue. if there are no +more messages, (in) returns #f + +guile can write using the (out tag object) function, which will send the +object to a [r tag] pd reciever. i.e. if you connect a +[r some-tag-symbol] object to a [pdp_xv] object, you can display a +packet (here contained in variable p) by doing: + +(out 'some-tag-symbol p) + + +guile is connected to pdp's forth scripting language (pdp's "rpn +calculator") using the (forth stack wordlist) statement. it returns the +processed stack. i.e.: + +(define p0 (make-pdp 'image/grey/320x240)) +(define p1 (make-pdp 'image/grey/320x240)) +(forth `(,p0 ,p1) '(add)) +=> (#) + + +see pdp_guile.scm and pdp_guile.pd for an example of how pdp_guile +could be used. + +this is mainly for experimental interactive work and testing pdp's forth +scripting. there's no documentation, apart from this file, the example +and the source code. if you like to have more info, just drop me a +line. + +if you want to write externals in scheme, this is probably not for you. + +requirements: libguile 1.6.x + + +enjoy, + +tom diff --git a/guile/example.pd b/guile/example.pd new file mode 100644 index 0000000..ee545e5 --- /dev/null +++ b/guile/example.pd @@ -0,0 +1,36 @@ +#N canvas 135 3 467 427 10; +#X obj 90 309 pdp_xv; +#X obj 90 170 bng 15 250 50 0 empty empty empty 0 -6 0 8 -262144 -1 +-1; +#X obj 90 202 pdp_v4l; +#X obj 169 128 metro 10; +#X obj 90 285 r out-vid; +#X obj 90 237 ss in-vid; +#X obj 250 206 ss control; +#X msg 248 177 stop; +#X msg 292 177 gc; +#X obj 293 142 metro 1000; +#X msg 304 48 stop; +#X msg 162 80 1; +#X msg 193 80 0; +#X obj 101 48 r start; +#X text 283 29 pd controls stop; +#X text 233 229 scheme control port; +#X text 29 28 scheme interpreter controls start; +#X text 20 372 load "example.scm" in the guile dir to use this patch +; +#X text 82 262 scheme code; +#X connect 1 0 2 0; +#X connect 2 0 5 0; +#X connect 3 0 2 0; +#X connect 4 0 0 0; +#X connect 7 0 6 0; +#X connect 8 0 6 0; +#X connect 9 0 8 0; +#X connect 10 0 7 0; +#X connect 10 0 12 0; +#X connect 11 0 3 0; +#X connect 11 0 9 0; +#X connect 12 0 3 0; +#X connect 12 0 9 0; +#X connect 13 0 11 0; diff --git a/guile/example.scm b/guile/example.scm new file mode 100644 index 0000000..3963c76 --- /dev/null +++ b/guile/example.scm @@ -0,0 +1,12 @@ +; load event handler +(load "pdp_guile.scm") + + +; input - output video plug +(add-input! 'in-vid + (lambda (thing) + (out 'out-vid thing))) + + +; start the input loop +(start) diff --git a/guile/pdp_guile.c b/guile/pdp_guile.c new file mode 100644 index 0000000..34ca8da --- /dev/null +++ b/guile/pdp_guile.c @@ -0,0 +1,705 @@ +/* + * Pure Data Packet module: Guile Interpreter for pd/pdp + * Copyright (c) by Tom Schouten + * + * 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., 675 Mass Ave, Cambridge, MA 02139, USA. + * + */ + + +#include +#include +#include +#include "pdp.h" +#include "pdp_forth.h" + +#define D if(0) + + + +/* communication stuff */ + +static t_class *guile_class; + +pthread_mutex_t guile_mux; + +t_pdp_list *guile_inlist; +t_pdp_list *guile_outlist; +t_clock *guile_clock; +t_float guile_clock_deltime; + + +/* GUILE GLUE CODE */ + +static scm_t_bits pdp_tag; + +typedef struct _pdp_scm_wrapper +{ + int packet; + SCM update_func; + //char dummy[1000000]; +} t_pdp_scm_wrapper; + + +/* list (comm queue) utility stuff */ + +static void guile_list_send(t_pdp_list *list, t_pdp_symbol *tag, t_pdp_word_type type, t_pdp_word word) +{ + pthread_mutex_lock(&guile_mux); + pdp_list_add_back(list, a_symbol, (t_pdp_word)tag); + pdp_list_add_back(list, type, word); + pthread_mutex_unlock(&guile_mux); +} + +static int guile_list_receive(t_pdp_list *list, t_pdp_symbol **tag, t_pdp_word_type *type, t_pdp_word *word) +{ + int success = 0; + if (pdp_list_size(list)){ + pthread_mutex_lock(&guile_mux); + *tag = pdp_list_pop(list).w_symbol; + *type = list->first->t; + *word = pdp_list_pop(list); + pthread_mutex_unlock(&guile_mux); + success = 1; + } + return success; + +} + +/* pdp list <-> scm list conversion */ + +/* any packets contained in the pdp list are copied ro */ + +static SCM pdp_to_scm (t_pdp_list *l) +{ + SCM pair = SCM_EOL; //temporary pair + SCM thing; //thing to add to the list + t_pdp_list *cl = pdp_list_copy_reverse(l); //make a reverse copy of the list + t_pdp_atom *a; + t_pdp_scm_wrapper *pg; + + for(a=cl->first;a;a=a->next){ + + // convert the atom to a lisp scalar + switch (a->t){ + case a_list: + thing = pdp_to_scm(a->w.w_list); break; + case a_int: + thing = SCM_MAKINUM(a->w.w_int); break; + case a_symbol: + thing = scm_str2symbol(a->w.w_symbol->s_name); break; + case a_float: + thing = scm_make_real (a->w.w_float); break; + case a_packet: + //post("ATTENTION: pdp_to_scm copies packets"); + pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp"); + pg->packet = pdp_packet_copy_ro(a->w.w_packet); + pg->update_func = SCM_BOOL_F; + SCM_NEWSMOB (thing, pdp_tag, pg); + break; + default: + thing = scm_str2symbol("undef"); break; + } + + // add the atom to the list + pair = scm_cons(thing, pair); // add thing + + } + + // + + // return the list + return pair; +} + +/* any packets contained in the list are copied ro */ +static t_pdp_list *scm_to_pdp (SCM pair) +{ + t_pdp_list *l = pdp_list_new(0); + SCM rest = pair; + SCM head; + while (1){ + if (!SCM_CONSP(rest)){ + head = rest; + rest = SCM_EOL; + } + else { + head = SCM_CAR(rest); + rest = SCM_CDR(rest); + } + if (SCM_NULLP(head)) break; + + else if (SCM_CONSP(head)){ + pdp_list_add_back(l, a_list, (t_pdp_word)scm_to_pdp(head)); + } + else if (SCM_SMOB_PREDICATE(pdp_tag, head)){ + t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (head); + //post("ATTENTION: scm_to_pdp copies packets"); + pdp_list_add_back(l, a_packet, + (t_pdp_word)(pdp_packet_copy_ro(pg->packet))); + } + else if (SCM_INUMP(head)){ + int i = SCM_INUM(head); + pdp_list_add_back(l, a_int, (t_pdp_word)i); + } + else if (SCM_REALP(head)){ + float f = (float)SCM_REAL_VALUE(head); + pdp_list_add_back(l, a_float, (t_pdp_word)f); + } + else if (SCM_SYMBOLP(head)){ + pdp_list_add_back(l, a_symbol, + (t_pdp_word)pdp_gensym(SCM_SYMBOL_CHARS(head))); + } + else { + pdp_list_add_back(l, a_undef, (t_pdp_word)0); + } + } + return l; +} + + + + +/* smob callbacks */ + +static SCM mark_pdp (SCM pdp_smob) +{ + /* Mark the image's name and update function. */ + t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob); + scm_gc_mark (pg->update_func); + D post("mark_pdp called"); + return SCM_BOOL_F; +} + +static size_t free_pdp (SCM pdp_smob) +{ + t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob); + pdp_packet_mark_unused(pg->packet); + scm_must_free(pg); + D post("free_pdp called"); + return sizeof(t_pdp_scm_wrapper); +} + + +static int +print_pdp (SCM pdp_smob, SCM port, scm_print_state *pstate) +{ + t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob); + char tmp[1000]; + t_pdp *h = pdp_packet_header(pg->packet); + tmp[999] = 0; + snprintf(tmp, 999, "#", pg->packet, + h && h->desc ? h->desc->s_name : "unknown"); + scm_puts(tmp, port); + D post ("print_pdp called"); + return 1; +} + + +/* extension functions */ + + +static SCM +forth_pdp (SCM stack, SCM program) +{ + t_pdp_word_error e; + t_pdp_list *s = scm_to_pdp (stack); + t_pdp_list *p = scm_to_pdp (program); + e = pdp_forth_execute_def(s, p); + stack = pdp_to_scm(s); + + if (e){ + post("ERROR: program evaluation aborted with error %d.", e); + } + pdp_tree_strip_packets(s); + pdp_tree_strip_packets(p); + + return stack; + +} + +static SCM +define_forth_word_pdp (SCM word, SCM in, SCM out, SCM program) +{ + t_pdp_word_error e; + t_pdp_list *p; + t_pdp_symbol *s; + SCM_ASSERT (SCM_SYMBOLP(word), word, SCM_ARG1, "define-forth-word"); + SCM_ASSERT (SCM_INUMP(in), word, SCM_ARG2, "define-forth-word"); + SCM_ASSERT (SCM_INUMP(out), word, SCM_ARG3, "define-forth-word"); + p = scm_to_pdp (program); + s = pdp_gensym(SCM_SYMBOL_CHARS(word)); + pdp_forthdict_add_word(s, p, SCM_INUM(in), SCM_INUM(out), -1, 0); + + return SCM_UNSPECIFIED; + +} + + +static SCM +unmark_pdp (SCM pdp_smob) +{ + t_pdp_scm_wrapper *pg; + SCM_ASSERT (SCM_SMOB_PREDICATE (pdp_tag, pdp_smob), + pdp_smob, SCM_ARG1, "mark-unused"); + pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob); + pdp_packet_mark_unused(pg->packet); + pg->packet = -1; + return SCM_UNSPECIFIED; +} + + + + +static SCM +is_writable_pdp (SCM pdp_smob) +{ + t_pdp_scm_wrapper *pg; + SCM_ASSERT (SCM_SMOB_PREDICATE (pdp_tag, pdp_smob), + pdp_smob, SCM_ARG1, "writable?"); + pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (pdp_smob); + if (pdp_packet_writable(pg->packet)) return SCM_BOOL_T; + else return SCM_BOOL_F; + return SCM_UNSPECIFIED; +} + +static SCM +make_pdp (SCM type) +{ + int p; + t_pdp_scm_wrapper *pg; + char *t; + + /* construct with type */ + if (SCM_SYMBOLP(type)){ + t = SCM_SYMBOL_CHARS(type); + p = pdp_factory_newpacket(pdp_gensym(t)); + } + /* copy construct from packet id */ + else if (SCM_INUMP(type)){ + int i = SCM_INUM(type); + p = pdp_packet_copy_ro(i); + } + else { + SCM_ASSERT (0, type, SCM_ARG1, "make-pdp"); + } + + /* check if valid packet */ + SCM_ASSERT (p != -1, type, SCM_ARG1, "make-pdp"); + + /* build smob */ + pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp"); + pg->packet = p; + pg->update_func = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (pdp_tag, pg); +} + +static SCM +_in (void) +{ + + t_pdp_scm_wrapper *pg; + t_pdp_word w; + t_pdp_symbol *stag; + t_pdp_word_type type = a_undef; + int skip = 1; + + SCM tag; + SCM thing; + SCM pair; + + D post("receiving pdp packet"); + + if (!guile_list_receive(guile_inlist, &stag, &type, &w)) goto exit; + tag = scm_str2symbol(stag->s_name); + + switch(type){ + case a_packet: + pg = (t_pdp_scm_wrapper *) scm_must_malloc (sizeof (t_pdp_scm_wrapper), "pdp"); + pg->packet = w.w_packet; + pg->update_func = SCM_BOOL_F; + SCM_NEWSMOB (thing, pdp_tag, pg); + break; + case a_symbol: + thing = scm_str2symbol(w.w_symbol->s_name); + break; + case a_float: + thing = scm_make_real (w.w_float); + break; + + default: + goto exit; + + } + pair = scm_cons2(tag, thing, SCM_EOL); + return pair; + + + exit: + return SCM_BOOL_F; +} + +static SCM +_out (SCM tag, SCM thing) +{ + t_pdp_symbol *stag; + SCM_ASSERT (SCM_SYMBOLP (tag), tag, SCM_ARG1, "out"); + stag = pdp_gensym(SCM_SYMBOL_CHARS(tag)); + + if (SCM_SMOB_PREDICATE(pdp_tag, thing)){ + t_pdp_scm_wrapper *pg = (t_pdp_scm_wrapper *) SCM_SMOB_DATA (thing); + guile_list_send(guile_outlist, stag, a_packet, + (t_pdp_word)(pdp_packet_copy_ro(pg->packet))); + } + else if (SCM_INUMP(thing)){ + int i = SCM_INUM(thing); + guile_list_send(guile_outlist, stag, a_int, (t_pdp_word)i); + } + else if (SCM_REALP(thing)){ + float f = (float)SCM_REAL_VALUE(thing); + guile_list_send(guile_outlist, stag, a_float, (t_pdp_word)f); + } + else if (SCM_SYMBOLP(thing)){ + char *s = SCM_SYMBOL_CHARS(thing); + guile_list_send(guile_outlist, stag, a_symbol, (t_pdp_word)(pdp_gensym(s))); + } + else if (SCM_CONSP(thing)){ + t_pdp_list *l = scm_to_pdp(thing); + guile_list_send(guile_outlist, stag, a_list, (t_pdp_word)l); + } + else{ + SCM_ASSERT (0, thing, SCM_ARG2, "out"); + } + + return SCM_BOOL_T; + +} + + +static SCM +test_pdp (SCM thing) +{ + if (SCM_SMOB_PREDICATE(pdp_tag, thing)) return SCM_BOOL_T; + else return SCM_BOOL_F; +} +static SCM +printdebugforthword_pdp (SCM thing) +{ + t_pdp_symbol *s; + t_pdp_atom *a; + SCM_ASSERT (SCM_SYMBOLP(thing), thing, SCM_ARG1, "pdp-debug-forth-word"); + s = pdp_gensym(SCM_SYMBOL_CHARS(thing)); + + pdp_forth_word_print_debug(s); + + return SCM_UNSPECIFIED; + +} + +static SCM +printdebug_pdp (SCM thing) +{ + if (SCM_INUMP(thing)){ + int p = SCM_INUM(thing); + pdp_packet_print_debug(p); + return SCM_UNSPECIFIED; + } + + SCM_ASSERT (SCM_SMOB_PREDICATE(pdp_tag, thing), thing, SCM_ARG1, "pdp-debug-packet"); + pdp_packet_print_debug(((t_pdp_scm_wrapper *) SCM_SMOB_DATA (thing))->packet); + return SCM_UNSPECIFIED; + +} +/* the inner main function. when this is called, guile + is initialized. when this function returns, exit(0) + is called. */ +static void guile_inner_main(void *closure, int argv, char **argc) +{ + /* initialize data types and functions */ + pdp_tag = scm_make_smob_type ("pdp", sizeof(t_pdp_scm_wrapper)); + scm_set_smob_free (pdp_tag, free_pdp); + scm_set_smob_print (pdp_tag, print_pdp); + scm_set_smob_mark (pdp_tag, mark_pdp); + + /* pdp stuff */ + scm_c_define_gsubr ("make-pdp", 1, 0, 0, make_pdp); + scm_c_define_gsubr ("writable?", 1, 0, 0, is_writable_pdp); + scm_c_define_gsubr ("pdp?", 1, 0, 0, test_pdp); + + /* communication */ + scm_c_define_gsubr ("in", 0, 0, 0, _in); + scm_c_define_gsubr ("out", 2, 0, 0, _out); + + /* pdp forth link */ + scm_c_define_gsubr ("forth", 2, 0, 0, forth_pdp); + scm_c_define_gsubr ("define-forth-word", 4, 0, 0, define_forth_word_pdp); + + /* debug methods */ + scm_c_define_gsubr ("mark-unused", 1, 0, 0, unmark_pdp); + scm_c_define_gsubr ("pdp-debug-packet", 1, 0, 0, printdebug_pdp); + scm_c_define_gsubr ("pdp-debug-forth-word", 1, 0, 0, printdebugforthword_pdp); + + /* start the shell */ + scm_c_eval_string("(set! scm-repl-prompt \"pdp> \")"); + + //scm_c_eval_string("(load \"/home/tom/.guile\")"); + //while(1) { + //post("read evaluate print loop"); + //scm_c_eval_string("(display scm-repl-prompt)(display (eval (read) (current-module)))(newline)"); + //} + + scm_shell(0,0); +} + + +/* the outer main function for booting the guile system + this is a separate thread */ +static void *guile_main(void *x) +{ + scm_boot_guile(0,0,guile_inner_main,0); + return 0; +} + + +/* start the thread that boots the guile system */ +static void guile_boot_in_thread(void) +{ + pthread_t thread; + pthread_attr_t attr; + + pthread_attr_init(&attr); + pthread_attr_setschedpolicy(&attr, SCHED_OTHER); + pthread_create(&thread, &attr, guile_main, 0); + +} + + +/* some restrictions on the pdp -> pd list conversion: + + - due to the nature of the pdp protocol in pd (3 phase) + a packet can not appear in a pd list. it will be sent out + as a pdp packet to the receiver corresponding to the tag. + the legal way to send a packet from guile is (out 'tag packet) + + - pd lists cannot be recursive, so pdp trees will need to be + flattened first. +*/ + +/* this sends a (flat pdp list) to a pd receiver + the list cannot contain pdp packets */ +static void pd_pdplist(void *thing, t_symbol *tag, t_pdp_list *l, int elements){ + t_atom pd_atom[elements]; + int i; + t_pdp_atom *a = l->first; + for (i=0; inext){ + switch(a->t){ + case a_float: + SETFLOAT(pd_atom+i, a->w.w_float); break; + case a_int: + SETFLOAT(pd_atom+i, (float)a->w.w_int); break; + case a_pointer: + SETPOINTER(pd_atom+i, a->w.w_pointer); break; + case a_symbol: + SETSYMBOL(pd_atom+i, gensym(a->w.w_symbol->s_name)); break; + case a_packet: + post("ERROR: can't put packet %d inside a pd list (not a pd atom)", + a->w.w_packet); + SETSYMBOL(pd_atom+i, gensym("deadpacket")); break; + case a_list: + post("ERROR: can't put a list inside a pd list (not a pd atom):"); + pdp_list_print(a->w.w_list); + SETSYMBOL(pd_atom+i, gensym("deadlist")); break; + default: + SETSYMBOL(pd_atom+i, gensym("undef")); break; + + } + } + typedmess(thing, tag, elements, pd_atom); + + + pdp_tree_strip_packets(l); + pdp_tree_free(l); +} + + + +static void guile_callback(void *dummy) +{ + int skip = 1; + t_pdp_symbol *s = 0; + t_pdp_word_type type = a_undef; + t_pdp_word w; + t_atom atom[3]; + void *thing; + + t_symbol *tag_sym; + + if (!guile_list_receive(guile_outlist, &s, &type, &w)) goto exit; + + tag_sym = gensym(s->s_name); + thing = tag_sym->s_thing; + + //post("got something from guile"); + + if (!thing) goto exit; + + + + /* send to outlet */ + switch(type){ + case a_packet: + SETFLOAT(atom+1, (float)w.w_packet); + SETSYMBOL(atom+0, pdp_sym_rro()); + typedmess(thing, pdp_sym_pdp(), 2, atom); + SETSYMBOL(atom+0, pdp_sym_rrw()); + typedmess(thing, pdp_sym_pdp(), 2, atom); + SETSYMBOL(atom+0, pdp_sym_prc()); + typedmess(thing, pdp_sym_pdp(), 2, atom); + pdp_packet_mark_unused(w.w_packet); + break; + + case a_float: + pd_float(thing, w.w_float); + break; + + case a_int: + pd_float(thing, (float)w.w_int); + break; + + case a_symbol: + pd_symbol(thing, gensym(w.w_symbol->s_name)); + break; + + case a_list:{ + int elements = w.w_list->elements; + t_symbol *tag; + + if (elements){ + /* if first element is a symbol, we use it to tag the list */ + if (w.w_list->first->t == a_symbol){ + tag = gensym(w.w_list->first->w.w_symbol->s_name); + elements--; + pdp_list_pop(w.w_list); + pd_pdplist(thing, tag, w.w_list, elements); + } + /* else tag it as "list" */ + else { + pd_pdplist(thing, gensym("list"), w.w_list, elements); + + } + } + else{ //an empty list is a bang + pd_bang(thing); + } + break; + } + + default: + break; + } + + exit: + clock_delay(guile_clock, guile_clock_deltime); +} + + + +/* PD INTERFACE OBJECT */ + +t_class *scheme_send_class; + +typedef struct _scheme_send +{ + t_object x_obj; + t_outlet *x_outlet; + t_pdp_symbol *x_tag; +} t_scheme_send; + + +static void *scheme_send_new(t_symbol *s) +{ + t_scheme_send *x = 0; + x = (t_scheme_send *)pd_new(scheme_send_class); + + x->x_tag = (s == gensym("")) ? + x->x_tag = pdp_gensym("dummy") : pdp_gensym(s->s_name); + + return (void*)x; +} + +static void scheme_send_anything(t_scheme_send *x, t_symbol *s, int argc, t_atom *argv) +{ + void *thing = 0; + + if (s == &s_float && argc == 1 && argv[0].a_type == A_FLOAT){ + guile_list_send(guile_inlist, x->x_tag, a_float, + (t_pdp_word)argv[1].a_w.w_float); + } + + else if (s == &s_symbol && argc == 1 && argv[0].a_type == A_SYMBOL){ + guile_list_send(guile_inlist, x->x_tag, a_symbol, + (t_pdp_word)pdp_gensym(argv[0].a_w.w_symbol->s_name)); + } + + else if (argc == 0){ + guile_list_send(guile_inlist, x->x_tag, a_symbol, + (t_pdp_word)pdp_gensym(s->s_name)); + } + + else if (s == gensym("pdp") + && argc == 2 + && argv[0].a_type == A_SYMBOL + && argv[0].a_w.w_symbol == gensym("register_ro") + && argv[1].a_type == A_FLOAT){ + + guile_list_send(guile_inlist, x->x_tag, a_packet, + (t_pdp_word)pdp_packet_copy_ro((int)argv[1].a_w.w_float)); + } + +} + + + + +static void scheme_send_free(t_scheme_send *x) +{ +} + +void pdp_guile_setup(void) +{ + + post("PDP: scheme extension"); + + /* setup guile interpreter */ + guile_boot_in_thread(); + + /* setup communication stuff */ + guile_inlist = pdp_list_new(0); + guile_outlist = pdp_list_new(0); + + pthread_mutex_init(&guile_mux, NULL); + guile_clock_deltime = 1.0f; + guile_clock = clock_new(0, (t_method)guile_callback); + clock_delay(guile_clock, guile_clock_deltime); + + + + /* create interface class */ + scheme_send_class = class_new(gensym("ss"), (t_newmethod)scheme_send_new, + (t_method)scheme_send_free, sizeof(t_scheme_send), 0, A_DEFSYMBOL, A_NULL); + + class_addanything(scheme_send_class, scheme_send_anything); +} + diff --git a/guile/pdp_guile.scm b/guile/pdp_guile.scm new file mode 100644 index 0000000..8ca17f2 --- /dev/null +++ b/guile/pdp_guile.scm @@ -0,0 +1,37 @@ +; pdp_guile.scm - a simple event dispatcher to be used with pdp_guile + +; some global variables +(define input-hash (make-hash-table 31)) +(define input-loop-flag #t) +(define input-loop-interval-ms 10) + +; add an input handler +(define (add-input! tag handler) + (hashq-create-handle! input-hash tag handler)) + +; the main input dispatcher loop +(define (input-loop) + (while input-loop-flag + (usleep (* input-loop-interval-ms 1000)) + (let nextmsg ((msg (in))) + (if msg + (begin + (let ((fn (hashq-ref input-hash (car msg)))) + (if fn (fn (cadr msg)))) + (nextmsg (in))))))) + +(define (start) + (set! input-loop-flag #t) + (out 'start 'bang) + (input-loop)) + + +; the control message handler +(add-input! 'control + (lambda (thing) + (case thing + ('stop (set! input-loop-flag #f)) ; stop the input loop and return to interpreter + ('gc (gc))))) ; call the garbage collector + + + diff --git a/guile/testguile.pd b/guile/testguile.pd new file mode 100644 index 0000000..0ddb253 --- /dev/null +++ b/guile/testguile.pd @@ -0,0 +1,38 @@ +#N canvas 197 59 766 427 10; +#X obj 158 49 metro 1000; +#X obj 161 77 bng 15 250 50 0 empty empty empty 0 -6 0 8 -262144 -1 +-1; +#X obj 160 23 loadbang; +#X obj 128 235 pdp_xv; +#X obj 293 39 bng 15 250 50 0 empty empty empty 0 -6 0 8 -262144 -1 +-1; +#X obj 293 71 pdp_v4l; +#X obj 347 35 metro 10; +#X obj 345 12 bng 15 250 50 0 empty empty empty 0 -6 0 8 -262144 -1 +-1; +#X obj 72 210 r iet; +#X floatatom 72 238 5 0 0 0 - - -; +#X obj 128 211 r out-vid; +#X obj 293 106 ss in-vid; +#X obj 352 144 ss test; +#X obj 479 193 ss control; +#X msg 477 164 stop; +#X msg 521 164 gc; +#X obj 522 129 metro 1000; +#X obj 523 106 tgl 15 0 empty empty empty 0 -6 0 8 -262144 -1 -1 1 +1; +#X obj 522 81 loadbang; +#X connect 0 0 1 0; +#X connect 2 0 0 0; +#X connect 4 0 5 0; +#X connect 5 0 11 0; +#X connect 5 0 12 0; +#X connect 6 0 5 0; +#X connect 7 0 6 0; +#X connect 8 0 9 0; +#X connect 10 0 3 0; +#X connect 14 0 13 0; +#X connect 15 0 13 0; +#X connect 16 0 15 0; +#X connect 17 0 16 0; +#X connect 18 0 17 0; -- cgit v1.2.1