diff options
author | Miller Puckette <millerpuckette@users.sourceforge.net> | 2009-08-17 23:31:36 +0000 |
---|---|---|
committer | Miller Puckette <millerpuckette@users.sourceforge.net> | 2009-08-17 23:31:36 +0000 |
commit | 282671282b20fa17ab9dbbaba9d1cf2246b5029d (patch) | |
tree | f7af53ee269efd2564ca872a4da187e1ae687f3b /pd/src | |
parent | 76d1c8472e025126a4b3e1571f817198b2fec9f9 (diff) |
merge in new tcl implementation by Steiner & Chun
svn path=/trunk/; revision=11934
Diffstat (limited to 'pd/src')
39 files changed, 125 insertions, 5454 deletions
diff --git a/pd/src/configure.in b/pd/src/configure.in index bc5d5f7b..dfc1b862 100644 --- a/pd/src/configure.in +++ b/pd/src/configure.in @@ -195,7 +195,7 @@ dnl This should be fixed so Pd can use ALSA shared libraries where appropriate. LDFLAGS="$LDFLAGS -static" fi EXT=pd_linux - CPPFLAGS="-DDL_OPEN -DPA_USE_OSS -DUNIX -DUNISTD\ + CPPFLAGS="-DHAVE_LIBDL -DPA_USE_OSS -DUNIX -DHAVE_UNISTD_H\ -DUSEAPI_OSS \ -fno-strict-aliasing" SYSSRC="s_midi_oss.c s_audio_oss.c" @@ -273,7 +273,7 @@ then -framework AudioUnit -framework AudioToolbox \ -framework Carbon -framework CoreMIDI" EXT=pd_darwin - CPPFLAGS="-DDL_OPEN -DMACOSX -DUNISTD -I/usr/X11R6/include \ + CPPFLAGS="-DHAVE_LIBDL -DMACOSX -DHAVE_UNISTD_H -I/usr/X11R6/include \ -I../portaudio/include -I../portaudio/src/common \ -I../portaudio/src/os/mac_osx/ \ -I../portmidi/pm_common -I../portmidi/pm_mac \ diff --git a/pd/src/g_all_guis.c b/pd/src/g_all_guis.c index 6f196e34..f9314995 100644 --- a/pd/src/g_all_guis.c +++ b/pd/src/g_all_guis.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_bang.c b/pd/src/g_bang.c index 1e5d6604..8606b0ac 100644 --- a/pd/src/g_bang.c +++ b/pd/src/g_bang.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_editor.c b/pd/src/g_editor.c index 0fbce41a..7ef5266a 100644 --- a/pd/src/g_editor.c +++ b/pd/src/g_editor.c @@ -1421,7 +1421,7 @@ void canvas_doclick(t_canvas *x, int xpos, int ypos, int which, } } -void canvas_mousedown(t_canvas *x, t_floatarg xpos, t_floatarg ypos, +void canvas_mouse(t_canvas *x, t_floatarg xpos, t_floatarg ypos, t_floatarg which, t_floatarg mod) { canvas_doclick(x, xpos, ypos, which, mod, 1); @@ -2454,9 +2454,9 @@ bad: (sink? class_getname(pd_class(&sink->g_pd)) : "???")); } -#define XTOLERANCE 4 -#define YTOLERANCE 3 -#define NHIST 15 +#define XTOLERANCE 18 +#define YTOLERANCE 17 +#define NHIST 35 /* LATER might have to speed this up */ static void canvas_tidy(t_canvas *x) @@ -2514,10 +2514,10 @@ static void canvas_tidy(t_canvas *x) } } } - for (i = 1, besthist = 0, bestdist = 4, ip = histogram + 1; - i < (NHIST-1); i++, ip++) + for (i = 2, besthist = 0, bestdist = 4, ip = histogram + 2; + i < (NHIST-2); i++, ip++) { - int hit = ip[-1] + 2 * ip[0] + ip[1]; + int hit = ip[-2] + 2 * ip[-1] + 3 * ip[0] + 2* ip[1] + ip[2]; if (hit > besthist) { besthist = hit; @@ -2665,7 +2665,7 @@ static void glist_setlastxy(t_glist *gl, int xval, int yval) void g_editor_setup(void) { /* ------------------------ events ---------------------------------- */ - class_addmethod(canvas_class, (t_method)canvas_mousedown, gensym("mouse"), + class_addmethod(canvas_class, (t_method)canvas_mouse, gensym("mouse"), A_FLOAT, A_FLOAT, A_FLOAT, A_FLOAT, A_NULL); class_addmethod(canvas_class, (t_method)canvas_mouseup, gensym("mouseup"), A_FLOAT, A_FLOAT, A_FLOAT, A_NULL); diff --git a/pd/src/g_graph.c b/pd/src/g_graph.c index cfda6c2c..b4112ddd 100644 --- a/pd/src/g_graph.c +++ b/pd/src/g_graph.c @@ -8,7 +8,7 @@ to this file... */ #include <stdlib.h> #include "m_pd.h" -#include "t_tk.h" + #include "g_canvas.h" #include "s_stuff.h" /* for sys_hostfontsize */ #include <stdio.h> diff --git a/pd/src/g_hdial.c b/pd/src/g_hdial.c index ace2ce66..19d21e84 100644 --- a/pd/src/g_hdial.c +++ b/pd/src/g_hdial.c @@ -14,7 +14,7 @@ put out a "float" as in sliders, toggles, etc. */ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_hslider.c b/pd/src/g_hslider.c index 8dc3d0e6..143a8988 100644 --- a/pd/src/g_hslider.c +++ b/pd/src/g_hslider.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_mycanvas.c b/pd/src/g_mycanvas.c index 1040c11f..f673f8ed 100644 --- a/pd/src/g_mycanvas.c +++ b/pd/src/g_mycanvas.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_numbox.c b/pd/src/g_numbox.c index db25e918..75f6bbbf 100644 --- a/pd/src/g_numbox.c +++ b/pd/src/g_numbox.c @@ -10,7 +10,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_rtext.c b/pd/src/g_rtext.c index 63a7485b..976901e9 100644 --- a/pd/src/g_rtext.c +++ b/pd/src/g_rtext.c @@ -13,7 +13,7 @@ #include "m_pd.h" #include "s_stuff.h" #include "g_canvas.h" -#include "t_tk.h" + #define LMARGIN 2 #define RMARGIN 2 diff --git a/pd/src/g_text.c b/pd/src/g_text.c index f927bf38..cff52274 100644 --- a/pd/src/g_text.c +++ b/pd/src/g_text.c @@ -10,7 +10,7 @@ #include "m_pd.h" #include "m_imp.h" #include "s_stuff.h" -#include "t_tk.h" + #include "g_canvas.h" #include <stdio.h> #include <string.h> diff --git a/pd/src/g_toggle.c b/pd/src/g_toggle.c index 830e99cb..344e1522 100644 --- a/pd/src/g_toggle.c +++ b/pd/src/g_toggle.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_vdial.c b/pd/src/g_vdial.c index 9f7732f5..f5364750 100644 --- a/pd/src/g_vdial.c +++ b/pd/src/g_vdial.c @@ -13,7 +13,7 @@ put out a "float" as in sliders, toggles, etc. */ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_vslider.c b/pd/src/g_vslider.c index 87309029..6b547f84 100644 --- a/pd/src/g_vslider.c +++ b/pd/src/g_vslider.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/g_vumeter.c b/pd/src/g_vumeter.c index f0ec30aa..75047e8d 100644 --- a/pd/src/g_vumeter.c +++ b/pd/src/g_vumeter.c @@ -12,7 +12,7 @@ #include <ctype.h> #include "m_pd.h" #include "g_canvas.h" -#include "t_tk.h" + #include "g_all_guis.h" #include <math.h> diff --git a/pd/src/m_binbuf.c b/pd/src/m_binbuf.c index 05ef1888..360512d0 100644 --- a/pd/src/m_binbuf.c +++ b/pd/src/m_binbuf.c @@ -7,7 +7,7 @@ #include "m_pd.h" #include "s_stuff.h" #include <stdio.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #ifdef MSW diff --git a/pd/src/m_class.c b/pd/src/m_class.c index cd4fbb1c..93d9c71b 100644 --- a/pd/src/m_class.c +++ b/pd/src/m_class.c @@ -7,7 +7,7 @@ #include "m_imp.h" #include "s_stuff.h" #include <stdlib.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #ifdef MSW diff --git a/pd/src/m_sched.c b/pd/src/m_sched.c index 411d1963..ae9f3664 100644 --- a/pd/src/m_sched.c +++ b/pd/src/m_sched.c @@ -45,7 +45,7 @@ struct _clock t_clock *clock_setlist; -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/pd/src/makefile.in b/pd/src/makefile.in index cba0f7a8..7713be99 100644 --- a/pd/src/makefile.in +++ b/pd/src/makefile.in @@ -59,10 +59,6 @@ SRC = g_canvas.c g_graph.c g_text.c g_rtext.c g_array.c g_template.c g_io.c \ OBJ = $(SRC:.c=.o) -GSRC = @GUISRC@ - -GOBJ = $(GSRC:.c=.o) - # get version from m_pd.h to use in doc/1.manual/1.introduction.txt PD_MAJOR_VERSION := $(shell grep PD_MAJOR_VERSION m_pd.h | \ sed 's|^.define *PD_MAJOR_VERSION *\([0-9]*\).*|\1|' ) @@ -84,10 +80,10 @@ endif .PHONY: pd gui externs all all: pd $(BIN_DIR)/pd-watchdog gui $(BIN_DIR)/pdsend \ - $(BIN_DIR)/pdreceive $(BIN_DIR)/pd.tk externs + $(BIN_DIR)/pdreceive externs bin: pd $(BIN_DIR)/pd-watchdog gui $(BIN_DIR)/pdsend \ - $(BIN_DIR)/pdreceive $(BIN_DIR)/pd.tk + $(BIN_DIR)/pdreceive $(OBJ) : %.o : %.c $(CC) $(CFLAGS) $(GFLAGS) $(INCLUDE) -c -o $(OBJ_DIR)/$*.o $*.c @@ -100,12 +96,6 @@ $(ASIOOBJ): %.o : %.cpp pd: $(PDEXEC) -ifneq ($(GSRC),) -gui: $(BIN_DIR)/$(GUINAME) -else -gui: -endif - pd-watchdog: $(BIN_DIR)/pd-watchdog $(BIN_DIR): @@ -123,13 +113,6 @@ $(BIN_DIR)/pdreceive: u_pdreceive.c $(BIN_DIR) $(PDEXEC): $(OBJ) $(BIN_DIR) cd ../obj; $(CC) $(LDFLAGS) $(DBG_CFLAGS) -o $(PDEXEC) $(OBJ) $(LIB) -$(BIN_DIR)/pd-gui: $(GOBJ) $(GSRC) - cd ../obj; $(CC) $(INCLUDE) -o $(BIN_DIR)/$(GUINAME) $(GOBJ) $(GLIB) - -$(BIN_DIR)/pd.tk: u_main.tk $(BIN_DIR) - cp u_main.tk $(BIN_DIR)/pd.tk - touch -r makefile.dependencies $(BIN_DIR) - #this is for Max OSX only... $(BIN_DIR)/libPdTcl.dylib: $(GOBJ) $(GSRC) cd ../obj && $(CC) $(CFLAGS) -dynamiclib -read_only_relocs warning \ @@ -203,7 +186,8 @@ install: all local-clean: -rm -f ../obj/* $(BIN_DIR)/pd $(BIN_DIR)/$(GUINAME) $(BIN_DIR)/pdsend \ - $(BIN_DIR)/pdreceive $(BIN_DIR)/pd-watchdog m_stamp.c + $(BIN_DIR)/pdreceive $(BIN_DIR)/pd-watchdog m_stamp.c \ + $(BIN_DIR)/*.tcl -rm -f `find ../portaudio -name "*.o"` -rm -f *~ -(cd ../doc/6.externs; rm -f *.pd_linux) diff --git a/pd/src/makefile.nt b/pd/src/makefile.nt index cda842f2..7b4e834e 100644 --- a/pd/src/makefile.nt +++ b/pd/src/makefile.nt @@ -1,6 +1,6 @@ # Makefile for PD on MSW -all: pd gui ..\bin\pd.tk ..\bin\pdsend.exe ..\bin\pdreceive.exe +all: pd ..\bin\pdsend.exe ..\bin\pdreceive.exe VCSDK = "C:\Program Files\Microsoft SDKs\Windows\v6.0A" @@ -18,7 +18,6 @@ LIB = /NODEFAULTLIB:libcmt /NODEFAULTLIB:oldnames /NODEFAULTLIB:libc \ $(LDIR)\setupapi.lib ..\bin\pthreadVC.lib \ $(LD2)\libcmt.lib $(LD2)\oldnames.lib -GLIB = $(LIB) ..\bin\tcl84.lib ..\bin\tk84.lib CFLAGS = /nologo /W3 /DMSW /DNT /DPD /DPD_INTERNAL /DWIN32 /DWINDOWS /Ox \ -DPA_LITTLE_ENDIAN -DUSEAPI_MMIO -DUSEAPI_PORTAUDIO -D__i386__ -DPA19 \ -D_CRT_SECURE_NO_WARNINGS @@ -98,8 +97,6 @@ ALLCF = $(CFLAGS) $(INCLUDE) $(INCASIO) $(INCPA) $(INCPM) /D_WINDOWS \ pd: ..\bin\pd.exe ..\bin\pd.com -gui: ..\bin\pdtcl.dll - ..\bin\pd.exe: s_entry.obj ..\bin\pd.lib link $(LFLAGS) /OUT:..\bin\pd.exe /INCREMENTAL:NO s_entry.obj \ ..\bin\pd.lib $(LIB) $(ASIOLIB) @@ -108,12 +105,6 @@ gui: ..\bin\pdtcl.dll link /DLL /OUT:..\bin\pd.dll /EXPORT:sys_main $(LFLAGS) $(OBJC) \ $(OBJASIO) $(LIB) $(ASIOLIB) -..\bin\pdtcl.dll: t_tkcmd.obj - link $(LFLAGS) /dll /export:Pdtcl_Init /out:..\bin\pdtcl.dll \ - t_tkcmd.obj $(GLIB) - -..\bin\pd.tk: u_main.tk; copy u_main.tk ..\bin\pd.tk - ..\bin\pdsend.exe: u_pdsend.obj link $(LFLAGS) /out:..\bin\pdsend.exe /INCREMENTAL:NO u_pdsend.obj \ $(LIB) diff --git a/pd/src/notes.txt b/pd/src/notes.txt index 6c98ca0a..0cf0ee61 100644 --- a/pd/src/notes.txt +++ b/pd/src/notes.txt @@ -1,10 +1,6 @@ ---------------- dolist -------------------- -doc: -exp~, abs~ fixes -pd~ -ninsig 0 bug fixed - compile on various versions of linux windows: modal dialogs confuse watchdog diff --git a/pd/src/s_audio.c b/pd/src/s_audio.c index 81438bbe..2f274fc6 100644 --- a/pd/src/s_audio.c +++ b/pd/src/s_audio.c @@ -9,7 +9,7 @@ #include "m_pd.h" #include "s_stuff.h" #include <stdio.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #include <sys/time.h> #include <sys/resource.h> diff --git a/pd/src/s_audio_jack.c b/pd/src/s_audio_jack.c index f00e2f13..990a7a8c 100644 --- a/pd/src/s_audio_jack.c +++ b/pd/src/s_audio_jack.c @@ -13,7 +13,7 @@ #define MAX_CLIENTS 100 -#define NUM_JACK_PORTS 32 +#define NUM_JACK_PORTS 128 /* seems like higher values give bad xrun problems */ #define BUF_JACK 4096 static jack_nframes_t jack_out_max; #define JACK_OUT_MAX 64 diff --git a/pd/src/s_file.c b/pd/src/s_file.c index fe266b37..e5510011 100644 --- a/pd/src/s_file.c +++ b/pd/src/s_file.c @@ -16,7 +16,7 @@ #include <stdlib.h> #include <stdio.h> #include <errno.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <sys/types.h> #include <sys/stat.h> #include <sys/types.h> diff --git a/pd/src/s_inter.c b/pd/src/s_inter.c index c67076f3..1f17ce70 100644 --- a/pd/src/s_inter.c +++ b/pd/src/s_inter.c @@ -47,6 +47,7 @@ typedef int socklen_t; #include <sys/types.h> #include <sys/stat.h> #include <pthread.h> +#include <glob.h> #else #include <stdlib.h> #endif @@ -58,6 +59,10 @@ typedef int socklen_t; #define PDBINDIR "bin/" #endif +#ifndef PDTCLDIR +#define PDTCLDIR "tcl/" +#endif + #ifndef WISHAPP #define WISHAPP "wish84.exe" #endif @@ -206,7 +211,7 @@ void sys_microsleep(int microsec) sys_domicrosleep(microsec, 1); } -#ifdef UNISTD +#ifdef HAVE_UNISTD_H typedef void (*sighandler_t)(int); static void sys_signal(int signo, sighandler_t sigfun) @@ -554,7 +559,7 @@ void socketreceiver_read(t_socketreceiver *x, int fd) void sys_closesocket(int fd) { -#ifdef UNISTD +#ifdef HAVE_UNISTD_H close(fd); #endif #ifdef MSW @@ -858,7 +863,7 @@ static int defaultfontshit[MAXFONTS] = { 24, 15, 28}; #define NDEFAULTFONT (sizeof(defaultfontshit)/sizeof(*defaultfontshit)) -int sys_startgui(const char *guidir) +int sys_startgui(const char *libdir) { pid_t childpid; char cmdbuf[4*MAXPDSTRING]; @@ -872,7 +877,7 @@ int sys_startgui(const char *guidir) short version = MAKEWORD(2, 0); WSADATA nobby; #endif -#ifdef UNISTD +#ifdef HAVE_UNISTD_H int stdinpipe[2]; #endif /* create an empty FD poll list */ @@ -880,7 +885,7 @@ int sys_startgui(const char *guidir) sys_nfdpoll = 0; inbinbuf = binbuf_new(); -#ifdef UNISTD +#ifdef HAVE_UNISTD_H signal(SIGHUP, sys_huphandler); signal(SIGINT, sys_exithandler); signal(SIGQUIT, sys_exithandler); @@ -910,7 +915,7 @@ int sys_startgui(const char *guidir) if (GetCurrentDirectory(MAXPDSTRING, cmdbuf) == 0) strcpy(cmdbuf, "."); #endif -#ifdef UNISTD +#ifdef HAVE_UNISTD_H if (!getcwd(cmdbuf, MAXPDSTRING)) strcpy(cmdbuf, "."); @@ -1019,68 +1024,52 @@ int sys_startgui(const char *guidir) if (sys_verbose) fprintf(stderr, "port %d\n", portno); -#ifdef UNISTD +#ifdef HAVE_UNISTD_H if (!sys_guicmd) { #ifdef __APPLE__ - char *homedir = getenv("HOME"), filename[250]; + int i; struct stat statbuf; - /* first look for Wish bundled with and renamed "Pd" */ - sprintf(filename, "%s/../../MacOS/Pd", guidir); - if (stat(filename, &statbuf) >= 0) - goto foundit; - if (!homedir || strlen(homedir) > 150) - goto nohomedir; - /* Look for Wish in user's Applications. Might or might - not be names "Wish Shell", and might or might not be - in "Utilities" subdir. */ - sprintf(filename, - "%s/Applications/Utilities/Wish shell.app/Contents/MacOS/Wish Shell", - homedir); - if (stat(filename, &statbuf) >= 0) - goto foundit; - sprintf(filename, - "%s/Applications/Utilities/Wish.app/Contents/MacOS/Wish", - homedir); - if (stat(filename, &statbuf) >= 0) - goto foundit; - sprintf(filename, - "%s/Applications/Wish shell.app/Contents/MacOS/Wish Shell", - homedir); - if (stat(filename, &statbuf) >= 0) - goto foundit; - sprintf(filename, - "%s/Applications/Wish.app/Contents/MacOS/Wish", - homedir); - if (stat(filename, &statbuf) >= 0) - goto foundit; - nohomedir: - /* Perform the same search among system applications. */ - strcpy(filename, - "/usr/bin/wish"); - if (stat(filename, &statbuf) >= 0) - goto foundit; - strcpy(filename, - "/Applications/Utilities/Wish Shell.app/Contents/MacOS/Wish Shell"); - if (stat(filename, &statbuf) >= 0) - goto foundit; - strcpy(filename, - "/Applications/Utilities/Wish.app/Contents/MacOS/Wish"); - if (stat(filename, &statbuf) >= 0) - goto foundit; - strcpy(filename, - "/Applications/Wish Shell.app/Contents/MacOS/Wish Shell"); - if (stat(filename, &statbuf) >= 0) - goto foundit; - strcpy(filename, - "/Applications/Wish.app/Contents/MacOS/Wish"); - foundit: - sprintf(cmdbuf, "\"%s\" %s/pd.tk %d\n", filename, guidir, portno); + glob_t glob_buffer; + char *homedir = getenv("HOME"); + char embed_glob[FILENAME_MAX]; + char embed_filename[FILENAME_MAX], home_filename[FILENAME_MAX]; + char *wish_paths[10] = { + "(did not find an embedded wish)", + "(did not find a home directory)", + "/Applications/Utilities/Wish.app/Contents/MacOS/Wish", + "/Applications/Utilities/Wish Shell.app/Contents/MacOS/Wish Shell", + "/Applications/Wish.app/Contents/MacOS/Wish", + "/Applications/Wish Shell.app/Contents/MacOS/Wish Shell", + "/usr/bin/wish" + }; + /* this glob is needed so the Wish executable can have the same + * filename as the Pd.app, i.e. 'Pd-0.42-3.app' should have a Wish + * executable called 'Pd-0.42-3.app/Contents/MacOS/Pd-0.42-3' */ + sprintf(embed_glob, "%s/../MacOS/Pd*", libdir); + glob_buffer.gl_matchc = 1; /* we only need one match */ + glob(embed_glob, GLOB_LIMIT, NULL, &glob_buffer); + if (glob_buffer.gl_pathc > 0) { + strcpy(embed_filename, glob_buffer.gl_pathv[0]); + wish_paths[0] = embed_filename; + } + sprintf(home_filename, + "%s/Applications/Wish.app/Contents/MacOS/Wish",homedir); + wish_paths[1] = home_filename; + for(i=0; i<10; i++) + { + if (sys_verbose) + fprintf(stderr, "Trying Wish at \"%s\"\n", wish_paths[i]); + if (stat(wish_paths[i], &statbuf) >= 0) + break; + } + sprintf(cmdbuf,"\"%s\" %s/tcl/pd.tcl %d\n", wish_paths[i], + libdir, portno); #else sprintf(cmdbuf, - "TCL_LIBRARY=\"%s/tcl/library\" TK_LIBRARY=\"%s/tk/library\" \ - \"%s/pd-gui\" %d\n", - sys_libdir->s_name, sys_libdir->s_name, guidir, portno); + "TCL_LIBRARY=\"%s/lib/tcl/library\" TK_LIBRARY=\"%s/lib/tk/library\" \ + wish \"%s/tcl/pd.tcl\" %d\n", + libdir, libdir, libdir, portno); #endif sys_guicmd = cmdbuf; } @@ -1099,6 +1088,7 @@ int sys_startgui(const char *guidir) { setuid(getuid()); /* lose setuid priveliges */ #ifndef __APPLE__ +// TODO this seems unneeded on any platform hans@eds.org /* the wish process in Unix will make a wish shell and read/write standard in and out unless we close the file descriptors. Somehow this doesn't make the MAC OSX @@ -1122,18 +1112,16 @@ int sys_startgui(const char *guidir) #endif /* UNISTD */ #ifdef MSW - /* in MSW land "guipath" is unused; we just do everything from - the libdir. */ - /* fprintf(stderr, "%s\n", sys_libdir->s_name); */ + /* fprintf(stderr, "%s\n", libdir); */ strcpy(scriptbuf, "\""); - strcat(scriptbuf, sys_libdir->s_name); - strcat(scriptbuf, "/" PDBINDIR "pd.tk\""); + strcat(scriptbuf, libdir); + strcat(scriptbuf, "/" PDTCLDIR "pd.tcl\""); sys_bashfilename(scriptbuf, scriptbuf); sprintf(portbuf, "%d", portno); - strcpy(wishbuf, sys_libdir->s_name); + strcpy(wishbuf, libdir); strcat(wishbuf, "/" PDBINDIR WISHAPP); sys_bashfilename(wishbuf, wishbuf); @@ -1197,7 +1185,7 @@ int sys_startgui(const char *guidir) } close(pipe9[1]); - sprintf(cmdbuf, "%s/pd-watchdog\n", guidir); + sprintf(cmdbuf, "%s/bin/pd-watchdog\n", libdir); if (sys_verbose) fprintf(stderr, "%s", cmdbuf); execl("/bin/sh", "sh", "-c", cmdbuf, (char*)0); perror("pd: exec"); diff --git a/pd/src/s_loader.c b/pd/src/s_loader.c index 6cc497c4..b708961c 100644 --- a/pd/src/s_loader.c +++ b/pd/src/s_loader.c @@ -2,10 +2,10 @@ * For information on usage and redistribution, and for a DISCLAIMER OF ALL * WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ -#ifdef DL_OPEN +#ifdef HAVE_LIBDL #include <dlfcn.h> #endif -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <stdlib.h> #include <unistd.h> #include <sys/types.h> @@ -169,7 +169,7 @@ gotone: strncat(filename, nameptr, MAXPDSTRING-strlen(filename)); filename[MAXPDSTRING-1] = 0; -#ifdef DL_OPEN +#ifdef HAVE_LIBDL dlobj = dlopen(filename, RTLD_NOW | RTLD_GLOBAL); if (!dlobj) { @@ -178,6 +178,7 @@ gotone: return (0); } makeout = (t_xxx)dlsym(dlobj, symname); + fprintf(stderr, "symbol %s\n", symname); #endif #ifdef MSW sys_bashfilename(filename, filename); @@ -262,6 +263,7 @@ int sys_run_scheduler(const char *externalschedlibname, (t_externalschedlibmain)GetProcAddress(ntdll, "main"); } #else +#ifdef HAVE_LIBDL { void *dlobj; struct stat statbuf; @@ -282,6 +284,9 @@ int sys_run_scheduler(const char *externalschedlibname, externalmainfunc = (t_externalschedlibmain)dlsym(dlobj, "pd_extern_sched"); } +#else + return (0); +#endif #endif return((*externalmainfunc)(sys_extraflagsstring)); } diff --git a/pd/src/s_main.c b/pd/src/s_main.c index a246e38a..058f0232 100644 --- a/pd/src/s_main.c +++ b/pd/src/s_main.c @@ -13,7 +13,7 @@ #include <fcntl.h> #include <stdlib.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #ifdef MSW @@ -51,7 +51,6 @@ int sys_nosleep = 0; /* skip all "sleep" calls and spin instead */ char *sys_guicmd; t_symbol *sys_libdir; -t_symbol *sys_guidir; static t_namelist *sys_openlist; static t_namelist *sys_messagelist; static int sys_version; @@ -63,12 +62,12 @@ int sys_midiindevlist[MAXMIDIINDEV] = {1}; int sys_midioutdevlist[MAXMIDIOUTDEV] = {1}; char sys_font[100] = -#ifdef MSW - "Courier"; +#ifdef __APPLE__ + "Monaco"; #else "Courier"; #endif -char sys_fontweight[] = "bold "; /* currently only used for iemguis */ +char sys_fontweight[] = "bold "; static int sys_main_srate; static int sys_main_advance; static int sys_main_callback; @@ -297,7 +296,7 @@ int sys_main(int argc, char **argv) pd_version, pd_compiletime, pd_compiledate); if (sys_version) /* if we were just asked our version, exit here. */ return (0); - if (sys_startgui(sys_guidir->s_name)) /* start the gui */ + if (sys_startgui(sys_libdir->s_name)) /* start the gui */ return(1); if (sys_externalschedlib) return (sys_run_scheduler(sys_externalschedlibname, @@ -391,7 +390,7 @@ static char *(usagemessage[]) = { "-guicmd \"cmd...\" -- start alternatve GUI program (e.g., remote via ssh)\n", "-send \"msg...\" -- send a message at startup, after patches are loaded\n", "-noprefs -- suppress loading preferences on startup\n", -#ifdef UNISTD +#ifdef HAVE_UNISTD_H "-rt or -realtime -- use real-time priority\n", "-nrt -- don't use real-time priority\n", #endif @@ -441,7 +440,7 @@ void sys_findprogdir(char *progname) { char sbuf[MAXPDSTRING], sbuf2[MAXPDSTRING], *sp; char *lastslash; -#ifdef UNISTD +#ifdef HAVE_UNISTD_H struct stat statbuf; #endif @@ -451,7 +450,7 @@ void sys_findprogdir(char *progname) sbuf2[MAXPDSTRING-1] = 0; sys_unbashfilename(sbuf2, sbuf); #endif /* MSW */ -#ifdef UNISTD +#ifdef HAVE_UNISTD_H strncpy(sbuf, progname, MAXPDSTRING); sbuf[MAXPDSTRING-1] = 0; #endif @@ -483,22 +482,23 @@ void sys_findprogdir(char *progname) pd was found in. We now want to infer the "lib" directory and the "gui" directory. In "simple" unix installations, the layout is .../bin/pd - .../bin/pd-gui + .../bin/pd-watchdog (etc) + .../tcl/pd.tcl .../doc and in "complicated" unix installations, it's: .../bin/pd - .../lib/pd/bin/pd-gui + .../lib/pd/bin/pd-watchdog + .../lib/tcl/pd.tcl .../lib/pd/doc To decide which, we stat .../lib/pd; if that exists, we assume it's the complicated layout. In MSW, it's the "simple" layout, but - the gui program is straight wish80: + "wish" is found in bin: .../bin/pd .../bin/wish80.exe .../doc */ #ifdef MSW sys_libdir = gensym(sbuf2); - sys_guidir = &s_; /* in MSW the guipath just depends on the libdir */ #else strncpy(sbuf, sbuf2, MAXPDSTRING-30); sbuf[MAXPDSTRING-30] = 0; @@ -507,21 +507,11 @@ void sys_findprogdir(char *progname) { /* complicated layout: lib dir is the one we just stat-ed above */ sys_libdir = gensym(sbuf); - /* gui lives in .../lib/pd/bin */ - strncpy(sbuf, sbuf2, MAXPDSTRING-30); - sbuf[MAXPDSTRING-30] = 0; - strcat(sbuf, "/lib/pd/bin"); - sys_guidir = gensym(sbuf); } else { /* simple layout: lib dir is the parent */ sys_libdir = gensym(sbuf2); - /* gui lives in .../bin */ - strncpy(sbuf, sbuf2, MAXPDSTRING-30); - sbuf[MAXPDSTRING-30] = 0; - strcat(sbuf, "/bin"); - sys_guidir = gensym(sbuf); } #endif } @@ -839,7 +829,7 @@ int sys_argparse(int argc, char **argv) sys_noautopatch = 1; argc--; argv++; } -#ifdef UNISTD +#ifdef HAVE_UNISTD_H else if (!strcmp(*argv, "-rt") || !strcmp(*argv, "-realtime")) { sys_hipriority = 1; diff --git a/pd/src/s_midi.c b/pd/src/s_midi.c index 67e5e4c7..11669366 100644 --- a/pd/src/s_midi.c +++ b/pd/src/s_midi.c @@ -7,7 +7,7 @@ #include "m_pd.h" #include "s_stuff.h" #include "m_imp.h" -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #include <sys/time.h> #ifdef HAVE_BSTRING_H diff --git a/pd/src/s_midi_alsa.c b/pd/src/s_midi_alsa.c index dcc50006..d0d82f30 100644 --- a/pd/src/s_midi_alsa.c +++ b/pd/src/s_midi_alsa.c @@ -6,7 +6,7 @@ /* MIDI I/O for Linux using ALSA */ #include <stdio.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #include <stdlib.h> diff --git a/pd/src/s_midi_oss.c b/pd/src/s_midi_oss.c index 5c11bae3..15d77253 100644 --- a/pd/src/s_midi_oss.c +++ b/pd/src/s_midi_oss.c @@ -6,7 +6,7 @@ /* MIDI I/O for Linux using OSS */ #include <stdio.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #include <stdlib.h> diff --git a/pd/src/s_midi_pm.c b/pd/src/s_midi_pm.c index 831f3f06..e1c05b1a 100644 --- a/pd/src/s_midi_pm.c +++ b/pd/src/s_midi_pm.c @@ -10,7 +10,7 @@ #include "m_pd.h" #include "s_stuff.h" #include <stdio.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #include <sys/time.h> #include <sys/resource.h> diff --git a/pd/src/s_path.c b/pd/src/s_path.c index d74aa0f6..f9c232a3 100644 --- a/pd/src/s_path.c +++ b/pd/src/s_path.c @@ -14,7 +14,7 @@ #define DEBUG(x) #include <stdlib.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #include <sys/stat.h> #endif @@ -228,7 +228,7 @@ int sys_trytoopenone(const char *dir, const char *name, const char* ext, if ((fd=open(dirresult,O_RDONLY | MSWOPENFLAG(bin))) >= 0) { /* in unix, further check that it's not a directory */ -#ifdef UNISTD +#ifdef HAVE_UNISTD_H struct stat statbuf; int ok = ((fstat(fd, &statbuf) >= 0) && !S_ISDIR(statbuf.st_mode)); diff --git a/pd/src/t_main.c b/pd/src/t_main.c deleted file mode 100644 index 2ed68841..00000000 --- a/pd/src/t_main.c +++ /dev/null @@ -1,115 +0,0 @@ -/* Copyright (c) 1997-1999 Miller Puckette. -* For information on usage and redistribution, and for a DISCLAIMER OF ALL -* WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ - -/* This file should be compared with the corresponding thing in the TK -* distribution whenever updating to newer versions of TCL/TK. */ - -/* - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - - -#ifndef __APPLE__ /* linux and IRIX only; in __APPLE__ we don't link this in */ -#include "tk.h" -#include <stdlib.h> - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * This is the main program for the application. - * - * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -void pdgui_startup(Tcl_Interp *interp); -void pdgui_setname(char *name); -void pdgui_setsock(int port); -void pdgui_sethost(char *name); - -int -main(int argc, char **argv) -{ - pdgui_setname(argv[0]); - if (argc >= 2) - { - pdgui_setsock(atoi(argv[1])); - argc--; argv++; - argv[0] = "Pd"; - } - if (argc >= 2) - { - pdgui_sethost(argv[1]); - argc--; argv++; - argv[0] = "Pd"; - } - Tk_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler warning. */ -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - Tk_Window mainwindow; - - if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - if (Tk_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - /* setup specific to pd-gui: */ - - pdgui_startup(interp); - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. - */ - -#if 0 - tcl_RcFileName = "~/.apprc"; -#endif - - return TCL_OK; -} - -#endif /* __APPLE__ */ diff --git a/pd/src/t_tk.h b/pd/src/t_tk.h deleted file mode 100644 index a6943679..00000000 --- a/pd/src/t_tk.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Copyright (c) 1997-1999 Miller Puckette. -* For information on usage and redistribution, and for a DISCLAIMER OF ALL -* WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ - -void pdgui_vmess(char *fmt, ...); -void pdgui_mess(char *s); - -void pdgui_evalfile(char *s); - -#define GUISTRING 1000 diff --git a/pd/src/t_tkcmd.c b/pd/src/t_tkcmd.c deleted file mode 100644 index b8cac71e..00000000 --- a/pd/src/t_tkcmd.c +++ /dev/null @@ -1,669 +0,0 @@ -/* Copyright (c) 1997-1999 Miller Puckette. -* For information on usage and redistribution, and for a DISCLAIMER OF ALL -* WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ - -#ifndef MSW /* in unix this only works first; in MSW it only works last. */ -#include "tk.h" -#endif - -#include "t_tk.h" -#include <stdlib.h> -#include <string.h> -#include <stdio.h> -#include <stdarg.h> -#include <sys/types.h> - -#ifndef MSW -#include <unistd.h> -#include <sys/socket.h> -#include <netinet/in.h> -#include <netinet/tcp.h> -#include <netdb.h> -#ifdef HAVE_BSTRING_H -#include <bstring.h> -#endif -#include <sys/time.h> -#include <errno.h> -#include <fcntl.h> -#endif -#ifdef MSW -#include <winsock.h> -#include <io.h> -#endif - -/* These pragmas are only used for MSVC, not MinGW or Cygwin <hans@at.or.at> */ -#ifdef _MSC_VER -#pragma warning( disable : 4305 ) /* uncast const double to float */ -#pragma warning( disable : 4244 ) /* uncast double to float */ -#pragma warning( disable : 4101 ) /* unused local variables */ -#endif - -#ifdef MSW -#include "tk.h" -#endif - -#ifdef __APPLE__ -#define STARTGUI -#endif - -#ifdef __linux__ -#define STARTGUI -#endif - -#define FIRSTPORTNUM 5600 - -void tcl_mess(char *s); -static Tcl_Interp *tk_pdinterp; -static int pd_portno = 0; - - -/***************** the socket setup code ********************/ - -/* If this is reset by pdgui_setsock(), it's the port number Pd will try to -connect to; but if zero, that means we should set it and start Pd ourselves. */ - - - /* some installations of linux don't know about "localhost" so give - the loopback address; NT, on the other hand, can't understand the - hostname "127.0.0.1". */ -char hostname[100] = -#ifdef __linux__ - "127.0.0.1"; -#else - "localhost"; -#endif - -void pdgui_setsock(int port) -{ - pd_portno = port; -} - - /* why is this here??? probably never used (see t_main.c). */ -void pdgui_sethost(char *name) -{ - strncpy(hostname, name, 100); - hostname[99] = 0; -} - -static void pdgui_sockerror(char *s) -{ -#ifdef MSW - int err = WSAGetLastError(); -#endif -#ifndef MSW - int err = errno; -#endif - - fprintf(stderr, "%s: %s (%d)\n", s, strerror(err), err); - tcl_mess("exit\n"); - exit(1); -} - -static int sockfd; - -/* The "pd_readsocket" command, which polls the socket. */ - -#define CHUNKSIZE 20000 /* chunks to allocate memory for reading socket */ -#define READSIZE 10000 /* size of read to issue */ - -static char *pd_tkbuf = 0; /* buffer for reading */ -static int pd_tkbufsize = 0; /* current buffer size */ -static int pd_buftail = 0; /* number of bytes already in buffer */ -static int pd_bufhead = 0; /* index of first byte to read */ - - /* mask argument unused but is here to follow tcl's prototype. */ -static void pd_readsocket(ClientData cd, int mask) -{ - fd_set readset, writeset, exceptset; - struct timeval timout; - - timout.tv_sec = 0; - timout.tv_usec = 0; - FD_ZERO(&writeset); - FD_ZERO(&readset); - FD_ZERO(&exceptset); - FD_SET(sockfd, &readset); - FD_SET(sockfd, &exceptset); - if (!pd_tkbuf) - { - if (!(pd_tkbuf = malloc(CHUNKSIZE))) - { - fprintf(stderr, "pd-gui: out of memory\n"); - tcl_mess("exit\n"); - } - pd_tkbufsize = CHUNKSIZE; - } - if (pd_buftail + READSIZE + 1 > pd_tkbufsize) - { - int newsize = pd_tkbufsize + CHUNKSIZE; - char *newbuf = realloc(pd_tkbuf, newsize); - if (!newbuf) - { - fprintf(stderr, "pd-gui: out of memory\n"); - tcl_mess("exit\n"); - } - pd_tkbuf = newbuf; - pd_tkbufsize = newsize; - } - if (select(sockfd+1, &readset, &writeset, &exceptset, &timout) < 0) - perror("select"); - if (FD_ISSET(sockfd, &exceptset) || FD_ISSET(sockfd, &readset)) - { - int ret; - ret = recv(sockfd, pd_tkbuf + pd_buftail, READSIZE, 0); - if (ret < 0) - pdgui_sockerror("socket receive error"); - else if (ret == 0) - { - /* fprintf(stderr, "read %d\n", SOCKSIZE - pd_buftail); */ - fprintf(stderr, "pd_gui: pd process exited\n"); - tcl_mess("exit\n"); - } - else - { - pd_buftail += ret; - while (1) - { - char lastc = 0, *gotcr = 0, *bp = pd_tkbuf + pd_bufhead, - *ep = pd_tkbuf + pd_buftail; - int brace = 0; - /* search for locations that terminate a complete TK - command. These are carriage returns which are not inside - any braces. Braces can be escaped with backslashes (but - backslashes themselves can't.) */ - while (bp < ep) - { - char c = *bp; - if (c == '}' && brace) - brace--; - else if (c == '{') - brace++; - else if (!brace && c == '\n' && lastc != '\\') - { - gotcr = bp; - break; - } - lastc = c; - bp++; - } - /* if gotcr is set there is at least one complete TK - command in the buffer, and gotcr terminates the first one. - Because sending the command to tcl may cause this code to - be reentered, we first copy the command and take it out of - the buffer, then execute the command. - Execute it and slide any - extra bytes to beginning of the buffer. */ - if (gotcr) - { - int bytesincmd = (gotcr - (pd_tkbuf+pd_bufhead)) + 1; - char smallcmdbuf[1000], *realcmdbuf; - if (gotcr - (pd_tkbuf+pd_bufhead) < 998) - realcmdbuf = smallcmdbuf; - else realcmdbuf = malloc(bytesincmd+1); - if (realcmdbuf) - { - strncpy(realcmdbuf, pd_tkbuf+pd_bufhead, bytesincmd); - realcmdbuf[bytesincmd] = 0; - } - pd_bufhead += bytesincmd; - if (realcmdbuf) - { - tcl_mess(realcmdbuf); - if (realcmdbuf != smallcmdbuf) - free(realcmdbuf); - } - if (pd_buftail < pd_bufhead) - fprintf(stderr, "tkcmd bug\n"); - } - else break; - } - if (pd_bufhead) - { - if (pd_buftail > pd_bufhead) - memmove(pd_tkbuf, pd_tkbuf + pd_bufhead, - pd_buftail-pd_bufhead); - pd_buftail -= pd_bufhead; - pd_bufhead = 0; - } - } - } -} - -#ifdef MSW - /* if we're in Gatesland, we add a tcl command to poll the - socket for data. */ -static int pd_pollsocketCmd(ClientData cd, Tcl_Interp *interp, - int argc, char **argv) -{ - pd_readsocket(cd, 0); - return (TCL_OK); -} -#endif - -static void pd_sockerror(char *s) -{ -#ifdef MSW - int err = WSAGetLastError(); - if (err == 10054) return; - else if (err == 10044) - { - fprintf(stderr, - "Warning: you might not have TCP/IP \"networking\" turned on\n"); - fprintf(stderr, "which is needed for Pd to talk to its GUI layer.\n"); - } -#else - int err = errno; -#endif - fprintf(stderr, "%s: %s (%d)\n", s, strerror(err), err); -} - -static void pdgui_connecttosocket(void) -{ - struct sockaddr_in server; - struct hostent *hp; -#ifndef MSW - int retry = 10; -#else - int retry = 1; -#endif -#ifdef MSW - short version = MAKEWORD(2, 0); - WSADATA nobby; - - if (WSAStartup(version, &nobby)) pdgui_sockerror("setup"); -#endif - - /* create a socket */ - sockfd = socket(AF_INET, SOCK_STREAM, 0); - if (sockfd < 0) pdgui_sockerror("socket"); - - /* connect socket using hostname provided in command line */ - server.sin_family = AF_INET; - - hp = gethostbyname(hostname); - - if (hp == 0) - { - fprintf(stderr, - "localhost not found (inet protocol not installed?)\n"); - exit(1); - } - memcpy((char *)&server.sin_addr, (char *)hp->h_addr, hp->h_length); - - /* assign client port number */ - server.sin_port = htons((unsigned short)pd_portno); - - /* try to connect */ - while (1) - { - if (connect(sockfd, (struct sockaddr *) &server, sizeof (server)) >= 0) - goto gotit; - retry--; - if (retry <= 0) - break; - /* In unix there's a race condition; the child won't be - able to connect before the parent (pd) has shed its - setuid-ness. In case this is the problem, sleep and - retry. */ - else - { -#ifndef MSW - fd_set readset, writeset, exceptset; - struct timeval timout; - - timout.tv_sec = 0; - timout.tv_usec = 100000; - FD_ZERO(&writeset); - FD_ZERO(&readset); - FD_ZERO(&exceptset); - fprintf(stderr, "retrying connect...\n"); - if (select(1, &readset, &writeset, &exceptset, &timout) < 0) - perror("select"); -#endif /* !MSW */ - } - } - pdgui_sockerror("connecting stream socket"); -gotit: ; -#ifndef MSW - /* normally we ask TK to call us back; but in MSW we have to poll. */ - Tk_CreateFileHandler(sockfd, TK_READABLE | TK_EXCEPTION, - pd_readsocket, 0); -#endif /* !MSW */ -} - -#ifdef STARTGUI - -/* #define DEBUGCONNECT */ - -#ifdef DEBUGCONNECT -static FILE *debugfd; -#endif - - -static void pd_startfromgui( void) -{ - pid_t childpid; - char cmdbuf[1000], pdbuf[1000], *lastchar; - const char *arg0; - struct sockaddr_in server; - int msgsock; - int len = sizeof(server), nchar; - int ntry = 0, portno = FIRSTPORTNUM; - int xsock = -1; - char morebuf[256]; -#ifdef MSW - short version = MAKEWORD(2, 0); - WSADATA nobby; - char scriptbuf[1000], wishbuf[1000], portbuf[80]; - int spawnret; - char intarg; -#else - int intarg; -#endif - - arg0 = Tcl_GetVar(tk_pdinterp, "argv0", 0); - if (!arg0) - { - fprintf(stderr, "Pd-gui: can't get arg 0\n"); - return; - } - lastchar = strrchr(arg0, '/'); - if (lastchar) - snprintf(pdbuf, lastchar - arg0 + 1, "%s", arg0); - else strcpy(pdbuf, "."); - strcat(pdbuf, "/../bin/pd"); -#ifdef DEBUGCONNECT - fprintf(stderr, "pdbuf is %s\n", pdbuf); -#endif - -#ifdef MSW - if (WSAStartup(version, &nobby)) - pd_sockerror("WSAstartup"); -#endif - - /* create a socket */ - xsock = socket(AF_INET, SOCK_STREAM, 0); - if (xsock < 0) pd_sockerror("socket"); - intarg = 1; - if (setsockopt(xsock, IPPROTO_TCP, TCP_NODELAY, - &intarg, sizeof(intarg)) < 0) - fprintf(stderr, "setsockopt (TCP_NODELAY) failed\n"); - - server.sin_family = AF_INET; - server.sin_addr.s_addr = INADDR_ANY; - - /* assign server port number */ - server.sin_port = htons((unsigned short)portno); - - /* name the socket */ - while (bind(xsock, (struct sockaddr *)&server, sizeof(server)) < 0) - { -#ifdef MSW - int err = WSAGetLastError(); -#else - int err = errno; -#endif - if ((ntry++ > 20) || (err != EADDRINUSE)) - { - perror("bind"); - fprintf(stderr, - "couldn't open GUI-to-pd network connection\n"); - return; - } - portno++; - server.sin_port = htons((unsigned short)(portno)); - } - -#ifdef DEBUGCONNECT - fprintf(debugfd, "port %d\n", portno); - fflush(debugfd); -#endif - -#ifdef UNISTD - sprintf(cmdbuf, "\"%s\" -guiport %d\n", pdbuf, portno); - childpid = fork(); - if (childpid < 0) - { - if (errno) perror("sys_startgui"); - else fprintf(stderr, "sys_startgui failed\n"); - return; - } - else if (!childpid) /* we're the child */ - { -#ifdef DEBUGCONNECT - fprintf(debugfd, "%s", cmdbuf); - fflush(debugfd); -#endif - execl("/bin/sh", "sh", "-c", cmdbuf, (char*)0); - perror("pd: exec"); - _exit(1); - } -#endif /* UNISTD */ - -#ifdef MSW - -#error not yet used.... sys_bashfilename() not filled in here - - strcpy(cmdbuf, pdcmd); - strcat(cmdbuf, "/pd.exe"); - sys_bashfilename(scriptbuf, scriptbuf); - - sprintf(portbuf, "%d", portno); - - spawnret = _spawnl(P_NOWAIT, cmdbuf, "pd.exe", "-port", portbuf, 0); - if (spawnret < 0) - { - perror("spawnl"); - fprintf(stderr, "%s: couldn't start\n", cmdbuf); - return; - } - -#endif /* MSW */ - -#ifdef DEBUGCONNECT - fprintf(stderr, "Waiting for connection request... \n"); -#endif - if (listen(xsock, 5) < 0) pd_sockerror("listen"); - sockfd = accept(xsock, (struct sockaddr *) &server, (unsigned int *)&len); - if (sockfd < 0) pd_sockerror("accept"); -#ifdef DEBUGCONNECT - fprintf(stderr, "... connected\n"); -#endif - -#ifndef MSW - /* normally we ask TK to call us back; but in MSW we have to poll. */ - Tk_CreateFileHandler(sockfd, TK_READABLE | TK_EXCEPTION, - pd_readsocket, 0); -#endif /* !MSW */ -} - -#endif /* STARTGUI */ - -static void pdgui_setupsocket(void) -{ -#ifdef MSW - pdgui_connecttosocket(); -#else - if (pd_portno) - pdgui_connecttosocket(); - else pd_startfromgui() ; -#endif -} - -/**************************** commands ************************/ -static char *pdgui_path; - -/* The "pd" command, which cats its args together and throws the result -* at the Pd interpreter. -*/ -#define MAXWRITE 1024 - -static int pdCmd(ClientData cd, Tcl_Interp *interp, int argc, char **argv) -{ - if (argc == 2) - { - int n = strlen(argv[1]); - if (send(sockfd, argv[1], n, 0) < n) - { - perror("stdout"); - tcl_mess("exit\n"); - } - } - else - { - int i; - char buf[MAXWRITE]; - buf[0] = 0; - for (i = 1; i < argc; i++) - { - if (strlen(argv[i]) + strlen(buf) + 2 > MAXWRITE) - { - interp->result = "pd: arg list too long"; - return (TCL_ERROR); - } - if (i > 1) strcat(buf, " "); - strcat(buf, argv[i]); - } - if (send(sockfd, buf, strlen(buf), 0) < 0) - { - perror("stdout"); - tcl_mess("exit\n"); - } - } - return (TCL_OK); -} - -/*********** "c" level access to tk functions. ******************/ - -void tcl_mess(char *s) -{ - int result; - result = Tcl_Eval(tk_pdinterp, s); - if (result != TCL_OK) - { - if (*tk_pdinterp->result) printf("%s\n", tk_pdinterp->result); - } -} - - /* in linux, we load the tk code from here (in MSW and MACOS, this - is done by passing the name of the file as a startup argument to - the wish shell.) */ -#if !defined(MSW) && !defined(__APPLE__) -void pdgui_doevalfile(Tcl_Interp *interp, char *s) -{ - char buf[GUISTRING]; - sprintf(buf, "set pd_guidir \"%s\"\n", pdgui_path); - tcl_mess(buf); - strcpy(buf, pdgui_path); - strcat(buf, "/bin/"); - strcat(buf, s); - if (Tcl_EvalFile(interp, buf) != TCL_OK) - { - char buf2[1000]; - sprintf(buf2, "puts [concat tcl: %s: can't open script]\n", - buf); - tcl_mess(buf2); - } -} - -void pdgui_evalfile(char *s) -{ - pdgui_doevalfile(tk_pdinterp, s); -} -#endif - -void pdgui_startup(Tcl_Interp *interp) -{ - /* save pointer to the main interpreter */ - tk_pdinterp = interp; - - /* add our own TK commands */ - Tcl_CreateCommand(interp, "pd", (Tcl_CmdProc*)pdCmd, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); -#ifdef MSW - Tcl_CreateCommand(interp, "pd_pollsocket",(Tcl_CmdProc*) pd_pollsocketCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - pdgui_setupsocket(); - /* read in the startup file */ -#if !defined(MSW) && !defined(__APPLE__) - pdgui_evalfile("pd.tk"); -#endif -} - -#ifndef MSW -void pdgui_setname(char *s) -{ - char *t; - char *str; - int n; - if (t = strrchr(s, '/')) str = s, n = (t-s) + 1; - else str = "./", n = 2; - if (n > GUISTRING-100) n = GUISTRING-100; - pdgui_path = malloc(n+9); - - strncpy(pdgui_path, str, n); - while (strlen(pdgui_path) > 0 && pdgui_path[strlen(pdgui_path)-1] == '/') - pdgui_path[strlen(pdgui_path)-1] = 0; - if (t = strrchr(pdgui_path, '/')) - *t = 0; -} -#endif - - /* this is called when an off-the-shelf "wish" has to "load" this module - at runtime. In Linux, this module is linked in and Pdtcl_Init() is not - called; instead, the code in t_main.c calls pdgui_setsock() and - pdgui_startup(). */ - -int Pdtcl_Init(Tcl_Interp *interp) -{ - const char *argv = Tcl_GetVar(interp, "argv", 0); - int portno = 0, i; - if (argv) - { - /* search for arg of form "-guiport %d"; if so we're the - child. For some reason, the second version is too stringent - a test on MSW so the first, incorrect one, is conditionally - used. */ -#ifdef MSW - for (i = 0; i < (int)strlen(argv) - 1; i++) - if (argv[i] >= '0' && argv[i] <= '9') - { - portno = atoi(argv+i); - break; - } -#else - for (i = 0; i < (int)strlen(argv) - 3; i++) - if (argv[i] == ' ' && - argv[i+1] >= '0' && argv[i+1] <= '9') - { - portno = atoi(argv+i+1); - break; - } -#endif - } - if (portno) - pdgui_setsock(portno); -#ifdef DEBUGCONNECT - debugfd = fopen("/tmp/bratwurst", "w"); - fprintf(debugfd, "turning stderr back on\n"); - fflush(debugfd); - dup2(fileno(debugfd), 2); - fprintf(stderr, "duped to stderr?\n"); - fprintf(stderr, "portno %d\n", pd_portno); - fprintf(stderr, "argv %s\n", argv); -#endif - tk_pdinterp = interp; - pdgui_startup(interp); - interp->result = "loaded pdtcl_init"; - - return (TCL_OK); -} - -#if 0 -int Pdtcl_SafeInit(Tcl_Interp *interp) { - fprintf(stderr, "Pdtcl_Safeinit 51\n"); - return (TCL_OK); -} -#endif - diff --git a/pd/src/u_main.tk b/pd/src/u_main.tk deleted file mode 100644 index 8834d232..00000000 --- a/pd/src/u_main.tk +++ /dev/null @@ -1,4489 +0,0 @@ -#!/usr/bin/wish -# Copyright (c) 1997-1999 Miller Puckette. -# For information on usage and redistribution, and for a DISCLAIMER OF ALL -# WARRANTIES, see the file, "LICENSE.txt," in this distribution. - -# changed by Thomas Musil 09.2001 -# between "pdtk_graph_dialog -- dialog window for graphs" -# and "pdtk_array_dialog -- dialog window for arrays" -# a new dialogbox was inserted, named: -# "pdtk_iemgui_dialog -- dialog window for iem guis" -# -# all this changes are labeled with #######iemlib########## - -# set pd_nt (bad name) 0 for unix, 1 for microsoft, and 2 for Mac OSX. -if { $tcl_platform(platform) == "windows" } { - set pd_nt 1 - set defaultFontFamily {Bitstream Vera Sans Mono} - set defaultFontWeight normal - font create menuFont -family Tahoma -size -11 -} elseif { $tcl_platform(os) == "Darwin" } { - set pd_nt 2 - set defaultFontFamily Monaco - set defaultFontWeight normal -} else { - set pd_nt 0 - set defaultFontFamily Courier - set defaultFontWeight bold -} - -# start Pd-extended font hacks ----------------------------- - -# Pd-0.39.2-extended hacks to make font/box sizes the same across platform -# puts stderr "tk scaling is [tk scaling]" -# tk scaling 1 - -# this font is for the Pd Window console text -font create console_font -family $defaultFontFamily -size -12 \ - -weight $defaultFontWeight -# this font is for text in Pd windows -font create text_font -family {Times} -size -14 -weight normal -# for text in Properties Panels and other panes -font create highlight_font -family $defaultFontFamily -size -14 -weight bold - -# end Pd-extended font hacks ----------------------------- - - -# Tearoff is set to true by default: -set pd_tearoff 1 - -# jsarlo -set pd_array_listview_pagesize 1000 -set pd_array_listview_id(0) 0 -set pd_array_listview_entry(0) 0 -set pd_array_listview_page(0) 0 -# end jsarlo - -if {$pd_nt == 1} { - global pd_guidir - global pd_tearoff - set pd_gui2 [string range $argv0 0 [expr [string last \\ $argv0 ] - 1]] - regsub -all \\\\ $pd_gui2 / pd_gui3 - set pd_guidir $pd_gui3/.. - load $pd_guidir/bin/pdtcl.dll - set pd_tearoff 1 -} - -if {$pd_nt == 2} { -# turn on James Tittle II's fast drawing - set tk::mac::useCGDrawing 1 -# anti-alias all lines that need it - set tk::mac::CGAntialiasLimit 2 - global pd_guidir - global pd_tearoff - set pd_gui2 [string range $argv0 0 [expr [string last / $argv0 ] - 1]] - set pd_guidir $pd_gui2/.. - load $pd_guidir/bin/libPdTcl.dylib - set pd_tearoff 0 - global pd_macready - set pd_macready 0 - global pd_macdropped - set pd_macdropped "" - # tk::mac::OpenDocument is called with the filenames put into the - # var args whenever docs are either dropped on the Pd.app icon or - # opened from the Finder. - # It uses menu_doc_open so it can handles numerous file types. - proc tk::mac::OpenDocument {args} { - global pd_macready pd_macdropped - foreach file $args { - if {$pd_macready != 0} { - pd [concat pd open [pdtk_enquote [file tail $file]] \ - [pdtk_enquote [file dirname $file]] \;] - menu_doc_open [file dirname $file] [file tail $file] - } else { - set pd_macdropped $args - } - } - } -} - -# hack so you can easily test-run this script in linux... define pd_guidir -# (which is normally defined at startup in pd under linux...) - -if {$pd_nt == 0} { - if {! [info exists pd_guidir]} { - global pd_guidir - puts stderr {setting pd_guidir to '.'} - set pd_guidir . - } -} - -set pd_deffont {courier 12 bold} - -set help_top_directory $pd_guidir/doc - -# it's unfortunate but we seem to have to turn off global bindings -# for Text objects to get control-s and control-t to do what we want for -# "text" dialogs below. Also we have to get rid of tab's changing the focus. - -bind all <Key-Tab> "" -bind all <<PrevWindow>> "" -bind Text <Control-t> {} -bind Text <Control-s> {} -# puts stderr [bind all] - -################## set up main window ######################### -# the menus are instantiated here for the main window -# for the patch windows, they are created by pdtk_canvas_new -menu .mbar - -frame .controls -pack .controls -side top -fill x -menu .mbar.file -tearoff $pd_tearoff -.mbar add cascade -label "File" -menu .mbar.file -menu .mbar.find -tearoff $pd_tearoff -.mbar add cascade -label "Find" -menu .mbar.find -menu .mbar.windows -postcommand [concat pdtk_fixwindowmenu] -tearoff $pd_tearoff -menu .mbar.audio -tearoff $pd_tearoff -if {$pd_nt != 2} { - .mbar add cascade -label "Windows" -menu .mbar.windows - .mbar add cascade -label "Media" -menu .mbar.audio - menu .mbar.help -tearoff $pd_tearoff - .mbar add cascade -label "Help" -menu .mbar.help -} else { - menu .mbar.apple -tearoff 0 - .mbar add cascade -label "Apple" -menu .mbar.apple -# arrange menus according to Apple HIG - .mbar add cascade -label "Media" -menu .mbar.audio - .mbar add cascade -label "Window" -menu .mbar.windows - menu .mbar.help -tearoff $pd_tearoff - .mbar add cascade -label "Help" -menu .mbar.help -} - -# fix menu font size on Windows with tk scaling = 1 -if {$pd_nt == 1} { - .mbar.file configure -font menuFont - .mbar.find configure -font menuFont - .mbar.windows configure -font menuFont - .mbar.audio configure -font menuFont - .mbar.help configure -font menuFont -} - -set ctrls_audio_on 0 -set ctrls_meter_on 0 -set ctrls_inlevel 0 -set ctrls_outlevel 0 - -frame .controls.switches -checkbutton .controls.switches.audiobutton -text {compute audio} \ - -variable ctrls_audio_on \ - -command {pd [concat pd dsp $ctrls_audio_on \;]} - -checkbutton .controls.switches.meterbutton -text {peak meters} \ - -variable ctrls_meter_on \ - -command {pd [concat pd meters $ctrls_meter_on \;]} - -pack .controls.switches.audiobutton .controls.switches.meterbutton \ - -side top -anchor w - -frame .controls.inout -frame .controls.inout.in -label .controls.inout.in.label -text IN -entry .controls.inout.in.level -textvariable ctrls_inlevel -width 3 -button .controls.inout.in.clip -text {CLIP} -state disabled -pack .controls.inout.in.label .controls.inout.in.level \ - .controls.inout.in.clip -side top -pady 2 - -frame .controls.inout.out -label .controls.inout.out.label -text OUT -entry .controls.inout.out.level -textvariable ctrls_outlevel -width 3 -button .controls.inout.out.clip -text {CLIP} -state disabled -pack .controls.inout.out.label .controls.inout.out.level \ - .controls.inout.out.clip -side top -pady 2 - -button .controls.dio -text "DIO\nerrors" \ - -command {pd [concat pd audiostatus \;]} -button .controls.clear -text "clear\nprintout" \ - -command {.printout.text delete 0.0 end} - -pack .controls.inout.in .controls.inout.out -side left -padx 6 -pack .controls.inout -side left -padx 14 -pack .controls.switches -side left -pack .controls.dio -side left -padx 20 -pack .controls.clear -side right -padx 6 - -frame .printout -text .printout.text -relief raised -bd 2 -font console_font \ - -yscrollcommand ".printout.scroll set" -width 80 -# .printout.text insert end "\n\n\n\n\n\n\n\n\n\n" -scrollbar .printout.scroll -command ".printout.text yview" -pack .printout.scroll -side right -fill y -pack .printout.text -side left -fill both -expand 1 -pack .printout -side bottom -fill both -expand 1 - -proc pdtk_post {stuff} { - .printout.text insert end $stuff - .printout.text yview end-2char -} - -proc pdtk_standardkeybindings {id} { - global pd_nt - bind $id <Control-Key> {pdtk_pd_ctrlkey %W %K 0} - bind $id <Control-Shift-Key> {pdtk_pd_ctrlkey %W %K 1} - if {$pd_nt == 2} { - bind $id <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0} - bind $id <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1} - } -} - -pdtk_standardkeybindings . - -wm title . "Pd" -. configure -menu .mbar -width 200 -height 150 - -# Intercept closing the main pd window: MP 20060413: -wm protocol . WM_DELETE_WINDOW menu_quit - -############### set up global variables ################################ - -set untitled_number 1 -set untitled_directory [pwd] -set saveas_client doggy -set pd_opendir $untitled_directory -set pd_savedir $untitled_directory -set pd_undoaction no -set pd_redoaction no -set pd_undocanvas no - -################ utility functions ######################### - -# enquote a string to send it to a tcl function -proc pdtk_enquote {x} { - set foo [string map {"," "" ";" "" \" ""} $x] - set foo2 [string map {" " "\\ "} $foo] - concat $foo2 -} - -#enquote a string to send it to Pd. Blow off semi and comma; alias spaces -#we also blow off "{", "}", "\" because they'll just cause bad trouble later. -proc pdtk_unspace {x} { - set y [string map {" " "_" ";" "" "," "" "{" "" "}" "" "\\" ""} $x] - if {$y == ""} {set y "empty"} - concat $y -} - -#enquote a string for preferences (command strings etc.) -proc pdtk_encodedialog {x} { - concat +[string map {" " "+_" "$" "+d" ";" "+s" "," "+c" "+" "++"} $x] -} - -proc pdtk_debug {x} { - tk_messageBox -message $x -type ok -} - -proc pdtk_watchdog {} { - pd [concat pd watchdog \;] - after 2000 {pdtk_watchdog} -} - -proc pdtk_ping {} { - pd [concat pd ping \;] -} - -##### routine to ask user if OK and, if so, send a message on to Pd ###### -proc pdtk_check {canvas x message default} { - global pd_nt - if {$pd_nt == 1} { - set answer [tk_messageBox -message $x -type yesno -default $default \ - -icon question] - } else { - set answer [tk_messageBox -message $x -type yesno -default $default \ - -parent $canvas -icon question] - } - if {! [string compare $answer yes]} {pd $message} -} - -set menu_windowlist {} - -proc pdtk_fixwindowmenu {} { - global menu_windowlist - .mbar.windows delete 0 end - foreach i $menu_windowlist { - .mbar.windows add command -label [lindex $i 0] \ - -command [concat menu_domenuwindow [lindex $i 1]] - menu_fixwindowmenu [lindex $i 1] - } -} - -####### Odd little function to make better Mac accelerators ##### - -proc accel_munge {acc} { - global pd_nt - - if {$pd_nt == 2} { - if [string is upper [string index $acc end]] { - return [format "%s%s" "Shift+" \ - [string toupper [string map {Ctrl Meta} $acc] end]] - } else { - return [string toupper [string map {Ctrl Meta} $acc] end] - } - } else { - return $acc - } -} - - - -############### the "New" menu command ######################## -proc menu_new {} { - global untitled_number - global untitled_directory - pd [concat pd filename Untitled-$untitled_number $untitled_directory \;] - pd { - #N canvas; - #X pop 1; - } - set untitled_number [expr $untitled_number + 1] -} - -################## the "Open" menu command ######################### - -proc menu_open {parent} { - global pd_opendir - set filename [tk_getOpenFile -defaultextension .pd -parent $parent\ - -filetypes { {{pd files} {.pd}} {{max files} {.pat}}} \ - -initialdir $pd_opendir] - if {$filename != ""} {open_file $filename} -} - -proc open_file {filename} { - global pd_opendir - set directory [string range $filename 0 [expr [string last / $filename] - 1]] - set pd_opendir $directory - set basename [string range $filename [expr [string last / $filename] + 1] end] - if {[string last .pd $filename] >= 0} { - pd "pd open [pdtk_enquote $basename] [pdtk_enquote $directory] ;" - } -} - -catch { - package require tkdnd - dnd bindtarget . text/uri-list <Drop> { - foreach file %D {open_file $file} - } -} - -################## the "Message" menu command ######################### -proc menu_send {} { - toplevel .sendpanel - entry .sendpanel.entry -textvariable send_textvariable - pack .sendpanel.entry -side bottom -fill both -ipadx 100 - .sendpanel.entry select from 0 - .sendpanel.entry select adjust end - bind .sendpanel.entry <KeyPress-Return> { - pd [concat $send_textvariable \;] - } - pdtk_standardkeybindings .sendpanel.entry - focus .sendpanel.entry -} - -################## the "Quit" menu command ######################### -proc menu_really_quit {} {pd {pd quit;}} - -proc menu_quit {} {pd {pd verifyquit;}} - -######### the "Pd" menu command, which puts the Pd window on top ######## -proc menu_pop_pd {} {raise .} - -######### the "audio" menu command ############### -proc menu_audio {flag} {pd [concat pd dsp $flag \;]} - -######### the "reselect" menu command ################ -proc menu_reselect {name} {pd [concat $name reselect \;]} - -######### the "documentation" menu command ############### - -set doc_number 1 - -# open text docs in a Pd window -proc menu_opentext {filename} { - global doc_number - global pd_guidir - global pd_myversion - set name [format ".help%d" $doc_number] - toplevel $name - text $name.text -relief raised -bd 2 -font text_font \ - -yscrollcommand "$name.scroll set" -background white - scrollbar $name.scroll -command "$name.text yview" - pack $name.scroll -side right -fill y - pack $name.text -side left -fill both -expand 1 - - set f [open $filename] - while {![eof $f]} { - set bigstring [read $f 1000] - regsub -all PD_BASEDIR $bigstring $pd_guidir bigstring2 - regsub -all PD_VERSION $bigstring2 $pd_myversion bigstring3 - $name.text insert end $bigstring3 - } - close $f - set doc_number [expr $doc_number + 1] -} - -# open HTML docs from the menu using the OS-default HTML viewer -proc menu_openhtml {filename} { - global pd_nt - - if {$pd_nt == 0} { - foreach candidate \ - { gnome-open xdg-open sensible-browser iceweasel firefox mozilla \ - galeon konqueror netscape lynx } { - set browser [lindex [auto_execok $candidate] 0] - if {[string length $browser]} { - puts stderr [format "%s %s" $browser $filename] - exec -- sh -c [format "%s %s" $browser $filename] & - break - } - } - } elseif {$pd_nt == 2} { - puts stderr [format "open %s" $filename] - exec sh -c [format "open %s" $filename] - } else { - exec rundll32 url.dll,FileProtocolHandler \ - [format "file://%s" $filename] & - } -} - -proc menu_doc_open {subdir basename} { - global pd_guidir - - set dirname $pd_guidir/$subdir - - if {[regexp ".*\.(txt|c)$" $basename]} { - menu_opentext $dirname/$basename - } elseif {[regexp ".*\.html?$" $basename]} { - menu_openhtml $dirname/$basename - } else { - pd [concat pd open [pdtk_enquote $basename] \ - [pdtk_enquote $dirname] \;] - } -} - - -################## help browser and support functions ######################### -proc menu_doc_browser {dir} { - global .mbar - if {![file isdirectory $dir]} { - puts stderr "menu_doc_browser non-directory $dir\n" - } - if { [winfo exists .help_browser.frame] } { - raise .help_browser - } else { - toplevel .help_browser -menu .mbar - wm title .help_browser "Pd Documentation Browser" - frame .help_browser.frame - pack .help_browser.frame -side top -fill both - doc_make_listbox .help_browser.frame $dir 0 - } - } - -proc doc_make_listbox {base dir count} { - # check for [file readable]? - #if { [info tclversion] >= 8.5 } { - # requires Tcl 8.5 but probably deals with special chars better -# destroy {expand}[lrange [winfo children $base] [expr {2 * $count}] end] - #} else { - if { [catch { eval destroy [lrange [winfo children $base] \ - [expr { 2 * $count }] end] } \ - errorMessage] } { - puts stderr "doc_make_listbox: error listing $dir\n" - } - #} - # exportselection 0 looks good, but selection gets easily out-of-sync - set current_listbox [listbox "[set b "$base.listbox$count"]-list" -yscrollcommand \ - [list "$b-scroll" set] -height 20 -exportselection 0] - pack $current_listbox [scrollbar "$b-scroll" -command [list $current_listbox yview]] \ - -side left -expand 1 -fill y -anchor w - foreach item [concat [lsort -dictionary [glob -directory $dir -nocomplain -types {d} -- *]] \ - [lsort -dictionary [glob -directory $dir -nocomplain -types {f} -- *]]] { - $current_listbox insert end "[file tail $item][expr {[file isdirectory $item] ? {/} : {}}]" - } - bind $current_listbox <Button-1> [list doc_navigate $dir $count %W %x %y] - bind $current_listbox <Double-Button-1> [list doc_double_button $dir $count %W %x %y] -} - -proc doc_navigate {dir count width x y} { - if {[set newdir [$width get [$width index "@$x,$y"]]] eq {}} { - return - } - set dir_to_open [file join $dir $newdir] - if {[file isdirectory $dir_to_open]} { - doc_make_listbox [winfo parent $width] $dir_to_open [incr count] - } -} - -proc doc_double_button {dir count width x y} { - global pd_guidir - if {[set newdir [$width get [$width index "@$x,$y"]]] eq {}} { - return - } - set dir_to_open [file join $dir $newdir] - if {[file isdirectory $dir_to_open]} { - doc_navigate $dir $count $width $x $y - } else { - regsub -- $pd_guidir [file dirname $dir_to_open] "" subdir - set file [file tail $dir_to_open] - if { [catch {menu_doc_open $subdir $file} fid] } { - puts stderr "Could not open $pd_guidir/$subdir/$file\n" - } - return; - } -} - -############# routine to add media, help, and apple menu items ############### - -proc menu_addstd {mbar} { - global pd_apilist pd_midiapilist pd_nt pd_tearoff -# the "Audio" menu - $mbar.audio add command -label {audio ON} -accelerator [accel_munge "Ctrl+/"] \ - -command {menu_audio 1} - $mbar.audio add command -label {audio OFF} -accelerator [accel_munge "Ctrl+."] \ - -command {menu_audio 0} - for {set x 0} {$x<[llength $pd_apilist]} {incr x} { - $mbar.audio add radiobutton -label [lindex [lindex $pd_apilist $x] 0] \ - -command {menu_audio 0} -variable pd_whichapi \ - -value [lindex [lindex $pd_apilist $x] 1]\ - -command {pd [concat pd audio-setapi $pd_whichapi \;]} - } - for {set x 0} {$x<[llength $pd_midiapilist]} {incr x} { - $mbar.audio add radiobutton -label [lindex [lindex $pd_midiapilist $x] 0] \ - -command {menu_midi 0} -variable pd_whichmidiapi \ - -value [lindex [lindex $pd_midiapilist $x] 1]\ - -command {pd [concat pd midi-setapi $pd_whichmidiapi \;]} - } - if {$pd_nt != 2} { - $mbar.audio add command -label {Audio settings...} \ - -command {pd pd audio-properties \;} - $mbar.audio add command -label {MIDI settings...} \ - -command {pd pd midi-properties \;} - } - - $mbar.audio add command -label {Test Audio and MIDI} \ - -command {menu_doc_open doc/7.stuff/tools testtone.pd} - $mbar.audio add command -label {Load Meter} \ - -command {menu_doc_open doc/7.stuff/tools load-meter.pd} - -# the MacOS X app menu - -# The menu on the main menubar named $whatever.apple while be treated -# as a special menu on MacOS X. Tcl/Tk assigns the $whatever.apple menu -# to the app-specific menu in MacOS X that is named after the app, -# so in our case, the Pd menu. <hans@at.or.at> -# See SPECIAL MENUS IN MENUBARS http://www.tcl.tk/man/tcl8.4/TkCmd/menu.htm - if {$pd_nt == 2} { - $mbar.apple add command -label "About Pd..." -command \ - {menu_doc_open doc/1.manual 1.introduction.txt} - menu $mbar.apple.preferences -tearoff 0 - $mbar.apple add cascade -label "Preferences" -menu $mbar.apple.preferences - $mbar.apple.preferences add command -label "Path..." \ - -command {pd pd start-path-dialog \;} - $mbar.apple.preferences add command -label "Startup..." \ - -command {pd pd start-startup-dialog \;} - $mbar.apple.preferences add command -label "Audio Settings..." \ - -command {pd pd audio-properties \;} - $mbar.apple.preferences add command -label "MIDI settings..." \ - -command {pd pd midi-properties \;} - } - - - # the "Help" menu - if {$pd_nt != 2} { - $mbar.help add command -label {About Pd} \ - -command {menu_doc_open doc/1.manual 1.introduction.txt} - } - $mbar.help add command -label {Html ...} \ - -command {menu_doc_open doc/1.manual index.htm} - $mbar.help add command -label {Browser ...} \ - -command {menu_doc_browser $help_top_directory} -} - -#################### the "File" menu for the Pd window ############## - -.mbar.file add command -label New -command {menu_new} \ - -accelerator [accel_munge "Ctrl+n"] -.mbar.file add command -label Open -command {menu_open .} \ - -accelerator [accel_munge "Ctrl+o"] -.mbar.file add separator -.mbar.file add command -label Message -command {menu_send} \ - -accelerator [accel_munge "Ctrl+m"] -# On MacOS X, these are in the standard HIG locations -# i.e. the Preferences menu under "Pd" -if {$pd_nt != 2} { -.mbar.file add command -label Path... \ - -command {pd pd start-path-dialog \;} -.mbar.file add command -label Startup... \ - -command {pd pd start-startup-dialog \;} -} -.mbar.file add separator -.mbar.file add command -label Quit -command {menu_quit} \ - -accelerator [accel_munge "Ctrl+q"] - -#################### the "Find" menu for the Pd window ############## -.mbar.find add command -label {Find last error} -command {menu_finderror} - -########### functions for menu functions on document windows ######## - -proc menu_save {name} { - pdtk_canvas_checkgeometry $name - pd [concat $name menusave \;] -} - -proc menu_saveas {name} { - pdtk_canvas_checkgeometry $name - pd [concat $name menusaveas \;] -} - -proc menu_print {name} { - set filename [tk_getSaveFile -initialfile pd.ps \ - -defaultextension .ps \ - -filetypes { {{postscript} {.ps}} }] - - if {$filename != ""} { - $name.c postscript -file $filename - } -} - -proc menu_close {name} { - pdtk_canvas_checkgeometry $name - pd [concat $name menuclose 0 \;] -} - -proc menu_really_close {name} { - pdtk_canvas_checkgeometry $name - pd [concat $name menuclose 1 \;] -} - -proc menu_undo {name} { - global pd_undoaction - global pd_redoaction - global pd_undocanvas - if {$name == $pd_undocanvas && $pd_undoaction != "no"} { - pd [concat $name undo \;] - } -} - -proc menu_redo {name} { - global pd_undoaction - global pd_redoaction - global pd_undocanvas - if {$name == $pd_undocanvas && $pd_redoaction != "no"} { - pd [concat $name redo \;] - } -} - -proc menu_cut {name} { - pd [concat $name cut \;] -} - -proc menu_copy {name} { - pd [concat $name copy \;] -} - -proc menu_paste {name} { - pd [concat $name paste \;] -} - -proc menu_duplicate {name} { - pd [concat $name duplicate \;] -} - -proc menu_selectall {name} { - pd [concat $name selectall \;] -} - -proc menu_texteditor {name} { - pd [concat $name texteditor \;] -} - -proc menu_font {name} { - pd [concat $name menufont \;] -} - -proc menu_tidyup {name} { - pd [concat $name tidy \;] -} - -proc menu_editmode {name} { - pd [concat $name editmode 0 \;] -} - -proc menu_object {name accel} { - pd [concat $name obj $accel \;] -} - -proc menu_message {name accel} { - pd [concat $name msg $accel \;] -} - -proc menu_floatatom {name accel} { - pd [concat $name floatatom $accel \;] -} - -proc menu_symbolatom {name accel} { - pd [concat $name symbolatom $accel \;] -} - -proc menu_comment {name accel} { - pd [concat $name text $accel \;] -} - -proc menu_graph {name} { - pd [concat $name graph \;] -} - -proc menu_array {name} { - pd [concat $name menuarray \;] -} - -############iemlib################## -proc menu_bng {name accel} { - pd [concat $name bng $accel \;] -} - -proc menu_toggle {name accel} { - pd [concat $name toggle $accel \;] -} - -proc menu_numbox {name accel} { - pd [concat $name numbox $accel \;] -} - -proc menu_vslider {name accel} { - pd [concat $name vslider $accel \;] -} - -proc menu_hslider {name accel} { - pd [concat $name hslider $accel \;] -} - -proc menu_hradio {name accel} { - pd [concat $name hradio $accel \;] -} - -proc menu_vradio {name accel} { - pd [concat $name vradio $accel \;] -} - -proc menu_vumeter {name accel} { - pd [concat $name vumeter $accel \;] -} - -proc menu_mycnv {name accel} { - pd [concat $name mycnv $accel \;] -} - -############iemlib################## - -# correct edit menu, enabling or disabling undo/redo -# LATER also cut/copy/paste -proc menu_fixeditmenu {name} { - global pd_undoaction - global pd_redoaction - global pd_undocanvas -# puts stderr [concat menu_fixeditmenu $name $pd_undocanvas $pd_undoaction] - if {$name == $pd_undocanvas && $pd_undoaction != "no"} { - $name.m.edit entryconfigure "Undo*" -state normal \ - -label [concat "Undo " $pd_undoaction] - } else { - $name.m.edit entryconfigure "Undo*" -state disabled -label "Undo" - } - if {$name == $pd_undocanvas && $pd_redoaction != "no"} { - $name.m.edit entryconfigure "Redo*" -state normal\ - -label [concat "Redo " $pd_redoaction] - } else { - $name.m.edit entryconfigure "Redo*" -state disabled - } -} - -# message from Pd to update the currently available undo/redo action -proc pdtk_undomenu {name undoaction redoaction} { - global pd_undoaction - global pd_redoaction - global pd_undocanvas -# puts stderr [concat pdtk_undomenu $name $undoaction $redoaction] - set pd_undocanvas $name - set pd_undoaction $undoaction - set pd_redoaction $redoaction - if {$name != "nobody"} { -# unpleasant way of avoiding a more unpleasant bug situation --atl 2002.11.25 - menu_fixeditmenu $name - } -} - -proc menu_windowparent {name} { - pd [concat $name findparent \;] -} - -proc menu_findagain {name} { - pd [concat $name findagain \;] -} - -proc menu_finderror {} { - pd [concat pd finderror \;] -} - -proc menu_domenuwindow {i} { - raise $i -} - -proc menu_fixwindowmenu {name} { - global menu_windowlist - global pd_tearoff - $name.m.windows add command - if $pd_tearoff { - $name.m.windows delete 4 end - } else { - $name.m.windows delete 3 end - } - foreach i $menu_windowlist { - $name.m.windows add command -label [lindex $i 0] \ - -command [concat menu_domenuwindow [lindex $i 1]] - } -} - -################## the "find" menu item ################### - -set find_canvas nobody -set find_string "" -set find_count 1 -set find_wholeword 1 - -proc find_apply {name} { - global find_string find_canvas find_wholeword - pd [concat $find_canvas find [pdtk_encodedialog $find_string] \ - $find_wholeword \;] - after 50 destroy $name -} - -proc find_cancel {name} { - after 50 destroy $name -} - -proc menu_findobject {canvas} { - global find_string find_canvas find_count find_wholeword - - set name [format ".find%d" $find_count] - set find_count [expr $find_count + 1] - - set find_canvas $canvas - - toplevel $name - - label $name.label -text {find...} - pack $name.label -side top - - entry $name.entry -textvariable find_string - pack $name.entry -side top - checkbutton $name.wholeword -variable find_wholeword \ - -text {whole word} -anchor e - pack $name.wholeword -side bottom - - frame $name.buttonframe - pack $name.buttonframe -side bottom -fill x -pady 2m - button $name.buttonframe.cancel -text {Cancel}\ - -command "find_cancel $name" - button $name.buttonframe.ok -text {OK}\ - -command "find_apply $name" - pack $name.buttonframe.cancel -side left -expand 1 - pack $name.buttonframe.ok -side left -expand 1 - - $name.entry select from 0 - $name.entry select adjust end - bind $name.entry <KeyPress-Return> [ concat find_apply $name] - pdtk_standardkeybindings $name.entry - focus $name.entry -} - - -############# pdtk_canvas_new -- create a new canvas ############### -proc pdtk_canvas_new {name width height geometry editable} { - global pd_opendir - global pd_tearoff - global pd_nt - global tcl_version - - toplevel $name -menu $name.m - # if we're a mac, refuse to make window so big you can't get to - # the resizing control - if {$pd_nt == 2} { - if {$width > [winfo screenwidth $name] - 80} { - set width [expr [winfo screenwidth $name] - 80] - } - if {$height > [winfo screenheight $name] - 80} { - set height [expr [winfo screenheight $name] - 80] - } - } - -# slide offscreen windows into view - if {$tcl_version >= 8.4} { - set geometry [split $geometry +] - set i 1 - foreach geo {width height} { - set screen($geo) [winfo screen$geo .] - if {[expr [lindex $geometry $i] + [set $geo]] > $screen($geo)} { - set pos($geo) [expr $screen($geo) - [set $geo]] - if {$pos($geo) < 0} {set pos($geo) 0} - lset geometry $i $pos($geo) - } - incr i - } - set geometry [join $geometry +] - } - wm geometry $name $geometry - canvas $name.c -width $width -height $height -background white \ - -yscrollcommand "$name.scrollvert set" \ - -xscrollcommand "$name.scrollhort set" \ - -scrollregion [concat 0 0 $width $height] - - scrollbar $name.scrollvert -command "$name.c yview" - scrollbar $name.scrollhort -command "$name.c xview" \ - -orient horizontal - - pack $name.scrollhort -side bottom -fill x - pack $name.scrollvert -side right -fill y - pack $name.c -side left -expand 1 -fill both - wm minsize $name 1 1 - wm geometry $name $geometry -# the file menu - -# The menus are instantiated here for the patch windows. -# For the main window, they are created on load, at the -# top of this file. - menu $name.m - menu $name.m.file -tearoff $pd_tearoff - $name.m add cascade -label File -menu $name.m.file - - $name.m.file add command -label New -command {menu_new} \ - -accelerator [accel_munge "Ctrl+n"] - - $name.m.file add command -label Open -command [concat menu_open $name] \ - -accelerator [accel_munge "Ctrl+o"] - - $name.m.file add separator - $name.m.file add command -label Message -command {menu_send} \ - -accelerator [accel_munge "Ctrl+m"] - - # arrange menus according to Apple HIG - # these are now part of Preferences... - if {$pd_nt != 2 } { - $name.m.file add command -label Path... \ - -command {pd pd start-path-dialog \;} - - $name.m.file add command -label Startup... \ - -command {pd pd start-startup-dialog \;} - } - - $name.m.file add separator - $name.m.file add command -label Close \ - -command [concat menu_close $name] \ - -accelerator [accel_munge "Ctrl+w"] - - $name.m.file add command -label Save -command [concat menu_save $name] \ - -accelerator [accel_munge "Ctrl+s"] - - $name.m.file add command -label "Save as..." \ - -command [concat menu_saveas $name] \ - -accelerator [accel_munge "Ctrl+S"] - - $name.m.file add command -label Print -command [concat menu_print $name] \ - -accelerator [accel_munge "Ctrl+p"] - - $name.m.file add separator - - $name.m.file add command -label Quit -command {menu_quit} \ - -accelerator [accel_munge "Ctrl+q"] - -# the edit menu - menu $name.m.edit -postcommand [concat menu_fixeditmenu $name] -tearoff $pd_tearoff - $name.m add cascade -label Edit -menu $name.m.edit - - $name.m.edit add command -label Undo -command [concat menu_undo $name] \ - -accelerator [accel_munge "Ctrl+z"] - - $name.m.edit add command -label Redo -command [concat menu_redo $name] \ - -accelerator [accel_munge "Ctrl+Z"] - - $name.m.edit add separator - - $name.m.edit add command -label Cut -command [concat menu_cut $name] \ - -accelerator [accel_munge "Ctrl+x"] - - $name.m.edit add command -label Copy -command [concat menu_copy $name] \ - -accelerator [accel_munge "Ctrl+c"] - - $name.m.edit add command -label Paste \ - -command [concat menu_paste $name] \ - -accelerator [accel_munge "Ctrl+v"] - - $name.m.edit add command -label Duplicate \ - -command [concat menu_duplicate $name] \ - -accelerator [accel_munge "Ctrl+d"] - - $name.m.edit add command -label {Select all} \ - -command [concat menu_selectall $name] \ - -accelerator [accel_munge "Ctrl+a"] - - $name.m.edit add command -label {Reselect} \ - -command [concat menu_reselect $name] \ - -accelerator "Ctrl+Enter" - - $name.m.edit add separator - - $name.m.edit add command -label {Text Editor} \ - -command [concat menu_texteditor $name] \ - -accelerator [accel_munge "Ctrl+t"] - - $name.m.edit add command -label Font \ - -command [concat menu_font $name] - - $name.m.edit add command -label {Tidy Up} \ - -command [concat menu_tidyup $name] - - $name.m.edit add separator - -# Apple, Microsoft, and others put find functions in the Edit menu. - $name.m.edit add command -label {Find...} \ - -accelerator [accel_munge "Ctrl+f"] \ - -command [concat menu_findobject $name] - $name.m.edit add command -label {Find Again} \ - -accelerator [accel_munge "Ctrl+g"] \ - -command [concat menu_findagain $name] - $name.m.edit add command -label {Find last error} \ - -command [concat menu_finderror] - - $name.m.edit add separator - -############iemlib################## -# instead of "red = #BC3C60" we take "grey85", so there is no difference, -# if widget is selected or not. - - $name.m.edit add checkbutton -label "Edit mode" \ - -indicatoron true -selectcolor grey85 \ - -command [concat menu_editmode $name] \ - -accelerator [accel_munge "Ctrl+e"] - - if { $editable == 0 } { - $name.m.edit entryconfigure "Edit mode" -indicatoron false } - - -############iemlib################## - - -# the put menu - menu $name.m.put -tearoff $pd_tearoff - $name.m add cascade -label Put -menu $name.m.put - - $name.m.put add command -label Object \ - -command [concat menu_object $name 0] \ - -accelerator [accel_munge "Ctrl+1"] - - $name.m.put add command -label Message \ - -command [concat menu_message $name 0] \ - -accelerator [accel_munge "Ctrl+2"] - - $name.m.put add command -label Number \ - -command [concat menu_floatatom $name 0] \ - -accelerator [accel_munge "Ctrl+3"] - - $name.m.put add command -label Symbol \ - -command [concat menu_symbolatom $name 0] \ - -accelerator [accel_munge "Ctrl+4"] - - $name.m.put add command -label Comment \ - -command [concat menu_comment $name 0] \ - -accelerator [accel_munge "Ctrl+5"] - - $name.m.put add separator - -############iemlib################## - - $name.m.put add command -label Bang \ - -command [concat menu_bng $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+b"] - - $name.m.put add command -label Toggle \ - -command [concat menu_toggle $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+t"] - - $name.m.put add command -label Number2 \ - -command [concat menu_numbox $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+n"] - - $name.m.put add command -label Vslider \ - -command [concat menu_vslider $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+v"] - - $name.m.put add command -label Hslider \ - -command [concat menu_hslider $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+h"] - - $name.m.put add command -label Vradio \ - -command [concat menu_vradio $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+d"] - - $name.m.put add command -label Hradio \ - -command [concat menu_hradio $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+i"] - - $name.m.put add command -label VU \ - -command [concat menu_vumeter $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+u"] - - $name.m.put add command -label Canvas \ - -command [concat menu_mycnv $name 0] \ - -accelerator [accel_munge "Shift+Ctrl+c"] - -############iemlib################## - - $name.m.put add separator - - $name.m.put add command -label Graph \ - -command [concat menu_graph $name] - - $name.m.put add command -label Array \ - -command [concat menu_array $name] - -# the find menu -# Apple, Microsoft, and others put find functions in the Edit menu. -# But in order to move these items to the Edit menu, the Find menu -# handling needs to be dealt with, including this line in g_canvas.c: -# sys_vgui(".mbar.find delete %d\n", i); -# <hans@at.or.at> - menu $name.m.find -tearoff $pd_tearoff - $name.m add cascade -label Find -menu $name.m.find - - $name.m.find add command -label {Find...} \ - -accelerator [accel_munge "Ctrl+f"] \ - -command [concat menu_findobject $name] - $name.m.find add command -label {Find Again} \ - -accelerator [accel_munge "Ctrl+g"] \ - -command [concat menu_findagain $name] - $name.m.find add command -label {Find last error} \ - -command [concat menu_finderror] - -# the window menu - menu $name.m.windows -postcommand [concat menu_fixwindowmenu $name] \ - -tearoff $pd_tearoff - - $name.m.windows add command -label {parent window}\ - -command [concat menu_windowparent $name] - $name.m.windows add command -label {Pd window} -command menu_pop_pd - $name.m.windows add separator - -# the audio menu - menu $name.m.audio -tearoff $pd_tearoff - - if {$pd_nt != 2} { - $name.m add cascade -label Windows -menu $name.m.windows - $name.m add cascade -label Media -menu $name.m.audio - } else { - $name.m add cascade -label Media -menu $name.m.audio - $name.m add cascade -label Window -menu $name.m.windows -# the MacOS X app menu - menu $name.m.apple -tearoff $pd_tearoff - $name.m add cascade -label "Apple" -menu $name.m.apple - } - -# the help menu - - menu $name.m.help -tearoff $pd_tearoff - $name.m add cascade -label Help -menu $name.m.help - - menu_addstd $name.m - -# the popup menu - menu $name.popup -tearoff false - $name.popup add command -label {Properties} \ - -command [concat popup_action $name 0] - $name.popup add command -label {Open} \ - -command [concat popup_action $name 1] - $name.popup add command -label {Help} \ - -command [concat popup_action $name 2] - -# fix menu font size on Windows with tk scaling = 1 -if {$pd_nt == 1} { - $name.m.file configure -font menuFont - $name.m.edit configure -font menuFont - $name.m.find configure -font menuFont - $name.m.put configure -font menuFont - $name.m.windows configure -font menuFont - $name.m.audio configure -font menuFont - $name.m.help configure -font menuFont - $name.popup configure -font menuFont -} - -# WM protocol - wm protocol $name WM_DELETE_WINDOW [concat menu_close $name] - -# bindings. -# this is idiotic -- how do you just sense what mod keys are down and -# pass them on? I can't find it anywhere. -# Here we encode shift as 1, control 2, alt 4, in agreement -# with definitions in g_canvas.c. The third button gets "8" but we don't -# bother with modifiers there. -# We don't handle multiple clicks yet. - - bind $name.c <Button> {pdtk_canvas_click %W %x %y %b 0} - bind $name.c <Shift-Button> {pdtk_canvas_click %W %x %y %b 1} - bind $name.c <Control-Shift-Button> {pdtk_canvas_click %W %x %y %b 3} - # Alt key is called Option on the Mac - if {$pd_nt == 2} { - bind $name.c <Option-Button> {pdtk_canvas_click %W %x %y %b 4} - bind $name.c <Option-Shift-Button> {pdtk_canvas_click %W %x %y %b 5} - bind $name.c <Option-Control-Button> {pdtk_canvas_click %W %x %y %b 6} - bind $name.c <Mod1-Button> {pdtk_canvas_click %W %x %y %b 6} - bind $name.c <Option-Control-Shift-Button> \ - {pdtk_canvas_click %W %x %y %b 7} - } else { - bind $name.c <Alt-Button> {pdtk_canvas_click %W %x %y %b 4} - bind $name.c <Alt-Shift-Button> {pdtk_canvas_click %W %x %y %b 5} - bind $name.c <Alt-Control-Button> {pdtk_canvas_click %W %x %y %b 6} - bind $name.c <Alt-Control-Shift-Button> \ - {pdtk_canvas_click %W %x %y %b 7} - } - global pd_nt -# button 2 is the right button on Mac; on other platforms it's button 3. - if {$pd_nt == 2} { - bind $name.c <Button-2> {pdtk_canvas_click %W %x %y %b 8} - bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 8} - } else { - bind $name.c <Button-3> {pdtk_canvas_click %W %x %y %b 8} - bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 2} - } -#on linux, button 2 "pastes" from the X windows clipboard - if {$pd_nt == 0} { - bind $name.c <Button-2> {\ - pdtk_canvas_click %W %x %y %b 0;\ - pdtk_canvas_mouseup %W %x %y %b;\ - pdtk_pastetext} - } - - bind $name.c <ButtonRelease> {pdtk_canvas_mouseup %W %x %y %b} - bind $name.c <Control-Key> {pdtk_canvas_ctrlkey %W %K 0} - bind $name.c <Control-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1} -# bind $name.c <Mod1-Key> {puts stderr [concat mod1 %W %K %A]} - if {$pd_nt == 2} { - bind $name.c <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0} - bind $name.c <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1} - } - bind $name.c <Key> {pdtk_canvas_key %W %K %A 0} - bind $name.c <Shift-Key> {pdtk_canvas_key %W %K %A 1} - bind $name.c <KeyRelease> {pdtk_canvas_keyup %W %K %A} - bind $name.c <Motion> {pdtk_canvas_motion %W %x %y 0} - bind $name.c <Control-Motion> {pdtk_canvas_motion %W %x %y 2} - if {$pd_nt == 2} { - bind $name.c <Option-Motion> {pdtk_canvas_motion %W %x %y 4} - } else { - bind $name.c <Alt-Motion> {pdtk_canvas_motion %W %x %y 4} - } - bind $name.c <Map> {pdtk_canvas_map %W} - bind $name.c <Unmap> {pdtk_canvas_unmap %W} - focus $name.c - - switch $pd_nt { 0 { - bind $name.c <Button-4> "pdtk_canvas_scroll $name.c y -1" - bind $name.c <Button-5> "pdtk_canvas_scroll $name.c y +1" - bind $name.c <Shift-Button-4> "pdtk_canvas_scroll $name.c x -1" - bind $name.c <Shift-Button-5> "pdtk_canvas_scroll $name.c x +1" - } default { - bind $name.c <MouseWheel> \ - "pdtk_canvas_scroll $name.c y \[expr -abs(%D)/%D\]" - bind $name.c <Shift-MouseWheel> \ - "pdtk_canvas_scroll $name.c x \[expr -abs(%D)/%D\]" - }} - - catch { - dnd bindtarget $name.c text/uri-list <Drop> \ - "pdtk_canvas_makeobjs $name %D %x %y" - } - -# puts stderr "all done" -# after 1 [concat raise $name] - global pdtk_canvas_mouseup_name - set pdtk_canvas_mouseup_name "" -} - -#### jsarlo ##### -proc pdtk_array_listview_setpage {arrayName page} { - global pd_array_listview_page - set pd_array_listview_page($arrayName) $page -} - -proc pdtk_array_listview_changepage {arrayName np} { - global pd_array_listview_page - pdtk_array_listview_setpage \ - $arrayName [expr $pd_array_listview_page($arrayName) + $np] - pdtk_array_listview_fillpage $arrayName -} - -proc pdtk_array_listview_fillpage {arrayName} { - global pd_array_listview_page - global pd_array_listview_id - set windowName [format ".%sArrayWindow" $arrayName] - set topItem [expr [lindex [$windowName.lb yview] 0] * \ - [$windowName.lb size]] - - if {[winfo exists $windowName]} { - set cmd "$pd_array_listview_id($arrayName) \ - arrayviewlistfillpage \ - $pd_array_listview_page($arrayName) \ - $topItem" - - pd [concat $cmd \;] - } -} - -proc pdtk_array_listview_new {id arrayName page} { - global pd_nt - global pd_array_listview_page - global pd_array_listview_id - global fontname fontweight - set pd_array_listview_page($arrayName) $page - set pd_array_listview_id($arrayName) $id - set windowName [format ".%sArrayWindow" $arrayName] - if [winfo exists $windowName] then [destroy $windowName] - toplevel $windowName - wm protocol $windowName WM_DELETE_WINDOW \ - "pdtk_array_listview_close $id $arrayName" - wm title $windowName [concat $arrayName "(list view)"] - # FIXME - set font 12 - set $windowName.lb [listbox $windowName.lb -height 20 -width 25\ - -selectmode extended \ - -relief solid -background white -borderwidth 1 \ - -font [format {{%s} %d %s} $fontname $font $fontweight]\ - -yscrollcommand "$windowName.lb.sb set"] - set $windowName.lb.sb [scrollbar $windowName.lb.sb \ - -command "$windowName.lb yview" -orient vertical] - place configure $windowName.lb.sb -relheight 1 -relx 0.9 -relwidth 0.1 - pack $windowName.lb -expand 1 -fill both - bind $windowName.lb <Double-ButtonPress-1> \ - "pdtk_array_listview_edit $arrayName $page $font" - # handle copy/paste - if {$pd_nt == 0} { - selection handle $windowName.lb \ - "pdtk_array_listview_lbselection $arrayName" - } else { - if {$pd_nt == 1} { - bind $windowName.lb <ButtonPress-3> \ - "pdtk_array_listview_popup $arrayName" - } - } - set $windowName.prevBtn [button $windowName.prevBtn -text "<-" \ - -command "pdtk_array_listview_changepage $arrayName -1"] - set $windowName.nextBtn [button $windowName.nextBtn -text "->" \ - -command "pdtk_array_listview_changepage $arrayName 1"] - pack $windowName.prevBtn -side left -ipadx 20 -pady 10 -anchor s - pack $windowName.nextBtn -side right -ipadx 20 -pady 10 -anchor s - focus $windowName -} - -proc pdtk_array_listview_lbselection {arrayName off size} { - set windowName [format ".%sArrayWindow" $arrayName] - set itemNums [$windowName.lb curselection] - set cbString "" - for {set i 0} {$i < [expr [llength $itemNums] - 1]} {incr i} { - set listItem [$windowName.lb get [lindex $itemNums $i]] - append cbString [string range $listItem \ - [expr [string first ") " $listItem] + 2] \ - end] - append cbString "\n" - } - set listItem [$windowName.lb get [lindex $itemNums $i]] - append cbString [string range $listItem \ - [expr [string first ") " $listItem] + 2] \ - end] - set last $cbString -} - -# Win32 uses a popup menu for copy/paste -proc pdtk_array_listview_popup {arrayName} { - set windowName [format ".%sArrayWindow" $arrayName] - if [winfo exists $windowName.popup] then [destroy $windowName.popup] - menu $windowName.popup -tearoff false - $windowName.popup add command -label {Copy} \ - -command "pdtk_array_listview_copy $arrayName; \ - destroy $windowName.popup" - $windowName.popup add command -label {Paste} \ - -command "pdtk_array_listview_paste $arrayName; \ - destroy $windowName.popup" - tk_popup $windowName.popup [winfo pointerx $windowName] \ - [winfo pointery $windowName] 0 -} - -proc pdtk_array_listview_copy {arrayName} { - set windowName [format ".%sArrayWindow" $arrayName] - set itemNums [$windowName.lb curselection] - set cbString "" - for {set i 0} {$i < [expr [llength $itemNums] - 1]} {incr i} { - set listItem [$windowName.lb get [lindex $itemNums $i]] - append cbString [string range $listItem \ - [expr [string first ") " $listItem] + 2] \ - end] - append cbString "\n" - } - set listItem [$windowName.lb get [lindex $itemNums $i]] - append cbString [string range $listItem \ - [expr [string first ") " $listItem] + 2] \ - end] - clipboard clear - clipboard append $cbString -} - -proc pdtk_array_listview_paste {arrayName} { - global pd_array_listview_page - global pd_array_listview_pagesize - set cbString [selection get -selection CLIPBOARD] - set lbName [format ".%sArrayWindow.lb" $arrayName] - set itemNum [lindex [$lbName curselection] 0] - set splitChars ", \n" - set itemString [split $cbString $splitChars] - set flag 1 - for {set i 0; set counter 0} {$i < [llength $itemString]} {incr i} { - if {[lindex $itemString $i] != {}} { - pd [concat $arrayName [expr $itemNum + \ - [expr $counter + \ - [expr $pd_array_listview_pagesize \ - * $pd_array_listview_page($arrayName)]]] \ - [lindex $itemString $i] \;] - incr counter - set flag 0 - } - } -} - -proc pdtk_array_listview_edit {arrayName page font} { - global pd_array_listview_entry - global pd_nt - global fontname fontweight - set lbName [format ".%sArrayWindow.lb" $arrayName] - if {[winfo exists $lbName.entry]} { - pdtk_array_listview_update_entry \ - $arrayName $pd_array_listview_entry($arrayName) - unset pd_array_listview_entry($arrayName) - } - set itemNum [$lbName index active] - set pd_array_listview_entry($arrayName) $itemNum - set bbox [$lbName bbox $itemNum] - set y [expr [lindex $bbox 1] - 4] - set $lbName.entry [entry $lbName.entry \ - -font [format {{%s} %d %s} $fontname $font $fontweight]] - $lbName.entry insert 0 [] - place configure $lbName.entry -relx 0 -y $y -relwidth 1 - lower $lbName.entry - focus $lbName.entry - bind $lbName.entry <Return> \ - "pdtk_array_listview_update_entry $arrayName $itemNum;" -} - -proc pdtk_array_listview_update_entry {arrayName itemNum} { - global pd_array_listview_page - global pd_array_listview_pagesize - set lbName [format ".%sArrayWindow.lb" $arrayName] - set splitChars ", \n" - set itemString [split [$lbName.entry get] $splitChars] - set flag 1 - for {set i 0; set counter 0} {$i < [llength $itemString]} {incr i} { - if {[lindex $itemString $i] != {}} { - pd [concat $arrayName [expr $itemNum + \ - [expr $counter + \ - [expr $pd_array_listview_pagesize \ - * $pd_array_listview_page($arrayName)]]] \ - [lindex $itemString $i] \;] - incr counter - set flag 0 - } - } - pdtk_array_listview_fillpage $arrayName - destroy $lbName.entry -} - -proc pdtk_array_listview_closeWindow {arrayName} { - set windowName [format ".%sArrayWindow" $arrayName] - destroy $windowName -} - -proc pdtk_array_listview_close {id arrayName} { - pdtk_array_listview_closeWindow $arrayName - set cmd [concat $id "arrayviewclose" \;] - pd $cmd -} -##### end jsarlo ##### - -#################### event binding procedures ################ - -#get the name of the toplevel window for a canvas; this is also -#the name of the canvas object in Pd. - -proc canvastosym {name} { - string range $name 0 [expr [string length $name] - 3] -} - -set pdtk_lastcanvasconfigured "" -set pdtk_lastcanvasconfiguration "" -set pdtk_lastcanvasconfiguration2 "" - -proc pdtk_canvas_checkgeometry {topname} { - set boo [winfo geometry $topname.c] - set boo2 [wm geometry $topname] - global pdtk_lastcanvasconfigured - global pdtk_lastcanvasconfiguration - global pdtk_lastcanvasconfiguration2 - if {$topname != $pdtk_lastcanvasconfigured || \ - $boo != $pdtk_lastcanvasconfiguration || \ - $boo2 != $pdtk_lastcanvasconfiguration2} { - set pdtk_lastcanvasconfigured $topname - set pdtk_lastcanvasconfiguration $boo - set pdtk_lastcanvasconfiguration2 $boo2 - pd $topname relocate $boo $boo2 \; - } -} - -proc pdtk_canvas_click {name x y b f} { - global pd_nt - if {$pd_nt == 0} {focus $name} - pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b $f \; -} - -proc pdtk_canvas_shiftclick {name x y b} { - pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 1 \; -} - -proc pdtk_canvas_ctrlclick {name x y b} { - pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 2 \; -} - -proc pdtk_canvas_altclick {name x y b} { - pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 3 \; -} - -proc pdtk_canvas_dblclick {name x y b} { - pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 4 \; -} - -set pdtk_canvas_mouseup_name 0 -set pdtk_canvas_mouseup_xminval 0 -set pdtk_canvas_mouseup_xmaxval 0 -set pdtk_canvas_mouseup_yminval 0 -set pdtk_canvas_mouseup_ymaxval 0 - -proc pdtk_canvas_mouseup {name x y b} { - pd [concat [canvastosym $name] mouseup [$name canvasx $x] \ - [$name canvasy $y] $b \;] -} - -proc pdtk_canvas_getscroll {name} { - global pdtk_canvas_mouseup_name - global pdtk_canvas_mouseup_xminval - global pdtk_canvas_mouseup_xmaxval - global pdtk_canvas_mouseup_yminval - global pdtk_canvas_mouseup_ymaxval - - set size [$name bbox all] - if {$size != ""} { - set xminval 0 - set yminval 0 - set xmaxval 100 - set ymaxval 100 - set x1 [lindex $size 0] - set x2 [lindex $size 2] - set y1 [lindex $size 1] - set y2 [lindex $size 3] - - if {$x1 < 0} {set xminval $x1} - if {$y1 < 0} {set yminval $y1} - - if {$x2 > 100} {set xmaxval $x2} - if {$y2 > 100} {set ymaxval $y2} - - if {$pdtk_canvas_mouseup_name != $name || \ - $pdtk_canvas_mouseup_xminval != $xminval || \ - $pdtk_canvas_mouseup_xmaxval != $xmaxval || \ - $pdtk_canvas_mouseup_yminval != $yminval || \ - $pdtk_canvas_mouseup_ymaxval != $ymaxval } { - - set newsize "$xminval $yminval $xmaxval $ymaxval" - $name configure -scrollregion $newsize - set pdtk_canvas_mouseup_name $name - set pdtk_canvas_mouseup_xminval $xminval - set pdtk_canvas_mouseup_xmaxval $xmaxval - set pdtk_canvas_mouseup_yminval $yminval - set pdtk_canvas_mouseup_ymaxval $ymaxval - } - - } - pdtk_canvas_checkgeometry [canvastosym $name] -} - -proc pdtk_canvas_key {name key iso shift} { -# puts stderr [concat down key= $key iso= $iso] -# .controls.switches.meterbutton configure -text $key -# HACK for MAC OSX -- backspace seems different; I don't understand why. -# invesigate this LATER... - global pd_nt - if {$pd_nt == 2} { - if {$key == "BackSpace"} { - set key 8 - set keynum 8 - } - if {$key == "Delete"} { - set key 8 - set keynum 8 - } - } - if {$key == "KP_Delete"} { - set key 127 - set keynum 127 - } - if {$iso != ""} { - scan $iso %c keynum - pd [canvastosym $name] key 1 $keynum $shift\; - } else { - pd [canvastosym $name] key 1 $key $shift\; - } -} - -proc pdtk_canvas_keyup {name key iso} { -# puts stderr [concat up key= $key iso= $iso] - if {$iso != ""} { - scan $iso %c keynum - pd [canvastosym $name] key 0 $keynum 0 \; - } else { - pd [canvastosym $name] key 0 $key 0 \; - } -} - -proc pdtk_canvas_ctrlkey {name key shift} { -# first get rid of ".c" suffix; we'll refer to the toplevel instead - set topname [string trimright $name .c] -# puts stderr [concat ctrl-key $key $topname] - - if {$key == "1"} {menu_object $topname 1} - if {$key == "2"} {menu_message $topname 1} - if {$key == "3"} {menu_floatatom $topname 1} - if {$key == "4"} {menu_symbolatom $topname 1} - if {$key == "5"} {menu_comment $topname 1} - if {$key == "slash"} {menu_audio 1} - if {$key == "period"} {menu_audio 0} - if {$key == "Return"} {menu_reselect $topname} - if {$shift == 1} { - if {$key == "q" || $key == "Q"} {menu_really_quit} - if {$key == "w" || $key == "W"} {menu_really_close $topname} - if {$key == "s" || $key == "S"} {menu_saveas $topname} - if {$key == "z" || $key == "Z"} {menu_redo $topname} - if {$key == "b" || $key == "B"} {menu_bng $topname 1} - if {$key == "t" || $key == "T"} {menu_toggle $topname 1} - if {$key == "n" || $key == "N"} {menu_numbox $topname 1} - if {$key == "v" || $key == "V"} {menu_vslider $topname 1} - if {$key == "h" || $key == "H"} {menu_hslider $topname 1} - if {$key == "i" || $key == "I"} {menu_hradio $topname 1} - if {$key == "d" || $key == "D"} {menu_vradio $topname 1} - if {$key == "u" || $key == "U"} {menu_vumeter $topname 1} - if {$key == "c" || $key == "C"} {menu_mycnv $topname 1} - } else { - if {$key == "e" || $key == "E"} {menu_editmode $topname} - if {$key == "q" || $key == "Q"} {menu_quit} - if {$key == "s" || $key == "S"} {menu_save $topname} - if {$key == "z" || $key == "Z"} {menu_undo $topname} - if {$key == "n" || $key == "N"} {menu_new} - if {$key == "o" || $key == "O"} {menu_open $topname} - if {$key == "m" || $key == "M"} {menu_send} - if {$key == "w" || $key == "W"} {menu_close $topname} - if {$key == "p" || $key == "P"} {menu_print $topname} - if {$key == "x" || $key == "X"} {menu_cut $topname} - if {$key == "c" || $key == "C"} {menu_copy $topname} - if {$key == "v" || $key == "V"} {menu_paste $topname} - if {$key == "d" || $key == "D"} {menu_duplicate $topname} - if {$key == "a" || $key == "A"} {menu_selectall $topname} - if {$key == "t" || $key == "T"} {menu_texteditor $topname} - if {$key == "f" || $key == "F"} {menu_findobject $topname} - if {$key == "g" || $key == "G"} {menu_findagain $topname} - } -} - -proc pdtk_canvas_scroll {canvas xy distance} { - $canvas [list $xy]view scroll $distance units -} - -proc pdtk_canvas_motion {name x y mods} { -# puts stderr [concat [canvastosym $name] $name $x $y] - pd [canvastosym $name] motion [$name canvasx $x] [$name canvasy $y] $mods \; -} - -# "map" event tells us when the canvas becomes visible (arg is "0") or -# invisible (arg is ""). Invisibility means the Window Manager has minimized -# us. We don't get a final "unmap" event when we destroy the window. -proc pdtk_canvas_map {name} { -# puts stderr [concat map $name] - pd [canvastosym $name] map 1 \; -} - -proc pdtk_canvas_unmap {name} { -# puts stderr [concat unmap $name] - pd [canvastosym $name] map 0 \; -} - -proc pdtk_canvas_makeobjs {name files x y} { - set c 0 - for {set n 0} {$n < [llength $files]} {incr n} { - if {[regexp {.*/(.+).pd$} [lindex $files $n] file obj] == 1} { - pd $name obj $x [expr $y + ($c * 30)] [pdtk_enquote $obj] \; - incr c - } - } -} - -set saveas_dir nowhere - -############ pdtk_canvas_saveas -- run a saveas dialog ############## - -proc pdtk_canvas_saveas {name initfile initdir} { - global pd_nt - set filename [tk_getSaveFile -initialfile $initfile \ - -initialdir $initdir -defaultextension .pd -parent $name.c \ - -filetypes { {{pd files} {.pd}} {{max files} {.pat}} }] - - if {$filename != ""} { -# yes, we need the extent even if we're on a mac. - if {$pd_nt == 2} { - if {[string last .pd $filename] < 0 && \ - [string last .PD $filename] < 0 && \ - [string last .pat $filename] < 0 && \ - [string last .PAT $filename] < 0} { - set filename $filename.pd - if {[file exists $filename]} { - set answer [tk_messageBox \ - \-message [concat overwrite $filename "?"] \ - \-type yesno \-icon question] - if {! [string compare $answer no]} {return} - } - } - } - - set directory [string range $filename 0 \ - [expr [string last / $filename ] - 1]] - set basename [string range $filename \ - [expr [string last / $filename ] + 1] end] - pd [concat $name savetofile [pdtk_enquote $basename] \ - [pdtk_enquote $directory] \;] -# pd [concat $name savetofile $basename $directory \;] - } -} - -############ pdtk_canvas_dofont -- run a font and resize dialog ######### - -set fontsize 0 -set stretchval 0 -set whichstretch 0 - -proc dofont_apply {name} { - global fontsize - global stretchval - global whichstretch - set cmd [concat $name font $fontsize $stretchval $whichstretch \;] -# puts stderr $cmd - pd $cmd -} - -proc dofont_cancel {name} { - set cmd [concat $name cancel \;] -# puts stderr $cmd - pd $cmd -} - -proc pdtk_canvas_dofont {name initsize} { - - global fontsize - set fontsize $initsize - - global stretchval - set stretchval 100 - - global whichstretch - set whichstretch 1 - - toplevel $name - wm title $name {FONT BOMB} - wm protocol $name WM_DELETE_WINDOW [concat dofont_cancel $name] - - frame $name.buttonframe - pack $name.buttonframe -side bottom -fill x -pady 2m - button $name.buttonframe.cancel -text {Cancel}\ - -command "dofont_cancel $name" - button $name.buttonframe.ok -text {Do it}\ - -command "dofont_apply $name" - pack $name.buttonframe.cancel -side left -expand 1 - pack $name.buttonframe.ok -side left -expand 1 - - frame $name.radiof - pack $name.radiof -side left - - label $name.radiof.label -text {Font Size:} - pack $name.radiof.label -side top - - radiobutton $name.radiof.radio8 -value 8 -variable fontsize -text "8" - radiobutton $name.radiof.radio10 -value 10 -variable fontsize -text "10" - radiobutton $name.radiof.radio12 -value 12 -variable fontsize -text "12" - radiobutton $name.radiof.radio16 -value 16 -variable fontsize -text "16" - radiobutton $name.radiof.radio24 -value 24 -variable fontsize -text "24" - radiobutton $name.radiof.radio36 -value 36 -variable fontsize -text "36" - pack $name.radiof.radio8 -side top -anchor w - pack $name.radiof.radio10 -side top -anchor w - pack $name.radiof.radio12 -side top -anchor w - pack $name.radiof.radio16 -side top -anchor w - pack $name.radiof.radio24 -side top -anchor w - pack $name.radiof.radio36 -side top -anchor w - - frame $name.stretchf - pack $name.stretchf -side left - - label $name.stretchf.label -text {Stretch:} - pack $name.stretchf.label -side top - - entry $name.stretchf.entry -textvariable stretchval -width 5 - pack $name.stretchf.entry -side left - - radiobutton $name.stretchf.radio1 \ - -value 1 -variable whichstretch -text "X and Y" - radiobutton $name.stretchf.radio2 \ - -value 2 -variable whichstretch -text "X only" - radiobutton $name.stretchf.radio3 \ - -value 3 -variable whichstretch -text "Y only" - - pack $name.stretchf.radio1 -side top -anchor w - pack $name.stretchf.radio2 -side top -anchor w - pack $name.stretchf.radio3 -side top -anchor w - -} - -############ pdtk_gatom_dialog -- run a gatom dialog ######### - -# dialogs like this one can come up in many copies; but in TK the easiest -# way to get data from an "entry", etc., is to set an associated variable -# name. This is especially true for grouped "radio buttons". So we have -# to synthesize variable names for each instance of the dialog. The dialog -# gets a TK pathname $id, from which it strips the leading "." to make a -# variable suffix $vid. Then you can get the actual value out by asking for -# [eval concat $$variablename]. There should be an easier way but I don't see -# it yet. - -proc gatom_escape {sym} { - if {[string length $sym] == 0} { - set ret "-" -# puts stderr [concat escape1 $sym $ret] - } else { - if {[string equal -length 1 $sym "-"]} { - set ret [string replace $sym 0 0 "--"] -# puts stderr [concat escape $sym $ret] - } else { - set ret [string map {"$" "#"} $sym] -# puts stderr [concat unescape $sym $ret] - } - } - pdtk_unspace $ret -} - -proc gatom_unescape {sym} { - if {[string equal -length 1 $sym "-"]} { - set ret [string replace $sym 0 0 ""] -# puts stderr [concat unescape $sym $ret] - } else { - set ret [string map {"#" "$"} $sym] -# puts stderr [concat unescape $sym $ret] - } - concat $ret -} - -proc dogatom_apply {id} { - set vid [string trimleft $id .] - - set var_gatomwidth [concat gatomwidth_$vid] - global $var_gatomwidth - set var_gatomlo [concat gatomlo_$vid] - global $var_gatomlo - set var_gatomhi [concat gatomhi_$vid] - global $var_gatomhi - set var_gatomwherelabel [concat gatomwherelabel_$vid] - global $var_gatomwherelabel - set var_gatomlabel [concat gatomlabel_$vid] - global $var_gatomlabel - set var_gatomsymfrom [concat gatomsymfrom_$vid] - global $var_gatomsymfrom - set var_gatomsymto [concat gatomsymto_$vid] - global $var_gatomsymto - -# set cmd [concat $id param $gatomwidth $gatomlo $gatomhi \;] - - set cmd [concat $id param \ - [eval concat $$var_gatomwidth] \ - [eval concat $$var_gatomlo] \ - [eval concat $$var_gatomhi] \ - [eval gatom_escape $$var_gatomlabel] \ - [eval concat $$var_gatomwherelabel] \ - [eval gatom_escape $$var_gatomsymfrom] \ - [eval gatom_escape $$var_gatomsymto] \ - \;] - -# puts stderr $cmd - pd $cmd -} - -proc dogatom_cancel {name} { - set cmd [concat $name cancel \;] -# puts stderr $cmd - pd $cmd -} - -proc dogatom_ok {name} { - dogatom_apply $name - dogatom_cancel $name -} - -proc pdtk_gatom_dialog {id initwidth initlo inithi \ - wherelabel label symfrom symto} { - - set vid [string trimleft $id .] - - global pd_nt - - set var_gatomwidth [concat gatomwidth_$vid] - global $var_gatomwidth - set var_gatomlo [concat gatomlo_$vid] - global $var_gatomlo - set var_gatomhi [concat gatomhi_$vid] - global $var_gatomhi - set var_gatomwherelabel [concat gatomwherelabel_$vid] - global $var_gatomwherelabel - set var_gatomlabel [concat gatomlabel_$vid] - global $var_gatomlabel - set var_gatomsymfrom [concat gatomsymfrom_$vid] - global $var_gatomsymfrom - set var_gatomsymto [concat gatomsymto_$vid] - global $var_gatomsymto - - set $var_gatomwidth $initwidth - set $var_gatomlo $initlo - set $var_gatomhi $inithi - set $var_gatomwherelabel $wherelabel - set $var_gatomlabel [gatom_unescape $label] - set $var_gatomsymfrom [gatom_unescape $symfrom] - set $var_gatomsymto [gatom_unescape $symto] - - toplevel $id - wm title $id "atom box properties" - wm resizable $id 0 0 - wm protocol $id WM_DELETE_WINDOW [concat dogatom_cancel $id] - - frame $id.params -height 7 - pack $id.params -side top - label $id.params.entryname -text "width" - entry $id.params.entry -textvariable $var_gatomwidth -width 4 - pack $id.params.entryname $id.params.entry -side left - - labelframe $id.limits -text "limits" -padx 15 -pady 4 -borderwidth 1 \ - -font highlight_font - pack $id.limits -side top -fill x - frame $id.limits.lower - pack $id.limits.lower -side left - label $id.limits.lower.entryname -text "lower" - entry $id.limits.lower.entry -textvariable $var_gatomlo -width 8 - pack $id.limits.lower.entryname $id.limits.lower.entry -side left - frame $id.limits.upper - pack $id.limits.upper -side left - frame $id.limits.upper.spacer -width 20 - label $id.limits.upper.entryname -text "upper" - entry $id.limits.upper.entry -textvariable $var_gatomhi -width 8 - pack $id.limits.upper.spacer $id.limits.upper.entryname \ - $id.limits.upper.entry -side left - - frame $id.spacer1 -height 7 - pack $id.spacer1 -side top - - labelframe $id.label -text "label" -padx 5 -pady 4 -borderwidth 1 \ - -font highlight_font - pack $id.label -side top -fill x - frame $id.label.name - pack $id.label.name -side top - entry $id.label.name.entry -textvariable $var_gatomlabel -width 33 - pack $id.label.name.entry -side left - frame $id.label.radio - pack $id.label.radio -side top - radiobutton $id.label.radio.left -value 0 \ - -variable $var_gatomwherelabel \ - -text "left " -justify left - radiobutton $id.label.radio.right -value 1 \ - -variable $var_gatomwherelabel \ - -text "right" -justify left - radiobutton $id.label.radio.top -value 2 \ - -variable $var_gatomwherelabel \ - -text "top" -justify left - radiobutton $id.label.radio.bottom -value 3 \ - -variable $var_gatomwherelabel \ - -text "bottom" -justify left - pack $id.label.radio.left -side left -anchor w - pack $id.label.radio.right -side right -anchor w - pack $id.label.radio.top -side top -anchor w - pack $id.label.radio.bottom -side bottom -anchor w - - frame $id.spacer2 -height 7 - pack $id.spacer2 -side top - - labelframe $id.s_r -text "messages" -padx 5 -pady 4 -borderwidth 1 \ - -font highlight_font - pack $id.s_r -side top -fill x - frame $id.s_r.paramsymto - pack $id.s_r.paramsymto -side top -anchor e - label $id.s_r.paramsymto.entryname -text "send symbol" - entry $id.s_r.paramsymto.entry -textvariable $var_gatomsymto -width 21 - pack $id.s_r.paramsymto.entry $id.s_r.paramsymto.entryname -side right - - frame $id.s_r.paramsymfrom - pack $id.s_r.paramsymfrom -side top -anchor e - label $id.s_r.paramsymfrom.entryname -text "receive symbol" - entry $id.s_r.paramsymfrom.entry -textvariable $var_gatomsymfrom -width 21 - pack $id.s_r.paramsymfrom.entry $id.s_r.paramsymfrom.entryname -side right - - frame $id.buttonframe -pady 5 - pack $id.buttonframe -side top -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "dogatom_cancel $id" - pack $id.buttonframe.cancel -side left -expand 1 - button $id.buttonframe.apply -text {Apply}\ - -command "dogatom_apply $id" - pack $id.buttonframe.apply -side left -expand 1 - button $id.buttonframe.ok -text {OK}\ - -command "dogatom_ok $id" - pack $id.buttonframe.ok -side left -expand 1 - - bind $id.limits.upper.entry <KeyPress-Return> [concat dogatom_ok $id] - bind $id.limits.lower.entry <KeyPress-Return> [concat dogatom_ok $id] - bind $id.params.entry <KeyPress-Return> [concat dogatom_ok $id] - pdtk_standardkeybindings $id.limits.upper.entry - pdtk_standardkeybindings $id.limits.lower.entry - pdtk_standardkeybindings $id.params.entry - $id.params.entry select from 0 - $id.params.entry select adjust end - focus $id.params.entry -} - -############ pdtk_canvas_popup -- popup menu for canvas ######### - -set popup_xpix 0 -set popup_ypix 0 - -proc popup_action {name action} { - global popup_xpix popup_ypix - set cmd [concat $name done-popup $action $popup_xpix $popup_ypix \;] -# puts stderr $cmd - pd $cmd -} - -proc pdtk_canvas_popup {name xpix ypix canprop canopen} { - global popup_xpix popup_ypix - set popup_xpix $xpix - set popup_ypix $ypix - if {$canprop == 0} {$name.popup entryconfigure 0 -state disabled} - if {$canprop == 1} {$name.popup entryconfigure 0 -state active} - if {$canopen == 0} {$name.popup entryconfigure 1 -state disabled} - if {$canopen == 1} {$name.popup entryconfigure 1 -state active} - tk_popup $name.popup [expr $xpix + [winfo rootx $name.c]] \ - [expr $ypix + [winfo rooty $name.c]] 0 -} - - -# begin of change "iemlib" -############ pdtk_iemgui_dialog -- dialog window for iem guis ######### - -set iemgui_define_min_flashhold 50 -set iemgui_define_min_flashbreak 10 -set iemgui_define_min_fontsize 4 - -proc iemgui_clip_dim {id} { - set vid [string trimleft $id .] - - set var_iemgui_wdt [concat iemgui_wdt_$vid] - global $var_iemgui_wdt - set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid] - global $var_iemgui_min_wdt - set var_iemgui_hgt [concat iemgui_hgt_$vid] - global $var_iemgui_hgt - set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid] - global $var_iemgui_min_hgt - - if {[eval concat $$var_iemgui_wdt] < [eval concat $$var_iemgui_min_wdt]} { - set $var_iemgui_wdt [eval concat $$var_iemgui_min_wdt] - $id.dim.w_ent configure -textvariable $var_iemgui_wdt - } - if {[eval concat $$var_iemgui_hgt] < [eval concat $$var_iemgui_min_hgt]} { - set $var_iemgui_hgt [eval concat $$var_iemgui_min_hgt] - $id.dim.h_ent configure -textvariable $var_iemgui_hgt - } -} - -proc iemgui_clip_num {id} { - set vid [string trimleft $id .] - - set var_iemgui_num [concat iemgui_num_$vid] - global $var_iemgui_num - - if {[eval concat $$var_iemgui_num] > 2000} { - set $var_iemgui_num 2000 - $id.para.num_ent configure -textvariable $var_iemgui_num - } - if {[eval concat $$var_iemgui_num] < 1} { - set $var_iemgui_num 1 - $id.para.num_ent configure -textvariable $var_iemgui_num - } -} - -proc iemgui_sched_rng {id} { - set vid [string trimleft $id .] - - set var_iemgui_min_rng [concat iemgui_min_rng_$vid] - global $var_iemgui_min_rng - set var_iemgui_max_rng [concat iemgui_max_rng_$vid] - global $var_iemgui_max_rng - set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid] - global $var_iemgui_rng_sch - - global iemgui_define_min_flashhold - global iemgui_define_min_flashbreak - - if {[eval concat $$var_iemgui_rng_sch] == 2} { - if {[eval concat $$var_iemgui_max_rng] < [eval concat $$var_iemgui_min_rng]} { - set hhh [eval concat $$var_iemgui_min_rng] - set $var_iemgui_min_rng [eval concat $$var_iemgui_max_rng] - set $var_iemgui_max_rng $hhh - $id.rng.max_ent configure -textvariable $var_iemgui_max_rng - $id.rng.min_ent configure -textvariable $var_iemgui_min_rng } - if {[eval concat $$var_iemgui_max_rng] < $iemgui_define_min_flashhold} { - set $var_iemgui_max_rng $iemgui_define_min_flashhold - $id.rng.max_ent configure -textvariable $var_iemgui_max_rng - } - if {[eval concat $$var_iemgui_min_rng] < $iemgui_define_min_flashbreak} { - set $var_iemgui_min_rng $iemgui_define_min_flashbreak - $id.rng.min_ent configure -textvariable $var_iemgui_min_rng - } - } - if {[eval concat $$var_iemgui_rng_sch] == 1} { - if {[eval concat $$var_iemgui_min_rng] == 0.0} { - set $var_iemgui_min_rng 1.0 - $id.rng.min_ent configure -textvariable $var_iemgui_min_rng - } - } -} - -proc iemgui_verify_rng {id} { - set vid [string trimleft $id .] - - set var_iemgui_min_rng [concat iemgui_min_rng_$vid] - global $var_iemgui_min_rng - set var_iemgui_max_rng [concat iemgui_max_rng_$vid] - global $var_iemgui_max_rng - set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid] - global $var_iemgui_lin0_log1 - - if {[eval concat $$var_iemgui_lin0_log1] == 1} { - if {[eval concat $$var_iemgui_max_rng] == 0.0 && [eval concat $$var_iemgui_min_rng] == 0.0} { - set $var_iemgui_max_rng 1.0 - $id.rng.max_ent configure -textvariable $var_iemgui_max_rng - } - if {[eval concat $$var_iemgui_max_rng] > 0} { - if {[eval concat $$var_iemgui_min_rng] <= 0} { - set $var_iemgui_min_rng [expr [eval concat $$var_iemgui_max_rng] * 0.01] - $id.rng.min_ent configure -textvariable $var_iemgui_min_rng - } - } else { - if {[eval concat $$var_iemgui_min_rng] > 0} { - set $var_iemgui_max_rng [expr [eval concat $$var_iemgui_min_rng] * 0.01] - $id.rng.max_ent configure -textvariable $var_iemgui_max_rng - } - } - } -} - -proc iemgui_clip_fontsize {id} { - set vid [string trimleft $id .] - - set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid] - global $var_iemgui_gn_fs - - global iemgui_define_min_fontsize - - if {[eval concat $$var_iemgui_gn_fs] < $iemgui_define_min_fontsize} { - set $var_iemgui_gn_fs $iemgui_define_min_fontsize - $id.label.fs_ent configure -textvariable $var_iemgui_gn_fs - } -} - -proc iemgui_set_col_example {id} { - set vid [string trimleft $id .] - - set var_iemgui_bcol [concat iemgui_bcol_$vid] - global $var_iemgui_bcol - set var_iemgui_fcol [concat iemgui_fcol_$vid] - global $var_iemgui_fcol - set var_iemgui_lcol [concat iemgui_lcol_$vid] - global $var_iemgui_lcol - - $id.colors.sections.lb_bk configure \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] - - if { [eval concat $$var_iemgui_fcol] >= 0 } { - $id.colors.sections.fr_bk configure \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] - } else { - $id.colors.sections.fr_bk configure \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]]} -} - -proc iemgui_preset_col {id presetcol} { - set vid [string trimleft $id .] - - set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid] - global $var_iemgui_l2_f1_b0 - set var_iemgui_bcol [concat iemgui_bcol_$vid] - global $var_iemgui_bcol - set var_iemgui_fcol [concat iemgui_fcol_$vid] - global $var_iemgui_fcol - set var_iemgui_lcol [concat iemgui_lcol_$vid] - global $var_iemgui_lcol - - if { [eval concat $$var_iemgui_l2_f1_b0] == 0 } { set $var_iemgui_bcol $presetcol } - if { [eval concat $$var_iemgui_l2_f1_b0] == 1 } { set $var_iemgui_fcol $presetcol } - if { [eval concat $$var_iemgui_l2_f1_b0] == 2 } { set $var_iemgui_lcol $presetcol } - iemgui_set_col_example $id -} - -proc iemgui_choose_col_bkfrlb {id} { - set vid [string trimleft $id .] - - set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid] - global $var_iemgui_l2_f1_b0 - set var_iemgui_bcol [concat iemgui_bcol_$vid] - global $var_iemgui_bcol - set var_iemgui_fcol [concat iemgui_fcol_$vid] - global $var_iemgui_fcol - set var_iemgui_lcol [concat iemgui_lcol_$vid] - global $var_iemgui_lcol - - if {[eval concat $$var_iemgui_l2_f1_b0] == 0} { - set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC] - set helpstring [tk_chooseColor -title "Background-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_bcol]]] - if { $helpstring != "" } { - set $var_iemgui_bcol [string replace $helpstring 0 0 "0x"] - set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC] } - } - if {[eval concat $$var_iemgui_l2_f1_b0] == 1} { - set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC] - set helpstring [tk_chooseColor -title "Front-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_fcol]]] - if { $helpstring != "" } { - set $var_iemgui_fcol [string replace $helpstring 0 0 "0x"] - set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC] } - } - if {[eval concat $$var_iemgui_l2_f1_b0] == 2} { - set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC] - set helpstring [tk_chooseColor -title "Label-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_lcol]]] - if { $helpstring != "" } { - set $var_iemgui_lcol [string replace $helpstring 0 0 "0x"] - set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC] } - } - iemgui_set_col_example $id -} - -proc iemgui_lilo {id} { - set vid [string trimleft $id .] - - set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid] - global $var_iemgui_lin0_log1 - set var_iemgui_lilo0 [concat iemgui_lilo0_$vid] - global $var_iemgui_lilo0 - set var_iemgui_lilo1 [concat iemgui_lilo1_$vid] - global $var_iemgui_lilo1 - - iemgui_sched_rng $id - - if {[eval concat $$var_iemgui_lin0_log1] == 0} { - set $var_iemgui_lin0_log1 1 - $id.para.lilo configure -text [eval concat $$var_iemgui_lilo1] - iemgui_verify_rng $id - iemgui_sched_rng $id - } else { - set $var_iemgui_lin0_log1 0 - $id.para.lilo configure -text [eval concat $$var_iemgui_lilo0] - } -} - -proc iemgui_toggle_font {id gn_f} { - set vid [string trimleft $id .] - - set var_iemgui_gn_f [concat iemgui_gn_f_$vid] - global $var_iemgui_gn_f - global fontname fontweight - - set $var_iemgui_gn_f $gn_f - - switch -- $gn_f { - 0 { set current_font $fontname} - 1 { set current_font "Helvetica" } - 2 { set current_font "Times" } - } - set current_font_spec "{$current_font} 12 $fontweight" - - $id.label.fontpopup_label configure -text $current_font \ - -font $current_font_spec - $id.label.name_entry configure -font $current_font_spec - $id.colors.sections.fr_bk configure -font $current_font_spec - $id.colors.sections.lb_bk configure -font $current_font_spec -} - -proc iemgui_lb {id} { - set vid [string trimleft $id .] - - set var_iemgui_loadbang [concat iemgui_loadbang_$vid] - global $var_iemgui_loadbang - - if {[eval concat $$var_iemgui_loadbang] == 0} { - set $var_iemgui_loadbang 1 - $id.para.lb configure -text "init" - } else { - set $var_iemgui_loadbang 0 - $id.para.lb configure -text "no init" - } -} - -proc iemgui_stdy_jmp {id} { - set vid [string trimleft $id .] - - set var_iemgui_steady [concat iemgui_steady_$vid] - global $var_iemgui_steady - - if {[eval concat $$var_iemgui_steady]} { - set $var_iemgui_steady 0 - $id.para.stdy_jmp configure -text "jump on click" - } else { - set $var_iemgui_steady 1 - $id.para.stdy_jmp configure -text "steady on click" - } -} - -proc iemgui_apply {id} { - set vid [string trimleft $id .] - - set var_iemgui_wdt [concat iemgui_wdt_$vid] - global $var_iemgui_wdt - set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid] - global $var_iemgui_min_wdt - set var_iemgui_hgt [concat iemgui_hgt_$vid] - global $var_iemgui_hgt - set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid] - global $var_iemgui_min_hgt - set var_iemgui_min_rng [concat iemgui_min_rng_$vid] - global $var_iemgui_min_rng - set var_iemgui_max_rng [concat iemgui_max_rng_$vid] - global $var_iemgui_max_rng - set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid] - global $var_iemgui_lin0_log1 - set var_iemgui_lilo0 [concat iemgui_lilo0_$vid] - global $var_iemgui_lilo0 - set var_iemgui_lilo1 [concat iemgui_lilo1_$vid] - global $var_iemgui_lilo1 - set var_iemgui_loadbang [concat iemgui_loadbang_$vid] - global $var_iemgui_loadbang - set var_iemgui_num [concat iemgui_num_$vid] - global $var_iemgui_num - set var_iemgui_steady [concat iemgui_steady_$vid] - global $var_iemgui_steady - set var_iemgui_snd [concat iemgui_snd_$vid] - global $var_iemgui_snd - set var_iemgui_rcv [concat iemgui_rcv_$vid] - global $var_iemgui_rcv - set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid] - global $var_iemgui_gui_nam - set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid] - global $var_iemgui_gn_dx - set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid] - global $var_iemgui_gn_dy - set var_iemgui_gn_f [concat iemgui_gn_f_$vid] - global $var_iemgui_gn_f - set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid] - global $var_iemgui_gn_fs - set var_iemgui_bcol [concat iemgui_bcol_$vid] - global $var_iemgui_bcol - set var_iemgui_fcol [concat iemgui_fcol_$vid] - global $var_iemgui_fcol - set var_iemgui_lcol [concat iemgui_lcol_$vid] - global $var_iemgui_lcol - - iemgui_clip_dim $id - iemgui_clip_num $id - iemgui_sched_rng $id - iemgui_verify_rng $id - iemgui_sched_rng $id - iemgui_clip_fontsize $id - - if {[eval concat $$var_iemgui_snd] == ""} {set hhhsnd "empty"} else {set hhhsnd [eval concat $$var_iemgui_snd]} - if {[eval concat $$var_iemgui_rcv] == ""} {set hhhrcv "empty"} else {set hhhrcv [eval concat $$var_iemgui_rcv]} - if {[eval concat $$var_iemgui_gui_nam] == ""} {set hhhgui_nam "empty" - } else { - set hhhgui_nam [eval concat $$var_iemgui_gui_nam]} - - if {[string index $hhhsnd 0] == "$"} { - set hhhsnd [string replace $hhhsnd 0 0 #] } - if {[string index $hhhrcv 0] == "$"} { - set hhhrcv [string replace $hhhrcv 0 0 #] } - if {[string index $hhhgui_nam 0] == "$"} { - set hhhgui_nam [string replace $hhhgui_nam 0 0 #] } - - set hhhsnd [pdtk_unspace $hhhsnd] - set hhhrcv [pdtk_unspace $hhhrcv] - set hhhgui_nam [pdtk_unspace $hhhgui_nam] - - pd [concat $id dialog \ - [eval concat $$var_iemgui_wdt] \ - [eval concat $$var_iemgui_hgt] \ - [eval concat $$var_iemgui_min_rng] \ - [eval concat $$var_iemgui_max_rng] \ - [eval concat $$var_iemgui_lin0_log1] \ - [eval concat $$var_iemgui_loadbang] \ - [eval concat $$var_iemgui_num] \ - $hhhsnd \ - $hhhrcv \ - $hhhgui_nam \ - [eval concat $$var_iemgui_gn_dx] \ - [eval concat $$var_iemgui_gn_dy] \ - [eval concat $$var_iemgui_gn_f] \ - [eval concat $$var_iemgui_gn_fs] \ - [eval concat $$var_iemgui_bcol] \ - [eval concat $$var_iemgui_fcol] \ - [eval concat $$var_iemgui_lcol] \ - [eval concat $$var_iemgui_steady] \ - \;] -} - -proc iemgui_cancel {id} {pd [concat $id cancel \;]} - -proc iemgui_ok {id} { - iemgui_apply $id - iemgui_cancel $id -} - -proc pdtk_iemgui_dialog {id mainheader \ - dim_header wdt min_wdt wdt_label hgt min_hgt hgt_label \ - rng_header min_rng min_rng_label max_rng max_rng_label rng_sched \ - lin0_log1 lilo0_label lilo1_label loadbang steady num_label num \ - snd rcv \ - gui_name \ - gn_dx gn_dy \ - gn_f gn_fs \ - bcol fcol lcol} { - - set vid [string trimleft $id .] - - global pd_nt - global fontname fontweight - - set var_iemgui_wdt [concat iemgui_wdt_$vid] - global $var_iemgui_wdt - set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid] - global $var_iemgui_min_wdt - set var_iemgui_hgt [concat iemgui_hgt_$vid] - global $var_iemgui_hgt - set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid] - global $var_iemgui_min_hgt - set var_iemgui_min_rng [concat iemgui_min_rng_$vid] - global $var_iemgui_min_rng - set var_iemgui_max_rng [concat iemgui_max_rng_$vid] - global $var_iemgui_max_rng - set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid] - global $var_iemgui_rng_sch - set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid] - global $var_iemgui_lin0_log1 - set var_iemgui_lilo0 [concat iemgui_lilo0_$vid] - global $var_iemgui_lilo0 - set var_iemgui_lilo1 [concat iemgui_lilo1_$vid] - global $var_iemgui_lilo1 - set var_iemgui_loadbang [concat iemgui_loadbang_$vid] - global $var_iemgui_loadbang - set var_iemgui_num [concat iemgui_num_$vid] - global $var_iemgui_num - set var_iemgui_steady [concat iemgui_steady_$vid] - global $var_iemgui_steady - set var_iemgui_snd [concat iemgui_snd_$vid] - global $var_iemgui_snd - set var_iemgui_rcv [concat iemgui_rcv_$vid] - global $var_iemgui_rcv - set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid] - global $var_iemgui_gui_nam - set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid] - global $var_iemgui_gn_dx - set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid] - global $var_iemgui_gn_dy - set var_iemgui_gn_f [concat iemgui_gn_f_$vid] - global $var_iemgui_gn_f - set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid] - global $var_iemgui_gn_fs - set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid] - global $var_iemgui_l2_f1_b0 - set var_iemgui_bcol [concat iemgui_bcol_$vid] - global $var_iemgui_bcol - set var_iemgui_fcol [concat iemgui_fcol_$vid] - global $var_iemgui_fcol - set var_iemgui_lcol [concat iemgui_lcol_$vid] - global $var_iemgui_lcol - - set $var_iemgui_wdt $wdt - set $var_iemgui_min_wdt $min_wdt - set $var_iemgui_hgt $hgt - set $var_iemgui_min_hgt $min_hgt - set $var_iemgui_min_rng $min_rng - set $var_iemgui_max_rng $max_rng - set $var_iemgui_rng_sch $rng_sched - set $var_iemgui_lin0_log1 $lin0_log1 - set $var_iemgui_lilo0 $lilo0_label - set $var_iemgui_lilo1 $lilo1_label - set $var_iemgui_loadbang $loadbang - set $var_iemgui_num $num - set $var_iemgui_steady $steady - if {$snd == "empty"} {set $var_iemgui_snd [format ""] - } else {set $var_iemgui_snd [format "%s" $snd]} - if {$rcv == "empty"} {set $var_iemgui_rcv [format ""] - } else {set $var_iemgui_rcv [format "%s" $rcv]} - if {$gui_name == "empty"} {set $var_iemgui_gui_nam [format ""] - } else {set $var_iemgui_gui_nam [format "%s" $gui_name]} - - if {[string index [eval concat $$var_iemgui_snd] 0] == "#"} { - set $var_iemgui_snd [string replace [eval concat $$var_iemgui_snd] 0 0 $] } - if {[string index [eval concat $$var_iemgui_rcv] 0] == "#"} { - set $var_iemgui_rcv [string replace [eval concat $$var_iemgui_rcv] 0 0 $] } - if {[string index [eval concat $$var_iemgui_gui_nam] 0] == "#"} { - set $var_iemgui_gui_nam [string replace [eval concat $$var_iemgui_gui_nam] 0 0 $] } - set $var_iemgui_gn_dx $gn_dx - set $var_iemgui_gn_dy $gn_dy - set $var_iemgui_gn_f $gn_f - set $var_iemgui_gn_fs $gn_fs - - set $var_iemgui_bcol $bcol - set $var_iemgui_fcol $fcol - set $var_iemgui_lcol $lcol - - set $var_iemgui_l2_f1_b0 0 - - toplevel $id - wm title $id [format "%s Properties" $mainheader] - wm resizable $id 0 0 - wm protocol $id WM_DELETE_WINDOW [concat iemgui_cancel $id] - - frame $id.dim - pack $id.dim -side top - label $id.dim.head -text $dim_header - label $id.dim.w_lab -text $wdt_label -width 6 - entry $id.dim.w_ent -textvariable $var_iemgui_wdt -width 5 - label $id.dim.dummy1 -text " " -width 10 - label $id.dim.h_lab -text $hgt_label -width 6 - entry $id.dim.h_ent -textvariable $var_iemgui_hgt -width 5 - pack $id.dim.head -side top - pack $id.dim.w_lab $id.dim.w_ent $id.dim.dummy1 -side left - if { $hgt_label != "empty" } { - pack $id.dim.h_lab $id.dim.h_ent -side left} - - frame $id.rng - pack $id.rng -side top - label $id.rng.head -text $rng_header - label $id.rng.min_lab -text $min_rng_label -width 6 - entry $id.rng.min_ent -textvariable $var_iemgui_min_rng -width 9 - label $id.rng.dummy1 -text " " -width 1 - label $id.rng.max_lab -text $max_rng_label -width 8 - entry $id.rng.max_ent -textvariable $var_iemgui_max_rng -width 9 - if { $rng_header != "empty" } { - pack $id.rng.head -side top - if { $min_rng_label != "empty" } { - pack $id.rng.min_lab $id.rng.min_ent -side left} - if { $max_rng_label != "empty" } { - pack $id.rng.dummy1 \ - $id.rng.max_lab $id.rng.max_ent -side left} } - - if { [eval concat $$var_iemgui_lin0_log1] >= 0 || [eval concat $$var_iemgui_loadbang] >= 0 || [eval concat $$var_iemgui_num] > 0 || [eval concat $$var_iemgui_steady] >= 0 } { - label $id.space1 -text "" - pack $id.space1 -side top } - - frame $id.para - pack $id.para -side top - label $id.para.dummy2 -text "" -width 1 - label $id.para.dummy3 -text "" -width 1 - if {[eval concat $$var_iemgui_lin0_log1] == 0} { - button $id.para.lilo -text [eval concat $$var_iemgui_lilo0] -width 5 -command "iemgui_lilo $id" } - if {[eval concat $$var_iemgui_lin0_log1] == 1} { - button $id.para.lilo -text [eval concat $$var_iemgui_lilo1] -width 5 -command "iemgui_lilo $id" } - if {[eval concat $$var_iemgui_loadbang] == 0} { - button $id.para.lb -text "no init" -width 5 -command "iemgui_lb $id" } - if {[eval concat $$var_iemgui_loadbang] == 1} { - button $id.para.lb -text "init" -width 5 -command "iemgui_lb $id" } - label $id.para.num_lab -text $num_label -width 9 - entry $id.para.num_ent -textvariable $var_iemgui_num -width 4 - if {[eval concat $$var_iemgui_steady] == 0} { - button $id.para.stdy_jmp -text "jump on click" -width 11 -command "iemgui_stdy_jmp $id" } - if {[eval concat $$var_iemgui_steady] == 1} { - button $id.para.stdy_jmp -text "steady on click" -width 11 -command "iemgui_stdy_jmp $id" } - if {[eval concat $$var_iemgui_lin0_log1] >= 0} { - pack $id.para.lilo -side left -expand 1} - if {[eval concat $$var_iemgui_loadbang] >= 0} { - pack $id.para.dummy2 $id.para.lb -side left -expand 1} - if {[eval concat $$var_iemgui_num] > 0} { - pack $id.para.dummy3 $id.para.num_lab $id.para.num_ent -side left -expand 1} - if {[eval concat $$var_iemgui_steady] >= 0} { - pack $id.para.dummy3 $id.para.stdy_jmp -side left -expand 1} - - frame $id.spacer0 -height 4 - pack $id.spacer0 -side top - - labelframe $id.s_r -borderwidth 1 -pady 4 -text "messages" \ - -font highlight_font - pack $id.s_r -side top -fill x -ipadx 5 - frame $id.s_r.send - pack $id.s_r.send -side top - label $id.s_r.send.lab -text " send-symbol:" -width 12 -justify right - entry $id.s_r.send.ent -textvariable $var_iemgui_snd -width 22 - if { $snd != "nosndno" } { - pack $id.s_r.send.lab $id.s_r.send.ent -side left} - - frame $id.s_r.receive - pack $id.s_r.receive -side top - label $id.s_r.receive.lab -text "receive-symbol:" -width 12 -justify right - entry $id.s_r.receive.ent -textvariable $var_iemgui_rcv -width 22 - if { $rcv != "norcvno" } { - pack $id.s_r.receive.lab $id.s_r.receive.ent -side left} - -# get the current font name from the int given from C-space (gn_f) - set current_font $fontname - if {[eval concat $$var_iemgui_gn_f] == 1} \ - { set current_font "Helvetica" } - if {[eval concat $$var_iemgui_gn_f] == 2} \ - { set current_font "Times" } - - frame $id.spacer1 -height 7 - pack $id.spacer1 -side top - - labelframe $id.label -borderwidth 1 -text "label" -pady 4 \ - -font highlight_font - pack $id.label -side top -fill x - entry $id.label.name_entry -textvariable $var_iemgui_gui_nam -width 30 \ - -font [list $current_font 12 $fontweight] - pack $id.label.name_entry -side top -expand yes -fill both -padx 5 - - frame $id.label.xy -padx 27 -pady 1 - pack $id.label.xy -side top - label $id.label.xy.x_lab -text "x offset" -width 6 - entry $id.label.xy.x_entry -textvariable $var_iemgui_gn_dx -width 5 - label $id.label.xy.dummy1 -text " " -width 2 - label $id.label.xy.y_lab -text "y offset" -width 6 - entry $id.label.xy.y_entry -textvariable $var_iemgui_gn_dy -width 5 - pack $id.label.xy.x_lab $id.label.xy.x_entry $id.label.xy.dummy1 \ - $id.label.xy.y_lab $id.label.xy.y_entry -side left -anchor e - - label $id.label.fontpopup_label -text $current_font \ - -relief groove -font [list $current_font 12 $fontweight] -padx 5 - pack $id.label.fontpopup_label -side left -anchor w -expand yes -fill x - label $id.label.fontsize_label -text "size" -width 4 - entry $id.label.fontsize_entry -textvariable $var_iemgui_gn_fs -width 5 - pack $id.label.fontsize_entry $id.label.fontsize_label \ - -side right -anchor e -padx 5 -pady 5 - menu $id.popup - $id.popup add command \ - -label $fontname \ - -font [format {{%s} 12 %s} $fontname $fontweight] \ - -command "iemgui_toggle_font $id 0" - $id.popup add command \ - -label "Helvetica" \ - -font [format {Helvetica 12 %s} $fontweight] \ - -command "iemgui_toggle_font $id 1" - $id.popup add command \ - -label "Times" \ - -font [format {Times 12 %s} $fontweight] \ - -command "iemgui_toggle_font $id 2" - bind $id.label.fontpopup_label <Button> \ - [list tk_popup $id.popup %X %Y] - - frame $id.spacer2 -height 7 - pack $id.spacer2 -side top - - labelframe $id.colors -borderwidth 1 -text "colors" -font highlight_font - pack $id.colors -fill x -ipadx 5 -ipady 4 - - frame $id.colors.select - pack $id.colors.select -side top - radiobutton $id.colors.select.radio0 -value 0 -variable \ - $var_iemgui_l2_f1_b0 -text "background" -width 10 -justify left - radiobutton $id.colors.select.radio1 -value 1 -variable \ - $var_iemgui_l2_f1_b0 -text "front" -width 5 -justify left - radiobutton $id.colors.select.radio2 -value 2 -variable \ - $var_iemgui_l2_f1_b0 -text "label" -width 5 -justify left - if { [eval concat $$var_iemgui_fcol] >= 0 } { - pack $id.colors.select.radio0 $id.colors.select.radio1 \ - $id.colors.select.radio2 -side left - } else { - pack $id.colors.select.radio0 $id.colors.select.radio2 -side left \ - } - - frame $id.colors.sections - pack $id.colors.sections -side top - button $id.colors.sections.but -text "compose color" -width 12 \ - -command "iemgui_choose_col_bkfrlb $id" - pack $id.colors.sections.but -side left -anchor w -padx 10 -pady 5 \ - -expand yes -fill x - if { [eval concat $$var_iemgui_fcol] >= 0 } { - label $id.colors.sections.fr_bk -text "o=||=o" -width 6 \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \ - -font [list $current_font 12 $fontweight] -padx 2 -pady 2 -relief ridge - } else { - label $id.colors.sections.fr_bk -text "o=||=o" -width 6 \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -font [list $current_font 12 $fontweight] -padx 2 -pady 2 -relief ridge - } - label $id.colors.sections.lb_bk -text "testlabel" -width 9 \ - -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \ - -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \ - -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \ - -font [list $current_font 12 $fontweight] -padx 2 -pady 2 -relief ridge - pack $id.colors.sections.lb_bk $id.colors.sections.fr_bk \ - -side right -anchor e -expand yes -fill both -pady 7 - -# color scheme by Mary Ann Benedetto http://piR2.org - frame $id.colors.r1 - pack $id.colors.r1 -side top - foreach i { 0 1 2 3 4 5 6 7 8 9} \ - hexcol { 0xFFFFFF 0xDFDFDF 0xBBBBBB 0xFFC7C6 0xFFE3C6 \ - 0xFEFFC6 0xC6FFC7 0xc6FEFF 0xC7C6FF 0xE3C6FF } \ - { - label $id.colors.r1.c$i -background [format "#%6.6x" $hexcol] \ - -activebackground [format "#%6.6x" $hexcol] -relief ridge \ - -padx 7 -pady 0 - bind $id.colors.r1.c$i <Button> [format "iemgui_preset_col %s %d" $id $hexcol] - } - pack $id.colors.r1.c0 $id.colors.r1.c1 $id.colors.r1.c2 $id.colors.r1.c3 \ - $id.colors.r1.c4 $id.colors.r1.c5 $id.colors.r1.c6 $id.colors.r1.c7 \ - $id.colors.r1.c8 $id.colors.r1.c9 -side left - - frame $id.colors.r2 - pack $id.colors.r2 -side top - foreach i { 0 1 2 3 4 5 6 7 8 9 } \ - hexcol { 0x9F9F9F 0x7C7C7C 0x606060 0xFF0400 0xFF8300 \ - 0xFAFF00 0x00FF04 0x00FAFF 0x0400FF 0x9C00FF } \ - { - label $id.colors.r2.c$i -background [format "#%6.6x" $hexcol] \ - -activebackground [format "#%6.6x" $hexcol] -relief ridge \ - -padx 7 -pady 0 - bind $id.colors.r2.c$i <Button> \ - [format "iemgui_preset_col %s %d" $id $hexcol] - } - pack $id.colors.r2.c0 $id.colors.r2.c1 $id.colors.r2.c2 $id.colors.r2.c3 \ - $id.colors.r2.c4 $id.colors.r2.c5 $id.colors.r2.c6 $id.colors.r2.c7 \ - $id.colors.r2.c8 $id.colors.r2.c9 -side left - - frame $id.colors.r3 - pack $id.colors.r3 -side top - foreach i { 0 1 2 3 4 5 6 7 8 9 } \ - hexcol { 0x404040 0x202020 0x000000 0x551312 0x553512 \ - 0x535512 0x0F4710 0x0E4345 0x131255 0x2F004D } \ - { - label $id.colors.r3.c$i -background [format "#%6.6x" $hexcol] \ - -activebackground [format "#%6.6x" $hexcol] -relief ridge \ - -padx 7 -pady 0 - bind $id.colors.r3.c$i <Button> \ - [format "iemgui_preset_col %s %d" $id $hexcol] - } - pack $id.colors.r3.c0 $id.colors.r3.c1 $id.colors.r3.c2 $id.colors.r3.c3 \ - $id.colors.r3.c4 $id.colors.r3.c5 $id.colors.r3.c6 $id.colors.r3.c7 \ - $id.colors.r3.c8 $id.colors.r3.c9 -side left - - frame $id.cao -pady 10 - pack $id.cao -side top - button $id.cao.cancel -text {Cancel} -width 6 \ - -command "iemgui_cancel $id" - label $id.cao.dummy1 -text "" -width 3 - button $id.cao.apply -text {Apply} -width 6 -command "iemgui_apply $id" - label $id.cao.dummy2 -text "" -width 3 - button $id.cao.ok -text {OK} -width 6 \ - -command "iemgui_ok $id" - - pack $id.cao.cancel $id.cao.dummy1 -side left - pack $id.cao.apply $id.cao.dummy2 -side left - pack $id.cao.ok -side left - - if {[info tclversion] < 8.4} { - bind $id <Key-Tab> {tkTabToWindow [tk_focusNext %W]} - bind $id <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]} - } else { - bind $id <Key-Tab> {tk::TabToWindow [tk_focusNext %W]} - bind $id <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]} - } - - bind $id.dim.w_ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.dim.h_ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.rng.min_ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.rng.max_ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.para.num_ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.s_r.send.ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.s_r.receive.ent <KeyPress-Return> [concat iemgui_ok $id] - bind $id.label.name_entry <KeyPress-Return> [concat iemgui_ok $id] - bind $id.label.xy.x_entry <KeyPress-Return> [concat iemgui_ok $id] - bind $id.label.xy.y_entry <KeyPress-Return> [concat iemgui_ok $id] - bind $id.label.fontsize_entry <KeyPress-Return> [concat iemgui_ok $id] - bind $id.cao.ok <KeyPress-Return> [concat iemgui_ok $id] - pdtk_standardkeybindings $id.dim.w_ent - pdtk_standardkeybindings $id.dim.h_ent - pdtk_standardkeybindings $id.rng.min_ent - pdtk_standardkeybindings $id.rng.max_ent - pdtk_standardkeybindings $id.para.num_ent - pdtk_standardkeybindings $id.s_r.send.ent - pdtk_standardkeybindings $id.s_r.receive.ent - pdtk_standardkeybindings $id.label.name_entry - pdtk_standardkeybindings $id.label.xy.x_entry - pdtk_standardkeybindings $id.label.xy.y_entry - pdtk_standardkeybindings $id.label.fontsize_entry - pdtk_standardkeybindings $id.cao.ok - - $id.dim.w_ent select from 0 - $id.dim.w_ent select adjust end - focus $id.dim.w_ent -} -# end of change "iemlib" - -############ pdtk_array_dialog -- dialog window for arrays ######### -# see comments above (pdtk_gatom_dialog) about variable name handling - -proc array_apply {id} { -# strip "." from the TK id to make a variable name suffix - set vid [string trimleft $id .] -# for each variable, make a local variable to hold its name... - set var_array_name [concat array_name_$vid] - global $var_array_name - set var_array_n [concat array_n_$vid] - global $var_array_n - set var_array_saveit [concat array_saveit_$vid] - global $var_array_saveit - set var_array_drawasrects [concat array_drawasrects_$vid] - global $var_array_drawasrects - set var_array_otherflag [concat array_otherflag_$vid] - global $var_array_otherflag - set mofo [eval concat $$var_array_name] - if {[string index $mofo 0] == "$"} { - set mofo [string replace $mofo 0 0 #] } - - set saveit [eval concat $$var_array_saveit] - set drawasrects [eval concat $$var_array_drawasrects] - - pd [concat $id arraydialog $mofo \ - [eval concat $$var_array_n] \ - [expr $saveit + 2 * $drawasrects] \ - [eval concat $$var_array_otherflag] \ - \;] -} - -# jsarlo -proc array_viewlist {id} { - pd [concat $id arrayviewlistnew\;] -} -# end jsarlo - -proc array_cancel {id} { - set cmd [concat $id cancel \;] - pd $cmd -} - -proc array_ok {id} { - array_apply $id - array_cancel $id -} - -proc pdtk_array_dialog {id name n flags newone} { - set vid [string trimleft $id .] - - set var_array_name [concat array_name_$vid] - global $var_array_name - set var_array_n [concat array_n_$vid] - global $var_array_n - set var_array_saveit [concat array_saveit_$vid] - global $var_array_saveit - set var_array_drawasrects [concat array_drawasrects_$vid] - global $var_array_drawasrects - set var_array_otherflag [concat array_otherflag_$vid] - global $var_array_otherflag - - set $var_array_name $name - set $var_array_n $n - set $var_array_saveit [expr ( $flags & 1 ) != 0] - set $var_array_drawasrects [expr ( $flags & 2 ) != 0] - set $var_array_otherflag 0 - - toplevel $id - wm title $id {array} - wm resizable $id 0 0 - wm protocol $id WM_DELETE_WINDOW [concat array_cancel $id] - - frame $id.name - pack $id.name -side top - label $id.name.label -text "name" - entry $id.name.entry -textvariable $var_array_name - pack $id.name.label $id.name.entry -side left - - frame $id.n - pack $id.n -side top - label $id.n.label -text "size" - entry $id.n.entry -textvariable $var_array_n - pack $id.n.label $id.n.entry -side left - - checkbutton $id.saveme -text {save contents} -variable $var_array_saveit \ - -anchor w - pack $id.saveme -side top - - frame $id.drawasrects - pack $id.drawasrects -side top - radiobutton $id.drawasrects.drawasrects0 -value 0 \ - -variable $var_array_drawasrects \ - -text "draw as points" - radiobutton $id.drawasrects.drawasrects1 -value 1 \ - -variable $var_array_drawasrects \ - -text "polygon" - radiobutton $id.drawasrects.drawasrects2 -value 2 \ - -variable $var_array_drawasrects \ - -text "bezier curve" - pack $id.drawasrects.drawasrects0 -side top -anchor w - pack $id.drawasrects.drawasrects1 -side top -anchor w - pack $id.drawasrects.drawasrects2 -side top -anchor w - - if {$newone != 0} { - frame $id.radio - pack $id.radio -side top - radiobutton $id.radio.radio0 -value 0 \ - -variable $var_array_otherflag \ - -text "in new graph" - radiobutton $id.radio.radio1 -value 1 \ - -variable $var_array_otherflag \ - -text "in last graph" - pack $id.radio.radio0 -side top -anchor w - pack $id.radio.radio1 -side top -anchor w - } else { - checkbutton $id.deleteme -text {delete me} \ - -variable $var_array_otherflag -anchor w - pack $id.deleteme -side top - } - # jsarlo - if {$newone == 0} { - button $id.listview -text {View list}\ - -command "array_viewlist $id" - pack $id.listview -side left - } - # end jsarlo - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "array_cancel $id" - if {$newone == 0} {button $id.buttonframe.apply -text {Apply}\ - -command "array_apply $id"} - button $id.buttonframe.ok -text {OK}\ - -command "array_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - if {$newone == 0} {pack $id.buttonframe.apply -side left -expand 1} - pack $id.buttonframe.ok -side left -expand 1 - - bind $id.name.entry <KeyPress-Return> [concat array_ok $id] - bind $id.n.entry <KeyPress-Return> [concat array_ok $id] - pdtk_standardkeybindings $id.name.entry - pdtk_standardkeybindings $id.n.entry - $id.name.entry select from 0 - $id.name.entry select adjust end - focus $id.name.entry -} - -############ pdtk_canvas_dialog -- dialog window for canvass ######### -# see comments above (pdtk_gatom_dialog) about variable name handling - -proc canvas_apply {id} { -# strip "." from the TK id to make a variable name suffix - set vid [string trimleft $id .] -# for each variable, make a local variable to hold its name... - - set var_canvas_xscale [concat canvas_xscale_$vid] - global $var_canvas_xscale - set var_canvas_yscale [concat canvas_yscale_$vid] - global $var_canvas_yscale - set var_canvas_graphme [concat canvas_graphme_$vid] - global $var_canvas_graphme - set var_canvas_hidetext [concat canvas_hidetext_$vid] - global $var_canvas_hidetext - set var_canvas_x1 [concat canvas_x1_$vid] - global $var_canvas_x1 - set var_canvas_x2 [concat canvas_x2_$vid] - global $var_canvas_x2 - set var_canvas_xpix [concat canvas_xpix_$vid] - global $var_canvas_xpix - set var_canvas_xmargin [concat canvas_xmargin_$vid] - global $var_canvas_xmargin - set var_canvas_y1 [concat canvas_y1_$vid] - global $var_canvas_y1 - set var_canvas_y2 [concat canvas_y2_$vid] - global $var_canvas_y2 - set var_canvas_ypix [concat canvas_ypix_$vid] - global $var_canvas_ypix - set var_canvas_ymargin [concat canvas_ymargin_$vid] - global $var_canvas_ymargin - - pd [concat $id donecanvasdialog \ - [eval concat $$var_canvas_xscale] \ - [eval concat $$var_canvas_yscale] \ - [expr [eval concat $$var_canvas_graphme]+2*[eval concat $$var_canvas_hidetext]] \ - [eval concat $$var_canvas_x1] \ - [eval concat $$var_canvas_y1] \ - [eval concat $$var_canvas_x2] \ - [eval concat $$var_canvas_y2] \ - [eval concat $$var_canvas_xpix] \ - [eval concat $$var_canvas_ypix] \ - [eval concat $$var_canvas_xmargin] \ - [eval concat $$var_canvas_ymargin] \ - \;] -} - -proc canvas_cancel {id} { - set cmd [concat $id cancel \;] - pd $cmd -} - -proc canvas_ok {id} { - canvas_apply $id - canvas_cancel $id -} - -proc canvas_checkcommand {id} { - set vid [string trimleft $id .] -# puts stderr [concat canvas_checkcommand $id $vid] - - set var_canvas_xscale [concat canvas_xscale_$vid] - global $var_canvas_xscale - set var_canvas_yscale [concat canvas_yscale_$vid] - global $var_canvas_yscale - set var_canvas_graphme [concat canvas_graphme_$vid] - global $var_canvas_graphme - set var_canvas_hidetext [concat canvas_hidetext_$vid] - global $var_canvas_hidetext - set var_canvas_x1 [concat canvas_x1_$vid] - global $var_canvas_x1 - set var_canvas_x2 [concat canvas_x2_$vid] - global $var_canvas_x2 - set var_canvas_xpix [concat canvas_xpix_$vid] - global $var_canvas_xpix - set var_canvas_xmargin [concat canvas_xmargin_$vid] - global $var_canvas_xmargin - set var_canvas_y1 [concat canvas_y1_$vid] - global $var_canvas_y1 - set var_canvas_y2 [concat canvas_y2_$vid] - global $var_canvas_y2 - set var_canvas_ypix [concat canvas_ypix_$vid] - global $var_canvas_ypix - set var_canvas_ymargin [concat canvas_ymargin_$vid] - global $var_canvas_ymargin - - if { [eval concat $$var_canvas_graphme] != 0 } { - $id.hidetext configure -state normal - $id.xrange.entry1 configure -state normal - $id.xrange.entry2 configure -state normal - $id.xrange.entry3 configure -state normal - $id.xrange.entry4 configure -state normal - $id.yrange.entry1 configure -state normal - $id.yrange.entry2 configure -state normal - $id.yrange.entry3 configure -state normal - $id.yrange.entry4 configure -state normal - $id.xscale.entry configure -state disabled - $id.yscale.entry configure -state disabled - set x1 [eval concat $$var_canvas_x1] - set y1 [eval concat $$var_canvas_y1] - set x2 [eval concat $$var_canvas_x2] - set y2 [eval concat $$var_canvas_y2] - if { [eval concat $$var_canvas_x1] == 0 && \ - [eval concat $$var_canvas_y1] == 0 && \ - [eval concat $$var_canvas_x2] == 0 && \ - [eval concat $$var_canvas_y2] == 0 } { - set $var_canvas_x2 1 - set $var_canvas_y2 1 - } - if { [eval concat $$var_canvas_xpix] == 0 } { - set $var_canvas_xpix 85 - set $var_canvas_xmargin 100 - } - if { [eval concat $$var_canvas_ypix] == 0 } { - set $var_canvas_ypix 60 - set $var_canvas_ymargin 100 - } - } else { - $id.hidetext configure -state disabled - $id.xrange.entry1 configure -state disabled - $id.xrange.entry2 configure -state disabled - $id.xrange.entry3 configure -state disabled - $id.xrange.entry4 configure -state disabled - $id.yrange.entry1 configure -state disabled - $id.yrange.entry2 configure -state disabled - $id.yrange.entry3 configure -state disabled - $id.yrange.entry4 configure -state disabled - $id.xscale.entry configure -state normal - $id.yscale.entry configure -state normal - if { [eval concat $$var_canvas_xscale] == 0 } { - set $var_canvas_xscale 1 - } - if { [eval concat $$var_canvas_yscale] == 0 } { - set $var_canvas_yscale -1 - } - } -} - -proc pdtk_canvas_dialog {id xscale yscale graphme x1 y1 x2 y2 \ - xpix ypix xmargin ymargin} { - set vid [string trimleft $id .] - - set var_canvas_xscale [concat canvas_xscale_$vid] - global $var_canvas_xscale - set var_canvas_yscale [concat canvas_yscale_$vid] - global $var_canvas_yscale - set var_canvas_graphme [concat canvas_graphme_$vid] - global $var_canvas_graphme - set var_canvas_hidetext [concat canvas_hidetext_$vid] - global $var_canvas_hidetext - set var_canvas_x1 [concat canvas_x1_$vid] - global $var_canvas_x1 - set var_canvas_x2 [concat canvas_x2_$vid] - global $var_canvas_x2 - set var_canvas_xpix [concat canvas_xpix_$vid] - global $var_canvas_xpix - set var_canvas_xmargin [concat canvas_xmargin_$vid] - global $var_canvas_xmargin - set var_canvas_y1 [concat canvas_y1_$vid] - global $var_canvas_y1 - set var_canvas_y2 [concat canvas_y2_$vid] - global $var_canvas_y2 - set var_canvas_ypix [concat canvas_ypix_$vid] - global $var_canvas_ypix - set var_canvas_ymargin [concat canvas_ymargin_$vid] - global $var_canvas_ymargin - - set $var_canvas_xscale $xscale - set $var_canvas_yscale $yscale - set $var_canvas_graphme [expr ($graphme!=0)?1:0] - set $var_canvas_hidetext [expr ($graphme&2)?1:0] - set $var_canvas_x1 $x1 - set $var_canvas_y1 $y1 - set $var_canvas_x2 $x2 - set $var_canvas_y2 $y2 - set $var_canvas_xpix $xpix - set $var_canvas_ypix $ypix - set $var_canvas_xmargin $xmargin - set $var_canvas_ymargin $ymargin - - toplevel $id - wm title $id {canvas} - wm protocol $id WM_DELETE_WINDOW [concat canvas_cancel $id] - - label $id.toplabel -text "Canvas Properties" - pack $id.toplabel -side top - - frame $id.xscale - pack $id.xscale -side top - label $id.xscale.label -text "X units per pixel" - entry $id.xscale.entry -textvariable $var_canvas_xscale -width 10 - pack $id.xscale.label $id.xscale.entry -side left - - frame $id.yscale - pack $id.yscale -side top - label $id.yscale.label -text "Y units per pixel" - entry $id.yscale.entry -textvariable $var_canvas_yscale -width 10 - pack $id.yscale.label $id.yscale.entry -side left - - checkbutton $id.graphme -text {graph on parent} \ - -variable $var_canvas_graphme -anchor w \ - -command [concat canvas_checkcommand $id] - pack $id.graphme -side top - - checkbutton $id.hidetext -text {hide object name and arguments} \ - -variable $var_canvas_hidetext -anchor w \ - -command [concat canvas_checkcommand $id] - pack $id.hidetext -side top - - frame $id.xrange - pack $id.xrange -side top - label $id.xrange.label1 -text "X range: from" - entry $id.xrange.entry1 -textvariable $var_canvas_x1 -width 6 - label $id.xrange.label2 -text "to" - entry $id.xrange.entry2 -textvariable $var_canvas_x2 -width 6 - label $id.xrange.label3 -text "size" - entry $id.xrange.entry3 -textvariable $var_canvas_xpix -width 4 - label $id.xrange.label4 -text "margin" - entry $id.xrange.entry4 -textvariable $var_canvas_xmargin -width 4 - pack $id.xrange.label1 $id.xrange.entry1 \ - $id.xrange.label2 $id.xrange.entry2 \ - $id.xrange.label3 $id.xrange.entry3 \ - $id.xrange.label4 $id.xrange.entry4 \ - -side left - - frame $id.yrange - pack $id.yrange -side top - label $id.yrange.label1 -text "Y range: from" - entry $id.yrange.entry1 -textvariable $var_canvas_y1 -width 6 - label $id.yrange.label2 -text "to" - entry $id.yrange.entry2 -textvariable $var_canvas_y2 -width 6 - label $id.yrange.label3 -text "size" - entry $id.yrange.entry3 -textvariable $var_canvas_ypix -width 4 - label $id.yrange.label4 -text "margin" - entry $id.yrange.entry4 -textvariable $var_canvas_ymargin -width 4 - pack $id.yrange.label1 $id.yrange.entry1 \ - $id.yrange.label2 $id.yrange.entry2 \ - $id.yrange.label3 $id.yrange.entry3 \ - $id.yrange.label4 $id.yrange.entry4 \ - -side left - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "canvas_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "canvas_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "canvas_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - pack $id.buttonframe.apply -side left -expand 1 - pack $id.buttonframe.ok -side left -expand 1 - - bind $id.xscale.entry <KeyPress-Return> [concat canvas_ok $id] - bind $id.yscale.entry <KeyPress-Return> [concat canvas_ok $id] - pdtk_standardkeybindings $id.xscale.entry - pdtk_standardkeybindings $id.yscale.entry - $id.xscale.entry select from 0 - $id.xscale.entry select adjust end - focus $id.xscale.entry - canvas_checkcommand $id -} - -############ pdtk_data_dialog -- run a data dialog ######### -proc dodata_send {name} { -# puts stderr [$name.text get 0.0 end] - - for {set i 1} {[$name.text compare [concat $i.0 + 3 chars] < end]} \ - {incr i 1} { -# puts stderr [concat it's [$name.text get $i.0 [expr $i + 1].0]] - set cmd [concat $name data [$name.text get $i.0 [expr $i + 1].0] \;] -# puts stderr $cmd - pd $cmd - } - set cmd [concat $name end \;] -# puts stderr $cmd - pd $cmd -} - -proc dodata_cancel {name} { - set cmd [concat $name cancel \;] -# puts stderr $cmd - pd $cmd -} - -proc dodata_ok {name} { - dodata_send $name - dodata_cancel $name -} - -proc pdtk_data_dialog {name stuff} { - global pd_deffont - toplevel $name - wm title $name {Atom} - wm protocol $name WM_DELETE_WINDOW [concat dodata_cancel $name] - - frame $name.buttonframe - pack $name.buttonframe -side bottom -fill x -pady 2m - button $name.buttonframe.send -text {Send (Ctrl s)}\ - -command [concat dodata_send $name] - button $name.buttonframe.ok -text {OK (Ctrl t)}\ - -command [concat dodata_ok $name] - pack $name.buttonframe.send -side left -expand 1 - pack $name.buttonframe.ok -side left -expand 1 - - text $name.text -relief raised -bd 2 -height 40 -width 60 \ - -yscrollcommand "$name.scroll set" -font $pd_deffont - scrollbar $name.scroll -command "$name.text yview" - pack $name.scroll -side right -fill y - pack $name.text -side left -fill both -expand 1 - $name.text insert end $stuff - focus $name.text - bind $name.text <Control-t> [concat dodata_ok $name] - bind $name.text <Control-s> [concat dodata_send $name] -} - -############ check or uncheck the "edit" menu item ############## -#####################iemlib####################### -proc pdtk_canvas_editval {name value} { - if { $value } { - $name.m.edit entryconfigure "Edit mode" -indicatoron true - } else { - $name.m.edit entryconfigure "Edit mode" -indicatoron false - } -} -#####################iemlib####################### - -############ pdtk_text_new -- create a new text object #2########### -proc pdtk_text_new {canvasname myname x y text font color} { -# if {$font < 13} {set fontname [format -*-courier-bold----%d-* $font]} -# if {$font >= 13} {set fontname [format -*-courier-----%d-* $font]} - - global pd_fontlist - switch -- $font { - 8 { set typeface [lindex $pd_fontlist 0] } - 9 { set typeface [lindex $pd_fontlist 1] } - 10 { set typeface [lindex $pd_fontlist 2] } - 12 { set typeface [lindex $pd_fontlist 3] } - 14 { set typeface [lindex $pd_fontlist 4] } - 16 { set typeface [lindex $pd_fontlist 5] } - 18 { set typeface [lindex $pd_fontlist 6] } - 24 { set typeface [lindex $pd_fontlist 7] } - 30 { set typeface [lindex $pd_fontlist 8] } - 36 { set typeface [lindex $pd_fontlist 9] } - } - - $canvasname create text $x $y \ - -font $typeface \ - -tags $myname -text $text -fill $color -anchor nw -# pd [concat $myname size [$canvasname bbox $myname] \;] -} - -################ pdtk_text_set -- change the text ################## -proc pdtk_text_set {canvasname myname text} { - $canvasname itemconfig $myname -text $text -# pd [concat $myname size [$canvasname bbox $myname] \;] -} - -############### event binding procedures for Pd window ################ - -proc pdtk_pd_ctrlkey {name key shift} { -# puts stderr [concat key $key shift $shift] -# .dummy itemconfig goo -text [concat ---> control-key event $key]; - if {$key == "n" || $key == "N"} {menu_new} - if {$key == "o" || $key == "O"} {menu_open .} - if {$key == "m" || $key == "M"} {menu_send} - if {$key == "q" || $key == "Q"} { - if {$shift == 1} {menu_really_quit} else {menu_quit} - } - if {$key == "slash"} {menu_audio 1} - if {$key == "period"} {menu_audio 0} -} - -######### startup function. ############## -# Tell pd the current directory; this is used in case the command line -# asked pd to open something. Also, get character width and height for -# seven "useful" font sizes. - -# tb: user defined typefaces -proc pdtk_pd_startup {version apilist midiapilist fontname_from_pd \ - fontweight_from_pd} { -# puts stderr [concat $version $apilist $fontname] - global pd_myversion pd_apilist pd_midiapilist pd_nt - set pd_myversion $version - set pd_apilist $apilist - set pd_midiapilist $midiapilist - global fontname fontweight - set fontname $fontname_from_pd - set fontweight $fontweight_from_pd - global pd_fontlist - set pd_fontlist {} - - set fontlist "" - foreach i {8 9 10 12 14 16 18 24 30 36} { - set font [format {{%s} %d %s} $fontname_from_pd -$i $fontweight_from_pd] - set pd_fontlist [linsert $pd_fontlist 100000 $font] - set width0 [font measure $font x] - set height0 [lindex [font metrics $font] 5] - set fontlist [concat $fontlist $i [font measure $font x] \ - [lindex [font metrics $font] 5]] - } - - set tclpatch [info patchlevel] - if {$tclpatch == "8.3.0" || \ - $tclpatch == "8.3.1" || \ - $tclpatch == "8.3.2" || \ - $tclpatch == "8.3.3" } { - set oldtclversion 1 - } else { - set oldtclversion 0 - } - pd [concat pd init [pdtk_enquote [pwd]] $oldtclversion $fontlist \;]; - - # add the audio and help menus to the Pd window. We delayed this - # so that we'd know the value of "apilist". - menu_addstd .mbar - - global pd_nt - if {$pd_nt == 2} { - global pd_macdropped pd_macready - set pd_macready 1 - foreach file $pd_macdropped { - pd [concat pd open [pdtk_enquote [file tail $file]] \ - [pdtk_enquote [file dirname $file]] \;] - menu_doc_open [file dirname $file] [file tail $file] - } - } -} - -##################### DSP ON/OFF, METERS, DIO ERROR ################### -proc pdtk_pd_dsp {value} { - global ctrls_audio_on - if {$value == "ON"} {set ctrls_audio_on 1} else {set ctrls_audio_on 0} -# puts stderr [concat its $ctrls_audio_on] -} - -proc pdtk_pd_meters {indb outdb inclip outclip} { -# puts stderr [concat meters $indb $outdb $inclip $outclip] - global ctrls_inlevel ctrls_outlevel - set ctrls_inlevel $indb - if {$inclip == 1} { - .controls.inout.in.clip configure -background red - } else { - .controls.inout.in.clip configure -background grey - } - set ctrls_outlevel $outdb - if {$outclip == 1} { - .controls.inout.out.clip configure -background red - } else { - .controls.inout.out.clip configure -background grey - } - -} - -proc pdtk_pd_dio {red} { -# puts stderr [concat dio $red] - if {$red == 1} { - .controls.dio configure -background red -activebackground red - } else { - .controls.dio configure -background grey -activebackground lightgrey - } - -} - -############# text editing from the "edit" menu ################### -set edit_number 1 - -proc texteditor_send {name} { - set topname [string trimright $name .text] - for {set i 0} \ - {[$name compare [concat 0.0 + [expr $i + 1] chars] < end]} \ - {incr i 1} { - set cha [$name get [concat 0.0 + $i chars]] - scan $cha %c keynum - pd [concat pd key 1 $keynum 0 \;] - } -} - -proc texteditor_ok {name} { - set topname [string trimright $name .text] - texteditor_send $name - destroy $topname -} - - -proc pdtk_pd_texteditor {stuff} { - global edit_number pd_deffont - set name [format ".text%d" $edit_number] - set edit_number [expr $edit_number + 1] - - toplevel $name - wm title $name {TEXT} - - frame $name.buttons - pack $name.buttons -side bottom -fill x -pady 2m - button $name.buttons.send -text {Send (Ctrl s)}\ - -command "texteditor_send $name.text" - button $name.buttons.ok -text {OK (Ctrl t)}\ - -command "texteditor_ok $name.text" - pack $name.buttons.send -side left -expand 1 - pack $name.buttons.ok -side left -expand 1 - - text $name.text -relief raised -bd 2 -height 12 -width 60 \ - -yscrollcommand "$name.scroll set" -font $pd_deffont - scrollbar $name.scroll -command "$name.text yview" - pack $name.scroll -side right -fill y - pack $name.text -side left -fill both -expand 1 - $name.text insert end $stuff - focus $name.text - bind $name.text <Control-t> {texteditor_ok %W} - bind $name.text <Control-s> {texteditor_send %W} -} - -# paste text into a text box -proc pdtk_pastetext {} { - global pdtk_pastebuffer - set pdtk_pastebuffer "" - catch {global pdtk_pastebuffer; set pdtk_pastebuffer [clipboard get]} -# puts stderr [concat paste $pdtk_pastebuffer] - for {set i 0} {$i < [string length $pdtk_pastebuffer]} {incr i 1} { - set cha [string index $pdtk_pastebuffer $i] - scan $cha %c keynum - pd [concat pd key 1 $keynum 0 \;] - } -} - -############# open and save dialogs for objects in Pd ########## - -proc pdtk_openpanel {target localdir} { - global pd_opendir - if {$localdir == ""} { - set localdir $pd_opendir - } - set filename [tk_getOpenFile -initialdir $localdir] - if {$filename != ""} { - set directory [string range $filename 0 \ - [expr [string last / $filename ] - 1]] - set pd_opendir $directory - - pd [concat $target callback [pdtk_enquote $filename] \;] - } -} - -proc pdtk_savepanel {target localdir} { - global pd_savedir - if {$localdir == ""} { - set localdir $pd_savedir - } - set filename [tk_getSaveFile -initialdir $localdir] - if {$filename != ""} { - pd [concat $target callback [pdtk_enquote $filename] \;] - } -} - -########################### comport hack ######################## - -set com1 0 -set com2 0 -set com3 0 -set com4 0 - -proc com1_open {} { - global com1 - set com1 [open com1 w] - .dummy itemconfig goo -text $com1 - fconfigure $com1 -buffering none - fconfigure $com1 -mode 19200,e,8,2 -} - -proc com1_send {str} { - global com1 - puts -nonewline $com1 $str -} - - -############# start a polling process to watch the socket ############## -# this is needed for nt, and presumably for Mac as well. -# in UNIX this is handled by a tcl callback (set up in t_tkcmd.c) - -if {$pd_nt == 1} { - proc polleofloop {} { - pd_pollsocket - after 20 polleofloop - } - - polleofloop -} - -####################### audio dialog ##################3 - -proc audio_apply {id} { - global audio_indev1 audio_indev2 audio_indev3 audio_indev4 - global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4 - global audio_inenable1 audio_inenable2 audio_inenable3 audio_inenable4 - global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4 - global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4 - global audio_outenable1 audio_outenable2 audio_outenable3 audio_outenable4 - global audio_sr audio_advance audio_callback - - pd [concat pd audio-dialog \ - $audio_indev1 \ - $audio_indev2 \ - $audio_indev3 \ - $audio_indev4 \ - [expr $audio_inchan1 * ( $audio_inenable1 ? 1 : -1 ) ]\ - [expr $audio_inchan2 * ( $audio_inenable2 ? 1 : -1 ) ]\ - [expr $audio_inchan3 * ( $audio_inenable3 ? 1 : -1 ) ]\ - [expr $audio_inchan4 * ( $audio_inenable4 ? 1 : -1 ) ]\ - $audio_outdev1 \ - $audio_outdev2 \ - $audio_outdev3 \ - $audio_outdev4 \ - [expr $audio_outchan1 * ( $audio_outenable1 ? 1 : -1 ) ]\ - [expr $audio_outchan2 * ( $audio_outenable2 ? 1 : -1 ) ]\ - [expr $audio_outchan3 * ( $audio_outenable3 ? 1 : -1 ) ]\ - [expr $audio_outchan4 * ( $audio_outenable4 ? 1 : -1 ) ]\ - $audio_sr \ - $audio_advance \ - $audio_callback \ - \;] -} - -proc audio_cancel {id} { - pd [concat $id cancel \;] -} - -proc audio_ok {id} { - audio_apply $id - audio_cancel $id -} - -# callback from popup menu -proc audio_popup_action {buttonname varname devlist index} { - global audio_indevlist audio_outdevlist $varname - $buttonname configure -text [lindex $devlist $index] -# puts stderr [concat popup_action $buttonname $varname $index] - set $varname $index -} - -# create a popup menu -proc audio_popup {name buttonname varname devlist} { - global pd_nt - if [winfo exists $name.popup] {destroy $name.popup} - menu $name.popup -tearoff false - if {$pd_nt == 1} { - $name.popup configure -font menuFont - } -# puts stderr [concat $devlist ] - for {set x 0} {$x<[llength $devlist]} {incr x} { - $name.popup add command -label [lindex $devlist $x] \ - -command [list audio_popup_action \ - $buttonname $varname $devlist $x] - } - tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0 -} - -# start a dialog window to select audio devices and settings. "multi" -# is 0 if only one device is allowed; 1 if one apiece may be specified for -# input and output; and 2 if we can select multiple devices. "longform" -# (which only makes sense if "multi" is 2) asks us to make controls for -# opening several devices; if not, we get an extra button to turn longform -# on and restart the dialog. - -proc pdtk_audio_dialog {id indev1 indev2 indev3 indev4 \ - inchan1 inchan2 inchan3 inchan4 \ - outdev1 outdev2 outdev3 outdev4 \ - outchan1 outchan2 outchan3 outchan4 sr advance multi callback \ - longform} { - global audio_indev1 audio_indev2 audio_indev3 audio_indev4 - global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4 - global audio_inenable1 audio_inenable2 audio_inenable3 audio_inenable4 - global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4 - global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4 - global audio_outenable1 audio_outenable2 audio_outenable3 audio_outenable4 - global audio_sr audio_advance audio_callback - global audio_indevlist audio_outdevlist - global pd_indev pd_outdev - - set audio_indev1 $indev1 - set audio_indev2 $indev2 - set audio_indev3 $indev3 - set audio_indev4 $indev4 - - set audio_inchan1 [expr ( $inchan1 > 0 ? $inchan1 : -$inchan1 ) ] - set audio_inenable1 [expr $inchan1 > 0 ] - set audio_inchan2 [expr ( $inchan2 > 0 ? $inchan2 : -$inchan2 ) ] - set audio_inenable2 [expr $inchan2 > 0 ] - set audio_inchan3 [expr ( $inchan3 > 0 ? $inchan3 : -$inchan3 ) ] - set audio_inenable3 [expr $inchan3 > 0 ] - set audio_inchan4 [expr ( $inchan4 > 0 ? $inchan4 : -$inchan4 ) ] - set audio_inenable4 [expr $inchan4 > 0 ] - - set audio_outdev1 $outdev1 - set audio_outdev2 $outdev2 - set audio_outdev3 $outdev3 - set audio_outdev4 $outdev4 - - set audio_outchan1 [expr ( $outchan1 > 0 ? $outchan1 : -$outchan1 ) ] - set audio_outenable1 [expr $outchan1 > 0 ] - set audio_outchan2 [expr ( $outchan2 > 0 ? $outchan2 : -$outchan2 ) ] - set audio_outenable2 [expr $outchan2 > 0 ] - set audio_outchan3 [expr ( $outchan3 > 0 ? $outchan3 : -$outchan3 ) ] - set audio_outenable3 [expr $outchan3 > 0 ] - set audio_outchan4 [expr ( $outchan4 > 0 ? $outchan4 : -$outchan4 ) ] - set audio_outenable4 [expr $outchan4 > 0 ] - - set audio_sr $sr - set audio_advance $advance - set audio_callback $callback - toplevel $id - wm title $id {audio} - wm protocol $id WM_DELETE_WINDOW [concat audio_cancel $id] - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "audio_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "audio_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "audio_ok $id" - button $id.buttonframe.save -text {Save all settings}\ - -command "audio_apply $id \; pd pd save-preferences \\;" - pack $id.buttonframe.cancel $id.buttonframe.apply $id.buttonframe.ok \ - $id.buttonframe.save -side left -expand 1 - - # sample rate and advance - frame $id.srf - pack $id.srf -side top - - label $id.srf.l1 -text "sample rate:" - entry $id.srf.x1 -textvariable audio_sr -width 7 - label $id.srf.l2 -text "delay (msec):" - entry $id.srf.x2 -textvariable audio_advance -width 4 - pack $id.srf.l1 $id.srf.x1 $id.srf.l2 $id.srf.x2 -side left - if {$audio_callback >= 0} { - checkbutton $id.srf.x3 -variable audio_callback \ - -text {use callbacks} -anchor e - pack $id.srf.x3 -side left - } - # input device 1 - frame $id.in1f - pack $id.in1f -side top - - checkbutton $id.in1f.x0 -variable audio_inenable1 \ - -text {input device 1} -anchor e - button $id.in1f.x1 -text [lindex $audio_indevlist $audio_indev1] \ - -command [list audio_popup $id $id.in1f.x1 audio_indev1 $audio_indevlist] - label $id.in1f.l2 -text "channels:" - entry $id.in1f.x2 -textvariable audio_inchan1 -width 3 - pack $id.in1f.x0 $id.in1f.x1 $id.in1f.l2 $id.in1f.x2 -side left - - # input device 2 - if {$longform && $multi > 1 && [llength $audio_indevlist] > 1} { - frame $id.in2f - pack $id.in2f -side top - - checkbutton $id.in2f.x0 -variable audio_inenable2 \ - -text {input device 2} -anchor e - button $id.in2f.x1 -text [lindex $audio_indevlist $audio_indev2] \ - -command [list audio_popup $id $id.in2f.x1 audio_indev2 \ - $audio_indevlist] - label $id.in2f.l2 -text "channels:" - entry $id.in2f.x2 -textvariable audio_inchan2 -width 3 - pack $id.in2f.x0 $id.in2f.x1 $id.in2f.l2 $id.in2f.x2 -side left - } - - # input device 3 - if {$longform && $multi > 1 && [llength $audio_indevlist] > 2} { - frame $id.in3f - pack $id.in3f -side top - - checkbutton $id.in3f.x0 -variable audio_inenable3 \ - -text {input device 3} -anchor e - button $id.in3f.x1 -text [lindex $audio_indevlist $audio_indev3] \ - -command [list audio_popup $id $id.in3f.x1 audio_indev3 \ - $audio_indevlist] - label $id.in3f.l2 -text "channels:" - entry $id.in3f.x2 -textvariable audio_inchan3 -width 3 - pack $id.in3f.x0 $id.in3f.x1 $id.in3f.l2 $id.in3f.x2 -side left - } - - # input device 4 - if {$longform && $multi > 1 && [llength $audio_indevlist] > 3} { - frame $id.in4f - pack $id.in4f -side top - - checkbutton $id.in4f.x0 -variable audio_inenable4 \ - -text {input device 4} -anchor e - button $id.in4f.x1 -text [lindex $audio_indevlist $audio_indev4] \ - -command [list audio_popup $id $id.in4f.x1 audio_indev4 \ - $audio_indevlist] - label $id.in4f.l2 -text "channels:" - entry $id.in4f.x2 -textvariable audio_inchan4 -width 3 - pack $id.in4f.x0 $id.in4f.x1 $id.in4f.l2 $id.in4f.x2 -side left - } - - # output device 1 - frame $id.out1f - pack $id.out1f -side top - - checkbutton $id.out1f.x0 -variable audio_outenable1 \ - -text {output device 1} -anchor e - if {$multi == 0} { - label $id.out1f.l1 \ - -text "(same as input device) .............. " - } else { - button $id.out1f.x1 -text [lindex $audio_outdevlist $audio_outdev1] \ - -command [list audio_popup $id $id.out1f.x1 audio_outdev1 \ - $audio_outdevlist] - } - label $id.out1f.l2 -text "channels:" - entry $id.out1f.x2 -textvariable audio_outchan1 -width 3 - if {$multi == 0} { - pack $id.out1f.x0 $id.out1f.l1 $id.out1f.x2 -side left - } else { - pack $id.out1f.x0 $id.out1f.x1 $id.out1f.l2 $id.out1f.x2 -side left - } - - # output device 2 - if {$longform && $multi > 1 && [llength $audio_outdevlist] > 1} { - frame $id.out2f - pack $id.out2f -side top - - checkbutton $id.out2f.x0 -variable audio_outenable2 \ - -text {output device 2} -anchor e - button $id.out2f.x1 -text [lindex $audio_outdevlist $audio_outdev2] \ - -command \ - [list audio_popup $id $id.out2f.x1 audio_outdev2 $audio_outdevlist] - label $id.out2f.l2 -text "channels:" - entry $id.out2f.x2 -textvariable audio_outchan2 -width 3 - pack $id.out2f.x0 $id.out2f.x1 $id.out2f.l2 $id.out2f.x2 -side left - } - - # output device 3 - if {$longform && $multi > 1 && [llength $audio_outdevlist] > 2} { - frame $id.out3f - pack $id.out3f -side top - - checkbutton $id.out3f.x0 -variable audio_outenable3 \ - -text {output device 3} -anchor e - button $id.out3f.x1 -text [lindex $audio_outdevlist $audio_outdev3] \ - -command \ - [list audio_popup $id $id.out3f.x1 audio_outdev3 $audio_outdevlist] - label $id.out3f.l2 -text "channels:" - entry $id.out3f.x2 -textvariable audio_outchan3 -width 3 - pack $id.out3f.x0 $id.out3f.x1 $id.out3f.l2 $id.out3f.x2 -side left - } - - # output device 4 - if {$longform && $multi > 1 && [llength $audio_outdevlist] > 3} { - frame $id.out4f - pack $id.out4f -side top - - checkbutton $id.out4f.x0 -variable audio_outenable4 \ - -text {output device 4} -anchor e - button $id.out4f.x1 -text [lindex $audio_outdevlist $audio_outdev4] \ - -command \ - [list audio_popup $id $id.out4f.x1 audio_outdev4 $audio_outdevlist] - label $id.out4f.l2 -text "channels:" - entry $id.out4f.x2 -textvariable audio_outchan4 -width 3 - pack $id.out4f.x0 $id.out4f.x1 $id.out4f.l2 $id.out4f.x2 -side left - } - - # if not the "long form" but if "multi" is 2, make a button to - # restart with longform set. - - if {$longform == 0 && $multi > 1} { - frame $id.longbutton - pack $id.longbutton -side top - button $id.longbutton.b -text {use multiple devices} \ - -command {pd pd audio-properties 1 \;} - pack $id.longbutton.b - } - bind $id.srf.x1 <KeyPress-Return> [concat audio_ok $id] - bind $id.srf.x2 <KeyPress-Return> [concat audio_ok $id] - bind $id.in1f.x2 <KeyPress-Return> [concat audio_ok $id] - bind $id.out1f.x2 <KeyPress-Return> [concat audio_ok $id] - $id.srf.x1 select from 0 - $id.srf.x1 select adjust end - focus $id.srf.x1 - pdtk_standardkeybindings $id.srf.x1 - pdtk_standardkeybindings $id.srf.x2 - pdtk_standardkeybindings $id.in1f.x2 - pdtk_standardkeybindings $id.out1f.x2 -} - -####################### midi dialog ################## - -proc midi_apply {id} { - global midi_indev1 midi_indev2 midi_indev3 midi_indev4 - global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4 - global midi_alsain midi_alsaout - - pd [concat pd midi-dialog \ - $midi_indev1 \ - $midi_indev2 \ - $midi_indev3 \ - $midi_indev4 \ - $midi_outdev1 \ - $midi_outdev2 \ - $midi_outdev3 \ - $midi_outdev4 \ - $midi_alsain \ - $midi_alsaout \ - \;] -} - -proc midi_cancel {id} { - pd [concat $id cancel \;] -} - -proc midi_ok {id} { - midi_apply $id - midi_cancel $id -} - -# callback from popup menu -proc midi_popup_action {buttonname varname devlist index} { - global midi_indevlist midi_outdevlist $varname - $buttonname configure -text [lindex $devlist $index] -# puts stderr [concat popup_action $buttonname $varname $index] - set $varname $index -} - -# create a popup menu -proc midi_popup {name buttonname varname devlist} { - global pd_nt - if [winfo exists $name.popup] {destroy $name.popup} - menu $name.popup -tearoff false - if {$pd_nt == 1} { - $name.popup configure -font menuFont - } -# puts stderr [concat $devlist ] - for {set x 0} {$x<[llength $devlist]} {incr x} { - $name.popup add command -label [lindex $devlist $x] \ - -command [list midi_popup_action \ - $buttonname $varname $devlist $x] - } - tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0 -} - -# start a dialog window to select midi devices. "longform" asks us to make -# controls for opening several devices; if not, we get an extra button to -# turn longform on and restart the dialog. -proc pdtk_midi_dialog {id indev1 indev2 indev3 indev4 \ - outdev1 outdev2 outdev3 outdev4 longform} { - global midi_indev1 midi_indev2 midi_indev3 midi_indev4 - global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4 - global midi_indevlist midi_outdevlist - global midi_alsain midi_alsaout - - set midi_indev1 $indev1 - set midi_indev2 $indev2 - set midi_indev3 $indev3 - set midi_indev4 $indev4 - set midi_outdev1 $outdev1 - set midi_outdev2 $outdev2 - set midi_outdev3 $outdev3 - set midi_outdev4 $outdev4 - set midi_alsain [llength $midi_indevlist] - set midi_alsaout [llength $midi_outdevlist] - - toplevel $id - wm title $id {midi} - wm protocol $id WM_DELETE_WINDOW [concat midi_cancel $id] - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "midi_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "midi_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "midi_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - pack $id.buttonframe.apply -side left -expand 1 - pack $id.buttonframe.ok -side left -expand 1 - - # input device 1 - frame $id.in1f - pack $id.in1f -side top - - label $id.in1f.l1 -text "input device 1:" - button $id.in1f.x1 -text [lindex $midi_indevlist $midi_indev1] \ - -command [list midi_popup $id $id.in1f.x1 midi_indev1 $midi_indevlist] - pack $id.in1f.l1 $id.in1f.x1 -side left - - # input device 2 - if {$longform && [llength $midi_indevlist] > 2} { - frame $id.in2f - pack $id.in2f -side top - - label $id.in2f.l1 -text "input device 2:" - button $id.in2f.x1 -text [lindex $midi_indevlist $midi_indev2] \ - -command [list midi_popup $id $id.in2f.x1 midi_indev2 \ - $midi_indevlist] - pack $id.in2f.l1 $id.in2f.x1 -side left - } - - # input device 3 - if {$longform && [llength $midi_indevlist] > 3} { - frame $id.in3f - pack $id.in3f -side top - - label $id.in3f.l1 -text "input device 3:" - button $id.in3f.x1 -text [lindex $midi_indevlist $midi_indev3] \ - -command [list midi_popup $id $id.in3f.x1 midi_indev3 \ - $midi_indevlist] - pack $id.in3f.l1 $id.in3f.x1 -side left - } - - # input device 4 - if {$longform && [llength $midi_indevlist] > 4} { - frame $id.in4f - pack $id.in4f -side top - - label $id.in4f.l1 -text "input device 4:" - button $id.in4f.x1 -text [lindex $midi_indevlist $midi_indev4] \ - -command [list midi_popup $id $id.in4f.x1 midi_indev4 \ - $midi_indevlist] - pack $id.in4f.l1 $id.in4f.x1 -side left - } - - # output device 1 - - frame $id.out1f - pack $id.out1f -side top - label $id.out1f.l1 -text "output device 1:" - button $id.out1f.x1 -text [lindex $midi_outdevlist $midi_outdev1] \ - -command [list midi_popup $id $id.out1f.x1 midi_outdev1 \ - $midi_outdevlist] - pack $id.out1f.l1 $id.out1f.x1 -side left - - # output device 2 - if {$longform && [llength $midi_outdevlist] > 2} { - frame $id.out2f - pack $id.out2f -side top - label $id.out2f.l1 -text "output device 2:" - button $id.out2f.x1 -text [lindex $midi_outdevlist $midi_outdev2] \ - -command \ - [list midi_popup $id $id.out2f.x1 midi_outdev2 $midi_outdevlist] - pack $id.out2f.l1 $id.out2f.x1 -side left - } - - # output device 3 - if {$longform && [llength $midi_midi_outdevlist] > 3} { - frame $id.out3f - pack $id.out3f -side top - label $id.out3f.l1 -text "output device 3:" - button $id.out3f.x1 -text [lindex $midi_outdevlist $midi_outdev3] \ - -command \ - [list midi_popup $id $id.out3f.x1 midi_outdev3 $midi_outdevlist] - pack $id.out3f.l1 $id.out3f.x1 -side left - } - - # output device 4 - if {$longform && [llength $midi_midi_outdevlist] > 4} { - frame $id.out4f - pack $id.out4f -side top - label $id.out4f.l1 -text "output device 4:" - button $id.out4f.x1 -text [lindex $midi_outdevlist $midi_outdev4] \ - -command \ - [list midi_popup $id $id.out4f.x1 midi_outdev4 $midi_outdevlist] - pack $id.out4f.l1 $id.out4f.x1 -side left - } - - # if not the "long form" make a button to - # restart with longform set. - - if {$longform == 0} { - frame $id.longbutton - pack $id.longbutton -side top - button $id.longbutton.b -text {use multiple devices} \ - -command {pd pd midi-properties 1 \;} - pack $id.longbutton.b - } -} - -proc pdtk_alsa_midi_dialog {id indev1 indev2 indev3 indev4 \ - outdev1 outdev2 outdev3 outdev4 longform alsa} { - global midi_indev1 midi_indev2 midi_indev3 midi_indev4 - global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4 - global midi_indevlist midi_outdevlist - global midi_alsain midi_alsaout - - set midi_indev1 $indev1 - set midi_indev2 $indev2 - set midi_indev3 $indev3 - set midi_indev4 $indev4 - set midi_outdev1 $outdev1 - set midi_outdev2 $outdev2 - set midi_outdev3 $outdev3 - set midi_outdev4 $outdev4 - set midi_alsain [llength $midi_indevlist] - set midi_alsaout [llength $midi_outdevlist] - - toplevel $id - wm title $id {midi} - wm protocol $id WM_DELETE_WINDOW [concat midi_cancel $id] - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "midi_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "midi_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "midi_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - pack $id.buttonframe.apply -side left -expand 1 - pack $id.buttonframe.ok -side left -expand 1 - - frame $id.in1f - pack $id.in1f -side top - - if {$alsa == 0} { - # input device 1 - label $id.in1f.l1 -text "input device 1:" - button $id.in1f.x1 -text [lindex $midi_indevlist $midi_indev1] \ - -command [list midi_popup $id $id.in1f.x1 midi_indev1 $midi_indevlist] - pack $id.in1f.l1 $id.in1f.x1 -side left - - # input device 2 - if {$longform && [llength $midi_indevlist] > 2} { - frame $id.in2f - pack $id.in2f -side top - - label $id.in2f.l1 -text "input device 2:" - button $id.in2f.x1 -text [lindex $midi_indevlist $midi_indev2] \ - -command [list midi_popup $id $id.in2f.x1 midi_indev2 \ - $midi_indevlist] - pack $id.in2f.l1 $id.in2f.x1 -side left - } - - # input device 3 - if {$longform && [llength $midi_indevlist] > 3} { - frame $id.in3f - pack $id.in3f -side top - - label $id.in3f.l1 -text "input device 3:" - button $id.in3f.x1 -text [lindex $midi_indevlist $midi_indev3] \ - -command [list midi_popup $id $id.in3f.x1 midi_indev3 \ - $midi_indevlist] - pack $id.in3f.l1 $id.in3f.x1 -side left - } - - # input device 4 - if {$longform && [llength $midi_indevlist] > 4} { - frame $id.in4f - pack $id.in4f -side top - - label $id.in4f.l1 -text "input device 4:" - button $id.in4f.x1 -text [lindex $midi_indevlist $midi_indev4] \ - -command [list midi_popup $id $id.in4f.x1 midi_indev4 \ - $midi_indevlist] - pack $id.in4f.l1 $id.in4f.x1 -side left - } - - # output device 1 - - frame $id.out1f - pack $id.out1f -side top - label $id.out1f.l1 -text "output device 1:" - button $id.out1f.x1 -text [lindex $midi_outdevlist $midi_outdev1] \ - -command [list midi_popup $id $id.out1f.x1 midi_outdev1 \ - $midi_outdevlist] - pack $id.out1f.l1 $id.out1f.x1 -side left - - # output device 2 - if {$longform && [llength $midi_outdevlist] > 2} { - frame $id.out2f - pack $id.out2f -side top - label $id.out2f.l1 -text "output device 2:" - button $id.out2f.x1 -text [lindex $midi_outdevlist $midi_outdev2] \ - -command \ - [list midi_popup $id $id.out2f.x1 midi_outdev2 $midi_outdevlist] - pack $id.out2f.l1 $id.out2f.x1 -side left - } - - # output device 3 - if {$longform && [llength $midi_outdevlist] > 3} { - frame $id.out3f - pack $id.out3f -side top - label $id.out3f.l1 -text "output device 3:" - button $id.out3f.x1 -text [lindex $midi_outdevlist $midi_outdev3] \ - -command \ - [list midi_popup $id $id.out3f.x1 midi_outdev3 $midi_outdevlist] - pack $id.out3f.l1 $id.out3f.x1 -side left - } - - # output device 4 - if {$longform && [llength $midi_outdevlist] > 4} { - frame $id.out4f - pack $id.out4f -side top - label $id.out4f.l1 -text "output device 4:" - button $id.out4f.x1 -text [lindex $midi_outdevlist $midi_outdev4] \ - -command \ - [list midi_popup $id $id.out4f.x1 midi_outdev4 $midi_outdevlist] - pack $id.out4f.l1 $id.out4f.x1 -side left - } - - # if not the "long form" make a button to - # restart with longform set. - - if {$longform == 0} { - frame $id.longbutton - pack $id.longbutton -side top - button $id.longbutton.b -text {use multiple alsa devices} \ - -command {pd pd midi-properties 1 \;} - pack $id.longbutton.b - } - } - if {$alsa} { - label $id.in1f.l1 -text "In Ports:" - entry $id.in1f.x1 -textvariable midi_alsain -width 4 - pack $id.in1f.l1 $id.in1f.x1 -side left - label $id.in1f.l2 -text "Out Ports:" - entry $id.in1f.x2 -textvariable midi_alsaout -width 4 - pack $id.in1f.l2 $id.in1f.x2 -side left - } -} - -############ pdtk_path_dialog -- dialog window for search path ######### - -proc path_apply {id} { - global pd_extrapath pd_verbose - global pd_path_count - set pd_path {} - - for {set x 0} {$x < $pd_path_count} {incr x} { - global pd_path$x - set this_path [set pd_path$x] - if {0==[string match "" $this_path]} { - lappend pd_path [pdtk_encodedialog $this_path] - } - } - - pd [concat pd path-dialog $pd_extrapath $pd_verbose $pd_path \;] -} - -proc path_cancel {id} { - pd [concat $id cancel \;] -} - -proc path_ok {id} { - path_apply $id - path_cancel $id -} - -proc pdtk_path_dialog {id extrapath verbose} { - global pd_extrapath pd_verbose - global pd_path - global pd_path_count - - set pd_path_count [expr [llength $pd_path] + 2] - if { $pd_path_count < 10 } { set pd_path_count 10 } - - for {set x 0} {$x < $pd_path_count} {incr x} { - global pd_path$x - set pd_path$x [lindex $pd_path $x] - } - - set pd_extrapath $extrapath - set pd_verbose $verbose - toplevel $id - wm title $id {PD search path for patches and other files} - wm protocol $id WM_DELETE_WINDOW [concat path_cancel $id] - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "path_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "path_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "path_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - pack $id.buttonframe.apply -side left -expand 1 - pack $id.buttonframe.ok -side left -expand 1 - - frame $id.extraframe - pack $id.extraframe -side bottom -fill x -pady 2m - checkbutton $id.extraframe.extra -text {use standard extensions} \ - -variable pd_extrapath -anchor w - checkbutton $id.extraframe.verbose -text {verbose} \ - -variable pd_verbose -anchor w - button $id.extraframe.save -text {Save all settings}\ - -command "path_apply $id \; pd pd save-preferences \\;" - pack $id.extraframe.extra $id.extraframe.verbose $id.extraframe.save \ - -side left -expand 1 - - for {set x 0} {$x < $pd_path_count} {incr x} { - entry $id.f$x -textvariable pd_path$x -width 80 - bind $id.f$x <KeyPress-Return> [concat path_ok $id] - pdtk_standardkeybindings $id.f$x - pack $id.f$x -side top - } - - focus $id.f0 -} - -proc pd_set {var value} { - global $var - set $var $value -} - -########## pdtk_startup_dialog -- dialog window for startup options ######### - -proc startup_apply {id} { - global pd_nort pd_flags - global pd_startup_count - - set pd_startup {} - for {set x 0} {$x < $pd_startup_count} {incr x} { - global pd_startup$x - set this_startup [set pd_startup$x] - if {0==[string match "" $this_startup]} {lappend pd_startup [pdtk_encodedialog $this_startup]} - } - - pd [concat pd startup-dialog $pd_nort [pdtk_encodedialog $pd_flags] $pd_startup \;] -} - -proc startup_cancel {id} { - pd [concat $id cancel \;] -} - -proc startup_ok {id} { - startup_apply $id - startup_cancel $id -} - -proc pdtk_startup_dialog {id nort flags} { - global pd_nort pd_nt pd_flags - global pd_startup - global pd_startup_count - - set pd_startup_count [expr [llength $pd_startup] + 2] - if { $pd_startup_count < 10 } { set pd_startup_count 10 } - - for {set x 0} {$x < $pd_startup_count} {incr x} { - global pd_startup$x - set pd_startup$x [lindex $pd_startup $x] - } - - set pd_nort $nort - set pd_flags $flags - toplevel $id - wm title $id {Pd binaries to load (on next startup)} - wm protocol $id WM_DELETE_WINDOW [concat startup_cancel $id] - - frame $id.buttonframe - pack $id.buttonframe -side bottom -fill x -pady 2m - button $id.buttonframe.cancel -text {Cancel}\ - -command "startup_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "startup_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "startup_ok $id" - pack $id.buttonframe.cancel -side left -expand 1 - pack $id.buttonframe.apply -side left -expand 1 - pack $id.buttonframe.ok -side left -expand 1 - - frame $id.flags - pack $id.flags -side bottom - label $id.flags.entryname -text {startup flags} - entry $id.flags.entry -textvariable pd_flags -width 80 - bind $id.flags.entry <KeyPress-Return> [concat startup_ok $id] - pdtk_standardkeybindings $id.flags.entry - pack $id.flags.entryname $id.flags.entry -side left - - frame $id.nortframe - pack $id.nortframe -side bottom -fill x -pady 2m - if {$pd_nt != 1} { - checkbutton $id.nortframe.nort -text {defeat real-time scheduling} \ - -variable pd_nort -anchor w - } - button $id.nortframe.save -text {Save all settings}\ - -command "startup_apply $id \; pd pd save-preferences \\;" - if {$pd_nt != 1} { - pack $id.nortframe.nort $id.nortframe.save -side left -expand 1 - } else { - pack $id.nortframe.save -side left -expand 1 - } - - - - for {set x 0} {$x < $pd_startup_count} {incr x} { - entry $id.f$x -textvariable pd_startup$x -width 80 - bind $id.f$x <KeyPress-Return> [concat startup_ok $id] - pdtk_standardkeybindings $id.f$x - pack $id.f$x -side top - } - - focus $id.f0 -} - -########## data-driven dialog -- convert others to this someday? ########## - -proc ddd_apply {id} { - set vid [string trimleft $id .] - set var_count [concat ddd_count_$vid] - global $var_count - set count [eval concat $$var_count] - set values {} - - for {set x 0} {$x < $count} {incr x} { - set varname [concat ddd_var_$vid$x] - global $varname - lappend values [eval concat $$varname] - } - set cmd [concat $id done $values \;] - -# puts stderr $cmd - pd $cmd -} - -proc ddd_cancel {id} { - set cmd [concat $id cancel \;] -# puts stderr $cmd - pd $cmd -} - -proc ddd_ok {id} { - ddd_apply $id - ddd_cancel $id -} - -proc ddd_dialog {id dialogname} { - global ddd_fields - set vid [string trimleft $id .] - set count [llength $ddd_fields] - - set var_count [concat ddd_count_$vid] - global $var_count - set $var_count $count - - toplevel $id - label $id.label -text $dialogname - pack $id.label -side top - wm title $id "Pd dialog" - wm resizable $id 0 0 - wm protocol $id WM_DELETE_WINDOW [concat ddd_cancel $id] - - for {set x 0} {$x < $count} {incr x} { - set varname [concat ddd_var_$vid$x] - global $varname - set fieldname [lindex $ddd_fields $x 0] - set $varname [lindex $ddd_fields $x 1] - frame $id.frame$x - pack $id.frame$x -side top -anchor e - label $id.frame$x.label -text $fieldname - entry $id.frame$x.entry -textvariable $varname -width 20 - bind $id.frame$x.entry <KeyPress-Return> [concat ddd_ok $id] - pdtk_standardkeybindings $id.frame$x.entry - pack $id.frame$x.entry $id.frame$x.label -side right - } - - frame $id.buttonframe -pady 5 - pack $id.buttonframe -side top -fill x -pady 2 - button $id.buttonframe.cancel -text {Cancel}\ - -command "ddd_cancel $id" - button $id.buttonframe.apply -text {Apply}\ - -command "ddd_apply $id" - button $id.buttonframe.ok -text {OK}\ - -command "ddd_ok $id" - pack $id.buttonframe.cancel $id.buttonframe.apply \ - $id.buttonframe.ok -side left -expand 1 - -# $id.params.entry select from 0 -# $id.params.entry select adjust end -# focus $id.params.entry -} - - diff --git a/pd/src/x_gui.c b/pd/src/x_gui.c index 6ba58a7b..e83981bb 100644 --- a/pd/src/x_gui.c +++ b/pd/src/x_gui.c @@ -8,7 +8,7 @@ away before the panel does... */ #include "m_pd.h" #include <stdio.h> #include <string.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/pd/src/x_misc.c b/pd/src/x_misc.c index 8a67a5d1..2d7860d9 100644 --- a/pd/src/x_misc.c +++ b/pd/src/x_misc.c @@ -9,7 +9,7 @@ #include <math.h> #include <stdio.h> #include <string.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <sys/types.h> #include <sys/time.h> #include <sys/times.h> @@ -194,7 +194,7 @@ static t_class *cputime_class; typedef struct _cputime { t_object x_obj; -#ifdef UNISTD +#ifdef HAVE_UNISTD_H struct tms x_setcputime; #endif #ifdef MSW @@ -206,7 +206,7 @@ typedef struct _cputime static void cputime_bang(t_cputime *x) { -#ifdef UNISTD +#ifdef HAVE_UNISTD_H times(&x->x_setcputime); #endif #ifdef MSW @@ -227,7 +227,7 @@ static void cputime_bang(t_cputime *x) static void cputime_bang2(t_cputime *x) { -#ifdef UNISTD +#ifdef HAVE_UNISTD_H t_float elapsedcpu; struct tms newcputime; times(&newcputime); diff --git a/pd/src/x_qlist.c b/pd/src/x_qlist.c index fe6df0f3..7c5ec57c 100644 --- a/pd/src/x_qlist.c +++ b/pd/src/x_qlist.c @@ -4,7 +4,7 @@ #include "m_pd.h" #include <string.h> -#ifdef UNISTD +#ifdef HAVE_UNISTD_H #include <unistd.h> #endif #ifdef MSW |