tclpd-0.3.0/0000755000175000017500000000000012564450620013056 5ustar zmoelnigzmoelnigtclpd-0.3.0/tclpd.tcl0000644000175000017500000002025211674625147014702 0ustar zmoelnigzmoelnig# TCL helper library for PD/tclpd api # Copyright (c) 2007-2011 Federico Ferri package provide TclpdLib 0.20 package require Tcl 8.5 package require Tclpd 0.3.0 set verbose 0 namespace eval :: { proc proc+ {name arglist body} { set body2 [concat "global _;" [regsub -all @(\\\$?\[\\w\\?\]+) $body _(\$self:\\1)]] uplevel #0 [list proc $name $arglist $body2] } } namespace eval ::pd { proc error_msg {m} { return "pdlib: [uplevel {lindex [info level 0] 0}]: error: $m" } proc add_inlet {self sel} { if $::verbose {post [info level 0]} variable _ tclpd_add_proxyinlet $self } proc add_outlet {self {sel {}}} { if $::verbose {post [info level 0]} variable _ if {$sel eq {}} { set o [outlet_new $self NULL] } else { if {[lsearch -exact {bang float list symbol} $sel] == -1} { return -code error [error_msg "unsupported selector: $sel"] } set o [outlet_new $self $sel] } lappend _($self:x_outlet) $o return $o } # used inside class for outputting some value proc outlet {self numInlet selector args} { if $::verbose {post [info level 0]} variable _ set outlet [lindex $_($self:x_outlet) $numInlet] switch -- $selector { float { set v [lindex $args 0] outlet_float $outlet $v } symbol { set v [lindex $args 0] outlet_symbol $outlet $v } list { set v [lindex $args 0] outlet_list $outlet list $v } bang { outlet_bang $outlet } default { set v [lindex $args 0] outlet_anything $outlet $selector $v } } } proc read_class_options {classname options} { set flag $::CLASS_DEFAULT foreach {k v} $options { switch -- $k { -patchable { if {$v != 0 && $v != 1} { return -code error [error_msg "-patchable must be 0/1"] } set flag [expr {$flag|($::CLASS_PATCHABLE*$v)}] } -noinlet { if {$v != 0 && $v != 1} { return -code error [error_msg "-noinlet must be 0/1"] } set flag [expr {$flag|($::CLASS_NOINLET*$v)}] } default { return -code error [error_msg "unknown option: $k"] } } } # TODO: c->c_gobj = (typeflag >= CLASS_GOBJ) proc ::${classname}::dispatcher {self function args} " if {\$function eq {method}} { set inlet \[lindex \$args 0\] set selector \[lindex \$args 1\] set argsr \[lrange \$args 2 end\] set i_s ::${classname}::\${inlet}_\${selector} set i_a ::${classname}::\${inlet}_anything if {\[info procs \$i_s\] ne {}} { uplevel \[linsert \$argsr 0 \$i_s \$self\] } elseif {\[info procs \$i_s\] eq {} && \[info procs \$i_a\] ne {}} { uplevel \[linsert \$argsr 0 \$i_a \$self \[pd::add_selector \$selector\]\] } else { return -code error \"${classname}: no such method: \$i_s\" } } elseif {\$function eq {widgetbehavior}} { set subfunction \[lindex \$args 0\] set argsr \[lrange \$args 1 end\] set f ::${classname}::\${function}_\${subfunction} if {\[info procs \$f\] ne {}} { uplevel \[linsert \$argsr 0 \$f \$self] } } else { # feature request 3436774 if {\$function eq {constructor}} { namespace eval ::${classname}::\$self {} } uplevel \[linsert \$args 0 ::${classname}::\$function \$self\] } " # some dummy function to suppress eventual errors if they are not deifned: proc ::${classname}::0_loadbang {self} {} return $flag } # this handles the pd::class definition proc class {classname args} { if $::verbose {post [lrange [info level 0] 0 end-1]} set flag [read_class_options $classname $args] # this wraps the call to class_new() tclpd_class_new $classname $flag } proc guiclass {classname args} { if $::verbose {post [lrange [info level 0] 0 end-1]} set flag [read_class_options $classname $args] # this wraps the call to class_new() tclpd_guiclass_new $classname $flag } # wrapper to post() withouth vargs proc post {args} { poststring2 [concat {*}$args] } proc args {} { return [uplevel 1 "llength \$args"] } proc arg {n {assertion any}} { upvar 1 args up_args set up_args_len [llength $up_args] if {$n < 0 || $n >= $up_args_len} { return -code error "fatal: argument $n out of range" } set v [lindex $up_args $n] set i 0 if {[llength $v] != 2} { return -code error "fatal: malformed atom: $v (full args: $up_args)" } foreach {selector value} $v {break} if {$assertion eq {int}} { set assertion {float} set i 1 } if {$assertion ne {any}} { if {$selector ne $assertion} { return -code error "arg #$n is $selector, must be $assertion" } } if {$assertion eq {float} && $i && $value != int($value)} { return -code error "arg #$n is float, must be int" } if {$assertion eq {float} && $i} { return [expr {int($value)}] } else { return $value } } proc default_arg {n assertion defval} { if {$n < [uplevel "pd::args"]} { return [uplevel "pd::arg $n $assertion"] } else { return $defval } } proc strip_selectors {pdlist} { set r {} foreach atom $pdlist { if {[llength $atom] != 2} { return -code error "Malformed pd list!" } lappend r [lindex $atom 1] } return $r } proc add_selector {s} { return [list [lindex {float symbol} [catch {expr $s}]] $s] } proc add_selectors {tcllist} { set r {} foreach i $tcllist { lappend r [add_selector $i] } return $r } proc strip_empty {tcllist} { set r {} foreach i $tcllist { if {$i eq "empty"} {lappend r {}} {lappend r $i} } return $r } proc add_empty {tcllist} { set r {} foreach i $tcllist { if {$i eq {}} {lappend r "empty"} {lappend r $i} } return $r } # mechanism for uploading procs to gui interp, without the hassle of escaping [encoder] proc guiproc {name argz body} { # upload the decoder sys_gui "proc guiproc {name argz body} {set map {}; for {set i 0} {\$i < 256} {incr i} {lappend map %\[format %02x \$i\] \[format %c \$i\]}; foreach x {name argz body} {set \$x \[string map \$map \[set \$x\]\]}; uplevel \[list proc \$name \$argz \$body\]}\n" # build the mapping set map {} for {set i 0} {$i < 256} {incr i} { set chr [format %c $i] set hex [format %02x $i] if {[regexp {[^A-Za-z0-9]} $chr]} {lappend map $chr %$hex} } # encode data foreach x {name argz body} {set $x [string map $map [set $x]]} # upload proc sys_gui "guiproc $name $argz $body\n" } proc get_binbuf {self} { set ob [CAST_t_object $self] set binbuf [$ob cget -te_binbuf] set len [binbuf_getnatom $binbuf] set result {} for {set i 0} {$i < $len} {incr i} { set atom [binbuf_getatom $binbuf $i] lappend result $atom } return $result } } tclpd-0.3.0/Makefile0000644000175000017500000004313612064640353014524 0ustar zmoelnigzmoelnig## Pd library template version 1.0.13 # For instructions on how to use this template, see: # http://puredata.info/docs/developer/MakefileTemplate LIBRARY_NAME = tclpd # add your .c source files, one object per file, to the SOURCES # variable, help files will be included automatically, and for GUI # objects, the matching .tcl file too SOURCES = tclpd.c # list all pd objects (i.e. myobject.pd) files here, and their helpfiles will # be included automatically PDOBJECTS = # example patches and related files, in the 'examples' subfolder EXAMPLES = bitmap-help.pd bitmap-madness.pd bitmap.tcl colorpicker.tcl dynreceive-help.pd dynreceive.tcl dynroute-help.pd dynroute.tcl list_change-help.pd list_change.tcl properties.tcl slider2-help.pd slider2.tcl # manuals and related files, in the 'manual' subfolder MANUAL = # if you want to include any other files in the source and binary tarballs, # list them here. This can be anything from header files, test patches, # documentation, etc. README.txt and LICENSE.txt are required and therefore # automatically included EXTRA_DIST = tclpd.i tclpd.h hashtable.h $(EXTRA_SOURCES) ChangeLog.txt AUTHORS.txt TODO.txt # unit tests and related files here, in the 'unittests' subfolder UNITTESTS = # tclpd-specific source files # NOTE: modified to build and link these all into tclpd.pd_linux EXTRA_SOURCES = hashtable.c tcl_class.c tcl_loader.c tcl_proxyinlet.c tcl_typemap.c tcl_widgetbehavior.c #------------------------------------------------------------------------------# # # things you might need to edit if you are using other C libraries # #------------------------------------------------------------------------------# ALL_CFLAGS = -I"$(PD_INCLUDE)" -std=c99 -I/usr/include/tcl8.5 \ -I/Library/Frameworks/Tcl.framework/Headers \ -Wall -W -Wno-unused-parameter \ -DHASHTABLE_COPY_KEYS ALL_LDFLAGS = -fPIC SHARED_LDFLAGS = ALL_LIBS = LIBS_linux = -ltcl8.5 LIBS_macosx = -framework Tcl LIBS_windows = -ltcl85 "$(LIBRARY_NAME).def" #------------------------------------------------------------------------------# # # you shouldn't need to edit anything below here, if we did it right :) # #------------------------------------------------------------------------------# # these can be set from outside without (usually) breaking the build DEBUG ?= 0 CFLAGS = -fno-tree-vectorize -fno-strict-aliasing -Wno-strict-aliasing LDFLAGS = LIBS = # get library version from meta file LIBRARY_VERSION = $(shell sed -n 's|^\#X text [0-9][0-9]* [0-9][0-9]* VERSION \(.*\);|\1|p' $(LIBRARY_NAME)-meta.pd) ALL_CFLAGS += -DPD -DVERSION='"$(LIBRARY_VERSION)"' PD_INCLUDE = $(PD_PATH)/include/pd # where to install the library, overridden below depending on platform prefix = /usr/local libdir = $(prefix)/lib pkglibdir = $(libdir)/pd-externals objectsdir = $(pkglibdir) INSTALL = install INSTALL_PROGRAM = $(INSTALL) -p -m 644 INSTALL_DATA = $(INSTALL) -p -m 644 INSTALL_DIR = $(INSTALL) -p -m 755 -d ALLSOURCES := $(SOURCES) $(SOURCES_android) $(SOURCES_cygwin) $(SOURCES_macosx) \ $(SOURCES_iphoneos) $(SOURCES_linux) $(SOURCES_windows) DISTDIR=$(LIBRARY_NAME)-$(LIBRARY_VERSION) ORIGDIR=pd-$(LIBRARY_NAME:~=)_$(LIBRARY_VERSION) UNAME := $(shell uname -s) ifeq ($(UNAME),Darwin) CPU := $(shell uname -p) ifeq ($(CPU),arm) # iPhone/iPod Touch SOURCES += $(SOURCES_iphoneos) EXTENSION = pd_darwin SHARED_EXTENSION = dylib OS = iphoneos PD_PATH = /Applications/Pd-extended.app/Contents/Resources IPHONE_BASE=/Developer/Platforms/iPhoneOS.platform/Developer/usr/bin CC=$(IPHONE_BASE)/gcc CPP=$(IPHONE_BASE)/cpp CXX=$(IPHONE_BASE)/g++ ISYSROOT = -isysroot /Developer/Platforms/iPhoneOS.platform/Developer/SDKs/iPhoneOS3.0.sdk IPHONE_CFLAGS = -miphoneos-version-min=3.0 $(ISYSROOT) -arch armv6 OPT_CFLAGS = -fast -funroll-loops -fomit-frame-pointer ALL_CFLAGS := $(IPHONE_CFLAGS) $(ALL_CFLAGS) ALL_LDFLAGS += -arch armv6 -bundle -undefined dynamic_lookup $(ISYSROOT) SHARED_LDFLAGS += -arch armv6 -dynamiclib -undefined dynamic_lookup $(ISYSROOT) ALL_LIBS += -lc $(LIBS_iphoneos) STRIP = strip -x DISTBINDIR=$(DISTDIR)-$(OS) else # Mac OS X SOURCES += $(SOURCES_macosx) EXTENSION = pd_darwin SHARED_EXTENSION = dylib OS = macosx PD_PATH = /Applications/Pd-extended.app/Contents/Resources OPT_CFLAGS = -ftree-vectorize -ftree-vectorizer-verbose=2 -fast # build universal 32-bit on 10.4 and 32/64 on newer ifeq ($(shell uname -r | sed 's|\([0-9][0-9]*\)\.[0-9][0-9]*\.[0-9][0-9]*|\1|'), 8) FAT_FLAGS = -arch ppc -arch i386 -mmacosx-version-min=10.4 else FAT_FLAGS = -arch ppc -arch i386 -arch x86_64 -mmacosx-version-min=10.4 SOURCES += $(SOURCES_iphoneos) endif ALL_CFLAGS += $(FAT_FLAGS) -fPIC -I/sw/include # if the 'pd' binary exists, check the linking against it to aid with stripping BUNDLE_LOADER = $(shell test ! -e $(PD_PATH)/bin/pd || echo -bundle_loader $(PD_PATH)/bin/pd) ALL_LDFLAGS += $(FAT_FLAGS) -headerpad_max_install_names -bundle $(BUNDLE_LOADER) \ -undefined dynamic_lookup -L/sw/lib SHARED_LDFLAGS += $(FAT_FLAGS) -dynamiclib -undefined dynamic_lookup \ -install_name @loader_path/$(SHARED_LIB) -compatibility_version 1 -current_version 1.0 ALL_LIBS += -lc $(LIBS_macosx) STRIP = strip -x DISTBINDIR=$(DISTDIR)-$(OS) # install into ~/Library/Pd on Mac OS X since /usr/local isn't used much pkglibdir=$(HOME)/Library/Pd endif endif # Tho Android uses Linux, we use this fake uname to provide an easy way to # setup all this things needed to cross-compile for Android using the NDK ifeq ($(UNAME),ANDROID) CPU := arm SOURCES += $(SOURCES_android) EXTENSION = pd_linux SHARED_EXTENSION = so OS = android PD_PATH = /usr NDK_BASE := /usr/local/android-ndk NDK_PLATFORM_VERSION := 5 NDK_SYSROOT=$(NDK_BASE)/platforms/android-$(NDK_PLATFORM_VERSION)/arch-arm NDK_UNAME := $(shell uname -s | tr '[A-Z]' '[a-z]') NDK_TOOLCHAIN_BASE=$(NDK_BASE)/toolchains/arm-linux-androideabi-4.4.3/prebuilt/$(NDK_UNAME)-x86 CC := $(NDK_TOOLCHAIN_BASE)/bin/arm-linux-androideabi-gcc --sysroot=$(NDK_SYSROOT) OPT_CFLAGS = -O6 -funroll-loops -fomit-frame-pointer CFLAGS += LDFLAGS += -rdynamic -shared SHARED_LDFLAGS += -Wl,-soname,$(SHARED_LIB) -shared LIBS += -lc $(LIBS_android) STRIP := $(NDK_TOOLCHAIN_BASE)/bin/arm-linux-androideabi-strip \ --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS)-$(shell uname -m) endif ifeq ($(UNAME),Linux) CPU := $(shell uname -m) SOURCES += $(SOURCES_linux) EXTENSION = pd_linux SHARED_EXTENSION = so OS = linux PD_PATH = /usr OPT_CFLAGS = -O6 -funroll-loops -fomit-frame-pointer ALL_CFLAGS += -fPIC ALL_LDFLAGS += -rdynamic -shared -fPIC -Wl,-rpath,"\$$ORIGIN",--enable-new-dtags SHARED_LDFLAGS += -Wl,-soname,$(SHARED_LIB) -shared ALL_LIBS += -lc $(LIBS_linux) STRIP = strip --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS)-$(shell uname -m) endif ifeq ($(UNAME),GNU) # GNU/Hurd, should work like GNU/Linux for basically all externals CPU := $(shell uname -m) SOURCES += $(SOURCES_linux) EXTENSION = pd_linux SHARED_EXTENSION = so OS = linux PD_PATH = /usr OPT_CFLAGS = -O6 -funroll-loops -fomit-frame-pointer ALL_CFLAGS += -fPIC ALL_LDFLAGS += -rdynamic -shared -fPIC -Wl,-rpath,"\$$ORIGIN",--enable-new-dtags SHARED_LDFLAGS += -shared -Wl,-soname,$(SHARED_LIB) ALL_LIBS += -lc $(LIBS_linux) STRIP = strip --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS)-$(shell uname -m) endif ifeq ($(UNAME),GNU/kFreeBSD) # Debian GNU/kFreeBSD, should work like GNU/Linux for basically all externals CPU := $(shell uname -m) SOURCES += $(SOURCES_linux) EXTENSION = pd_linux SHARED_EXTENSION = so OS = linux PD_PATH = /usr OPT_CFLAGS = -O6 -funroll-loops -fomit-frame-pointer ALL_CFLAGS += -fPIC ALL_LDFLAGS += -rdynamic -shared -fPIC -Wl,-rpath,"\$$ORIGIN",--enable-new-dtags SHARED_LDFLAGS += -shared -Wl,-soname,$(SHARED_LIB) ALL_LIBS += -lc $(LIBS_linux) STRIP = strip --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS)-$(shell uname -m) endif ifeq (CYGWIN,$(findstring CYGWIN,$(UNAME))) CPU := $(shell uname -m) SOURCES += $(SOURCES_cygwin) EXTENSION = dll SHARED_EXTENSION = dll OS = cygwin PD_PATH = $(shell cygpath $$PROGRAMFILES)/pd OPT_CFLAGS = -O6 -funroll-loops -fomit-frame-pointer ALL_CFLAGS += ALL_LDFLAGS += -rdynamic -shared -L"$(PD_PATH)/src" -L"$(PD_PATH)/bin" SHARED_LDFLAGS += -shared -Wl,-soname,$(SHARED_LIB) ALL_LIBS += -lc -lpd $(LIBS_cygwin) STRIP = strip --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS) endif ifeq (MINGW,$(findstring MINGW,$(UNAME))) CPU := $(shell uname -m) SOURCES += $(SOURCES_windows) EXTENSION = dll SHARED_EXTENSION = dll OS = windows PD_PATH = $(shell cd "$$PROGRAMFILES/pd" && pwd) # MinGW doesn't seem to include cc so force gcc CC=gcc OPT_CFLAGS = -O3 -funroll-loops -fomit-frame-pointer ALL_CFLAGS += -mms-bitfields ALL_LDFLAGS += -s -shared -Wl,--enable-auto-import SHARED_LDFLAGS += -shared ALL_LIBS += -L"$(PD_PATH)/src" -L"$(PD_PATH)/bin" -L"$(PD_PATH)/obj" \ -lpd -lwsock32 -lkernel32 -luser32 -lgdi32 -liberty $(LIBS_windows) STRIP = strip --strip-unneeded -R .note -R .comment DISTBINDIR=$(DISTDIR)-$(OS) endif # in case somebody manually set the HELPPATCHES above HELPPATCHES ?= $(SOURCES:.c=-help.pd) $(PDOBJECTS:.pd=-help.pd) ifeq ($(DEBUG),1) ALL_CFLAGS += -O0 -g -ggdb -DDEBUG STRIP = echo else ALL_CFLAGS += $(OPT_CFLAGS) endif ALL_CFLAGS := $(ALL_CFLAGS) $(CFLAGS) $(OPT_CFLAGS) ALL_LDFLAGS := $(LDFLAGS) $(ALL_LDFLAGS) ALL_LIBS := $(LIBS) $(ALL_LIBS) SHARED_SOURCE ?= $(wildcard lib$(LIBRARY_NAME).c) SHARED_HEADER ?= $(shell test ! -e $(LIBRARY_NAME).h || echo $(LIBRARY_NAME).h) SHARED_LIB ?= $(SHARED_SOURCE:.c=.$(SHARED_EXTENSION)) SHARED_TCL_LIB = $(wildcard lib$(LIBRARY_NAME).tcl) .PHONY = install libdir_install single_install install-doc install-examples install-manual install-unittests clean distclean dist etags $(LIBRARY_NAME) all: $(SOURCES:.c=.$(EXTENSION)) $(SHARED_LIB) %.o: %.c $(CC) $(ALL_CFLAGS) -o "$*.o" -c "$*.c" tclpd.$(EXTENSION): tclpd.o $(SHARED_LIB) $(EXTRA_SOURCES:.c=.o) tcl_wrap.o $(CC) $(ALL_LDFLAGS) -o "tclpd.$(EXTENSION)" tclpd.o $(EXTRA_SOURCES:.c=.o) tcl_wrap.o $(ALL_LIBS) $(SHARED_LIB) chmod a-x "tclpd.$(EXTENSION)" tcl_wrap.c: tclpd.i tclpd.h Makefile swig -v -tcl -o tcl_wrap.c -I$(PD_INCLUDE) tclpd.i # this links everything into a single binary file $(LIBRARY_NAME): $(SOURCES:.c=.o) $(LIBRARY_NAME).o lib$(LIBRARY_NAME).o $(CC) $(ALL_LDFLAGS) -o $(LIBRARY_NAME).$(EXTENSION) $(SOURCES:.c=.o) \ $(LIBRARY_NAME).o lib$(LIBRARY_NAME).o $(ALL_LIBS) chmod a-x $(LIBRARY_NAME).$(EXTENSION) $(SHARED_LIB): $(SHARED_SOURCE:.c=.o) $(CC) $(SHARED_LDFLAGS) -o $(SHARED_LIB) $(SHARED_SOURCE:.c=.o) $(ALL_LIBS) test: tclpd.$(EXTENSION) make -C tests PD_PATH=$(PD_PATH) install: libdir_install # The meta and help files are explicitly installed to make sure they are # actually there. Those files are not optional, then need to be there. libdir_install: $(SOURCES:.c=.$(EXTENSION)) $(SHARED_LIB) install-doc install-examples install-manual install-unittests $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(INSTALL_DATA) $(LIBRARY_NAME)-meta.pd \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) test -z "$(strip $(SOURCES))" || (\ $(INSTALL_PROGRAM) $(SOURCES:.c=.$(EXTENSION)) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) && \ $(STRIP) $(addprefix $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/,$(SOURCES:.c=.$(EXTENSION)))) test -z "$(strip $(SHARED_LIB))" || \ $(INSTALL_DATA) $(SHARED_LIB) \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) test -z "$(strip $(wildcard $(SOURCES:.c=.tcl)))" || \ $(INSTALL_DATA) $(wildcard $(SOURCES:.c=.tcl)) \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) test -z "$(strip $(PDOBJECTS))" || \ $(INSTALL_DATA) $(PDOBJECTS) \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) test -z "$(strip $(SHARED_TCL_LIB))" || \ $(INSTALL_DATA) $(SHARED_TCL_LIB) \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(INSTALL_DATA) tclpd.tcl $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) ifeq ($(UNAME),Darwin) # force tclpd to use the Tcl.framework built into Pd-extended install_name_tool -change \ /Library/Frameworks/Tcl.framework/Versions/8.5/Tcl \ @executable_path/../../Frameworks/Tcl.framework/Versions/8.5/Tcl \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/$(LIBRARY_NAME).$(EXTENSION) endif # install library linked as single binary single_install: $(LIBRARY_NAME) install-doc install-examples install-manual install-unittests $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(INSTALL_PROGRAM) $(LIBRARY_NAME).$(EXTENSION) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(STRIP) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/$(LIBRARY_NAME).$(EXTENSION) install-doc: $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) test -z "$(strip $(SOURCES) $(PDOBJECTS))" || \ $(INSTALL_DATA) $(HELPPATCHES) \ $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(INSTALL_DATA) README.txt $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/README.txt $(INSTALL_DATA) LICENSE.txt $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/LICENSE.txt install-examples: test -z "$(strip $(EXAMPLES))" || \ $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/examples && \ for file in $(EXAMPLES); do \ $(INSTALL_DATA) examples/$$file $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/examples; \ done install-manual: test -z "$(strip $(MANUAL))" || \ $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/manual && \ for file in $(MANUAL); do \ $(INSTALL_DATA) manual/$$file $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/manual; \ done install-unittests: test -z "$(strip $(UNITTESTS))" || \ $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/unittests && \ for file in $(UNITTESTS); do \ $(INSTALL_DATA) unittests/$$file $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/unittests; \ done clean: -rm -f -- $(SOURCES:.c=.o) $(SOURCES_LIB:.c=.o) $(SHARED_SOURCE:.c=.o) -rm -f -- tcl_wrap.c tcl_wrap.o $(EXTRA_SOURCES:.c=.o) -rm -f -- $(SOURCES:.c=.$(EXTENSION)) -rm -f -- $(LIBRARY_NAME).o -rm -f -- $(LIBRARY_NAME).$(EXTENSION) -rm -f -- $(SHARED_LIB) make -C tests clean distclean: clean -rm -f -- $(DISTBINDIR).tar.gz -rm -rf -- $(DISTBINDIR) -rm -f -- $(DISTDIR).tar.gz -rm -rf -- $(DISTDIR) -rm -f -- $(ORIGDIR).tar.gz -rm -rf -- $(ORIGDIR) $(DISTBINDIR): $(INSTALL_DIR) $(DISTBINDIR) libdir: all $(DISTBINDIR) $(INSTALL_DATA) $(LIBRARY_NAME)-meta.pd $(DISTBINDIR) $(INSTALL_DATA) $(SOURCES) $(SHARED_SOURCE) $(SHARED_HEADER) $(DISTBINDIR) $(INSTALL_DATA) $(HELPPATCHES) $(DISTBINDIR) test -z "$(strip $(EXTRA_DIST))" || \ $(INSTALL_DATA) $(EXTRA_DIST) $(DISTBINDIR) # tar --exclude-vcs -czpf $(DISTBINDIR).tar.gz $(DISTBINDIR) $(DISTDIR): $(INSTALL_DIR) $(DISTDIR) $(ORIGDIR): $(INSTALL_DIR) $(ORIGDIR) dist: $(DISTDIR) $(INSTALL_DATA) Makefile $(DISTDIR) $(INSTALL_DATA) README.txt $(DISTDIR) $(INSTALL_DATA) LICENSE.txt $(DISTDIR) $(INSTALL_DATA) $(EXTRA_SOURCES) $(DISTDIR) $(INSTALL_DATA) $(LIBRARY_NAME)-meta.pd $(DISTDIR) test -z "$(strip $(ALLSOURCES))" || \ $(INSTALL_DATA) $(ALLSOURCES) $(DISTDIR) test -z "$(strip $(wildcard $(ALLSOURCES:.c=.tcl)))" || \ $(INSTALL_DATA) $(wildcard $(ALLSOURCES:.c=.tcl)) $(DISTDIR) test -z "$(strip $(wildcard $(LIBRARY_NAME).c))" || \ $(INSTALL_DATA) $(LIBRARY_NAME).c $(DISTDIR) test -z "$(strip $(SHARED_HEADER))" || \ $(INSTALL_DATA) $(SHARED_HEADER) $(DISTDIR) test -z "$(strip $(SHARED_SOURCE))" || \ $(INSTALL_DATA) $(SHARED_SOURCE) $(DISTDIR) test -z "$(strip $(SHARED_TCL_LIB))" || \ $(INSTALL_DATA) $(SHARED_TCL_LIB) $(DISTDIR) test -z "$(strip $(PDOBJECTS))" || \ $(INSTALL_DATA) $(PDOBJECTS) $(DISTDIR) test -z "$(strip $(HELPPATCHES))" || \ $(INSTALL_DATA) $(HELPPATCHES) $(DISTDIR) test -z "$(strip $(EXTRA_DIST))" || \ $(INSTALL_DATA) $(EXTRA_DIST) $(DISTDIR) test -z "$(strip $(EXAMPLES))" || \ $(INSTALL_DIR) $(DISTDIR)/examples && \ for file in $(EXAMPLES); do \ $(INSTALL_DATA) examples/$$file $(DISTDIR)/examples; \ done test -z "$(strip $(MANUAL))" || \ $(INSTALL_DIR) $(DISTDIR)/manual && \ for file in $(MANUAL); do \ $(INSTALL_DATA) manual/$$file $(DISTDIR)/manual; \ done test -z "$(strip $(UNITTESTS))" || \ $(INSTALL_DIR) $(DISTDIR)/unittests && \ for file in $(UNITTESTS); do \ $(INSTALL_DATA) unittests/$$file $(DISTDIR)/unittests; \ done tar --exclude-vcs -czpf $(DISTDIR).tar.gz $(DISTDIR) # make a Debian source package dpkg-source: debclean make distclean dist mv $(DISTDIR) $(ORIGDIR) tar --exclude-vcs -czpf ../$(ORIGDIR).orig.tar.gz $(ORIGDIR) rm -f -- $(DISTDIR).tar.gz rm -rf -- $(DISTDIR) $(ORIGDIR) cd .. && dpkg-source -b $(LIBRARY_NAME) etags: TAGS TAGS: $(wildcard $(PD_INCLUDE)/*.h) $(SOURCES) $(SHARED_SOURCE) $(SHARED_HEADER) etags $(wildcard $(PD_INCLUDE)/*.h) etags -a *.h $(SOURCES) $(SHARED_SOURCE) $(SHARED_HEADER) $(EXTRA_SOURCES) etags -a --language=none --regex="/proc[ \t]+\([^ \t]+\)/\1/" *.tcl showsetup: @echo "CC: $(CC)" @echo "CFLAGS: $(CFLAGS)" @echo "LDFLAGS: $(LDFLAGS)" @echo "LIBS: $(LIBS)" @echo "ALL_CFLAGS: $(ALL_CFLAGS)" @echo "ALL_LDFLAGS: $(ALL_LDFLAGS)" @echo "ALL_LIBS: $(ALL_LIBS)" @echo "PD_INCLUDE: $(PD_INCLUDE)" @echo "PD_PATH: $(PD_PATH)" @echo "objectsdir: $(objectsdir)" @echo "LIBRARY_NAME: $(LIBRARY_NAME)" @echo "LIBRARY_VERSION: $(LIBRARY_VERSION)" @echo "SOURCES: $(SOURCES)" @echo "SHARED_HEADER: $(SHARED_HEADER)" @echo "SHARED_SOURCE: $(SHARED_SOURCE)" @echo "SHARED_LIB: $(SHARED_LIB)" @echo "SHARED_TCL_LIB: $(SHARED_TCL_LIB)" @echo "PDOBJECTS: $(PDOBJECTS)" @echo "ALLSOURCES: $(ALLSOURCES)" @echo "ALLSOURCES TCL: $(wildcard $(ALLSOURCES:.c=.tcl))" @echo "UNAME: $(UNAME)" @echo "CPU: $(CPU)" @echo "pkglibdir: $(pkglibdir)" @echo "DISTDIR: $(DISTDIR)" @echo "ORIGDIR: $(ORIGDIR)" tclpd-0.3.0/tclpd.i0000644000175000017500000001127011674625147014350 0ustar zmoelnigzmoelnig%module tclpd %{ #undef EXTERN #include "tclpd.h" #define __attribute__(x) %} %include exception.i %include cpointer.i %include carrays.i %include typemaps.i %pointer_functions(t_atom, atom); %pointer_functions(t_symbol, symbol); /* %array_functions(t_atom_array, atom_array); Creates four functions. type *new_name(int nelements) type *delete_name(type *ary) type name_getitem(type *ary, int index) void name_setitem(type *ary, int index, type value) */ %typemap(in) (int argc, t_atom *argv) { if(Tcl_ListObjLength(interp, $input, &$1) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed to get list length"); } $2 = (t_atom *)getbytes(sizeof(t_atom) * $1); int i; Tcl_Obj *oi; for(i = 0; i < $1; i++) { if(Tcl_ListObjIndex(interp, $input, i, &oi) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed to access list element"); } if(tcl_to_pdatom(oi, &$2[i]) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed tcl_to_pdatom conversion"); } } } %typemap(freearg) (int argc, t_atom *argv) { if($2) freebytes($2, sizeof(t_atom) * $1); } %typemap(in) t_atom * { $1 = (t_atom *)getbytes(sizeof(t_atom)); if(tcl_to_pdatom($input, $1) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed tcl_to_pdatom conversion"); } } %typemap(freearg) t_atom * { freebytes($1, sizeof(t_atom)); } %typemap(out) t_atom * { Tcl_Obj *lst; if(pdatom_to_tcl($1, &lst) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed pdatom_to_tcl conversion"); } Tcl_SetObjResult(interp, lst); } %typemap(in) t_symbol * { if(tcl_to_pdsymbol($input, &$1) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed tcl_to_pdsymbol conversion"); } } %typemap(out) t_symbol * { Tcl_Obj *lst; if(pdsymbol_to_tcl($1, &lst) == TCL_ERROR) { SWIG_exception_fail(SWIG_RuntimeError, "failed pdsymbol_to_tcl conversion"); } Tcl_SetObjResult(interp, lst); } %typemap(in) t_tcl * { const char *str = Tcl_GetStringFromObj($input, NULL); $1 = object_table_get(str); SWIG_contract_assert($1, "not a t_tcl * instance") {}; } %typemap(in) t_pd * { const char *str = Tcl_GetStringFromObj($input, NULL); $1 = object_table_get(str); SWIG_contract_assert($1, "not a t_pd * instance") {}; // XXX: %typemap(out) missing!!! } %typemap(in) t_text * { int res = SWIG_ConvertPtr($input, &$1, $1_descriptor, 0 | 0 ); if(!SWIG_IsOK(res)) { const char *str = Tcl_GetStringFromObj($input, NULL); t_tcl *x = object_table_get(str); SWIG_contract_assert(x, "not a t_text * instance") {}; $1 = &x->o; } } %typemap(in) t_object * { const char *str = Tcl_GetStringFromObj($input, NULL); t_tcl *x = object_table_get(str); SWIG_contract_assert(x, "not a t_object * instance") {}; $1 = &x->o; } %typemap(in) struct _class * { const char *str = Tcl_GetStringFromObj($input, NULL); t_class *c = class_table_get(str); SWIG_contract_assert(c, "invalid class name") {}; $1 = c; } /* functions that are in m_pd.h but don't exist in modern versions of pd */ %ignore pd_getfilename; %ignore pd_getdirname; %ignore pd_anything; %ignore class_parentwidget; %ignore sys_isreadablefile; %ignore garray_get; %ignore c_extern; %ignore c_addmess; /* functions that we can't auto-wrap, because they have varargs */ %ignore post; %ignore class_new; /* functions that we can't auto-wrap, because */ %ignore glist_new; %ignore canvas_zapallfortemplate; %ignore canvas_fattenforscalars; %ignore canvas_visforscalars; %ignore canvas_clicksub; %ignore text_xcoord; %ignore text_ycoord; %ignore canvas_getglistonsuper; %ignore canvas_getfont; %ignore canvas_setusedastemplate; %ignore canvas_vistext; %ignore rtext_remove; %ignore canvas_recurapply; %ignore gobj_properties; /* function that we don't want to wrap, because they are internal */ %ignore tclpd_setup; %ignore tclpd_interp_error; %ignore tcl_to_pdatom; %ignore tcl_to_pdsymbol; %ignore pdatom_to_tcl; %ignore pdsymbol_to_tcl; %ignore class_table_add; %ignore class_table_remove; %ignore class_table_get; %ignore object_table_add; %ignore object_table_remove; %ignore object_table_get; /* not needed - typemaps take care of this */ %ignore gensym; /* end of ignore-list */ %include "m_pd.h" %include "g_canvas.h" %include "tclpd.h" /* this does the trick of solving TypeError in method 'xyz', argument 4 of type 't_atom *' */ /*%name(outlet_list) EXTERN void outlet_list(t_outlet *x, t_symbol *s, int argc, t_atom_array *argv); %name(outlet_anything) EXTERN void outlet_anything(t_outlet *x, t_symbol *s, int argc, t_atom_array *argv); */ tclpd-0.3.0/LICENSE.txt0000644000175000017500000003607511674625147014725 0ustar zmoelnigzmoelnig GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS tclpd-0.3.0/README.txt0000644000175000017500000000516011674625147014567 0ustar zmoelnigzmoelnig Tcl for Pd ========== This library allows to to write externals for Pd using the Tcl language. It wraps quite closely the pd API (m_pd.h, plus some private functions) Also a library of Tcl helper functions is provided. It is not mandatory to use it (moreover: it requires Tcl 8.5, while the tclpd external alone requires only Tcl 8.4), but it is a syntactic sugar and can simplify a lot the code. To use it simply add 'package require TclpdLib' in your Tcl external. Anyway, disregarding any approach chosen to develop Tcl externals, a general knowledge of Pd internals (atoms, symbols, symbol table, inlets, objects) is strongly required. (Pd-External-HOWTO is always a good reading) Compiling and installing ======================== To compile tclpd, simply type: make clean all To compile it with debug enabled: make DEBUG=1 clean all Requirements are pd >= 0.39, swig, c++ compiler. To install tclpd, simply copy it to /usr/lib/pd/extra (or where you installed pure-data). Writing GUI externals ===================== Pd is split into two processes: pd (the core) and pd-gui. A pd external executes in the core. The same applies for a Tcl external loaded by tclpd, because tclpd creates a Tcl interpreter for that, running in the same process as pd. On the gui side (pd-gui) there is another Tcl interpreter living in a separate process, which communicates with pd using a network socket. Communication happens in one way (pd to gui) with the sys_gui function, and in the other way using ::pdsend. (needs to set up a receiver using pdbind, check the examples). Data conversion between Tcl <=> Pd ================================== In pd objects communicate using messages, and messages are made up of atoms. An atom could be a float, a symbol, a list, and so on. Tcl usually doesn't make distinction between strings and numbers. This means that simply translating a message text into a string could lose information about the atom type (to pd, symbol 456 is different from float 456, but if we just convert it as a string "456" the type information is lost). To maintain atom type infrmation, pd atoms are represented in Tcl as two element lists, where the first element indicates the atom type. Some examples of this conversion: Pd: 456 Tcl: {float 456} Pd: symbol foo Tcl: {symbol foo} Pd: list cat dog 123 456 weee Tcl: {{symbol cat} {symbol dog} {float 123} {float 456} {symbol wee}} Examples ======== Some examples externals are provided, including their helpfile. Authors ======= Please refer to AUTHORS file found in tclpd package. License ======= Please refer to COPYING file found in tclpd package. tclpd-0.3.0/tcl_proxyinlet.c0000644000175000017500000000337211674625147016317 0ustar zmoelnigzmoelnig#include "tclpd.h" t_class *proxyinlet_class; void proxyinlet_init(t_proxyinlet *x) { //x->pd = proxyinlet_class; x->target = NULL; x->sel = gensym("none"); x->argc = 0; x->argv = NULL; } void proxyinlet_clear(t_proxyinlet *x) { if(x->argv) { freebytes(x->argv, x->argc * sizeof(*x->argv)); } } #define PROXYINLET_SEL_TO_LIST 0 // 0 or 1 void proxyinlet_anything(t_proxyinlet *x, t_symbol *s, int argc, t_atom *argv) { proxyinlet_clear(x); if(!(x->argv = (t_atom *)getbytes((argc+PROXYINLET_SEL_TO_LIST) * sizeof(*x->argv)))) { x->argc = 0; error("proxyinlet: getbytes: out of memory"); return; } x->argc = argc + PROXYINLET_SEL_TO_LIST; if(PROXYINLET_SEL_TO_LIST == 1) SETSYMBOL(&x->argv[0], s); else x->sel = s; int i; for(i = 0; i < argc; i++) { x->argv[i+PROXYINLET_SEL_TO_LIST] = argv[i]; } proxyinlet_trigger(x); } void proxyinlet_trigger(t_proxyinlet *x) { if(x->target != NULL && x->sel != gensym("none")) { tclpd_inlet_anything(x->target, x->ninlet, x->sel, x->argc, x->argv); } } t_atom * proxyinlet_get_atoms(t_proxyinlet *x) { return x->argv; } void proxyinlet_clone(t_proxyinlet *x, t_proxyinlet *y) { y->target = x->target; y->sel = x->sel; y->argc = x->argc; if(!(y->argv = (t_atom *)getbytes(y->argc * sizeof(*y->argv)))) { y->argc = 0; error("proxyinlet: getbytes: out of memory"); return; } int i; for(i = 0; i < x->argc; i++) { y->argv[i] = x->argv[i]; } } void proxyinlet_setup(void) { proxyinlet_class = class_new(gensym("tclpd proxyinlet"), 0, 0, sizeof(t_proxyinlet), 0, A_NULL); class_addanything(proxyinlet_class, proxyinlet_anything); } tclpd-0.3.0/ChangeLog.txt0000644000175000017500000000201511674625147015455 0ustar zmoelnigzmoelnigVersion 0.3.0: - Big rewrite, fixing typemaps - Support for most binbuf atoms (COMMA, SEMI, DOLLAR, DOLLSYM, ...) Version 0.2.3: - Big rewrite, using tcl namespaces (more tidy, more efficient) Version 0.2.2: - Requires pd 0.43 (logpost, pdpost) - Fixed "tclpd_get_instance_text cmd not found" bug - Makefile for all platforms - Replaced std::map with a minimal hashtable implementation - Added support for te_binbuf retrieval (for savefn) Version 0.2.1: - Added support for properties function. - Added support for pd_bind/unbind. - Added destructor call in pd_free. - Added support for glist_grab (needed for mouse motion) - Added support for loadbang - Added iemgui-style general purpose property panel - Introduced Tcl package logic (package name: Tclpd) Version 0.2: - Added support for GUI externals (widgetbehavior). - Added support for save function. - Fixed memory leaks. Version 0.1.1: - Basic support for atom conversion, pd classes, methods. - Fixed issues with tcl obj reference counter (segfaults). tclpd-0.3.0/AUTHORS.txt0000644000175000017500000000026411674625147014757 0ustar zmoelnigzmoelnigAuthors of tclpd. Federico Ferri I'd like to thank also Mathieu Bouchard for sharing its knowledge and giving advices, thus contributing to this project. tclpd-0.3.0/tclpd.h0000644000175000017500000001021611674625147014346 0ustar zmoelnigzmoelnig#include "m_pd.h" //#include "m_imp.h" #include "g_canvas.h" //#include "s_stuff.h" #include /* PATH_MAX is not defined in limits.h on some platforms */ #ifndef PATH_MAX #define PATH_MAX 4096 #endif #define TCLPD_VERSION "0.3.0" #define InitArray(name, size, value) for(int zz=0; zz<(size); zz++) name[zz]=value typedef struct _t_tcl { t_object o; int ninlets; /* used for proxy inlet count */ char *source_file; // Tcl-interpreter related objects: Tcl_Obj *self; Tcl_Obj *classname; Tcl_Obj *dispatcher; } t_tcl; typedef struct _t_proxyinlet { t_object obj; t_tcl *target; int ninlet; t_symbol *sel; int argc; t_atom *argv; } t_proxyinlet; /* tcl_proxyinlet.c */ extern t_class *proxyinlet_class; void proxyinlet_init(t_proxyinlet *x); void proxyinlet_clear(t_proxyinlet *x); void proxyinlet_anything(t_proxyinlet *x, t_symbol *s, int argc, t_atom *argv); void proxyinlet_trigger(t_proxyinlet *x); t_atom * proxyinlet_get_atoms(t_proxyinlet *x); void proxyinlet_clone(t_proxyinlet *x, t_proxyinlet *y); void proxyinlet_setup(void); /* tcl_wrap.c */ extern int Tclpd_SafeInit(Tcl_Interp *interp); /* tcl_typemap.c */ int tcl_to_pdatom(Tcl_Obj *input, t_atom *output); int tcl_to_pdsymbol(Tcl_Obj *input, t_symbol **output); int pdatom_to_tcl(t_atom *input, Tcl_Obj **output); int pdsymbol_to_tcl(t_symbol *input, Tcl_Obj **output); /* tclpd.c */ extern Tcl_Interp *tclpd_interp; extern void tclpd_setup(void); void tclpd_interp_error(t_tcl *x, int result); /* tcl_class.c */ void class_table_add(const char *n, t_class *c); void class_table_remove(const char *n); t_class * class_table_get(const char *n); void object_table_add(const char *n, t_tcl *o); void object_table_remove(const char *n); t_tcl * object_table_get(const char *n); t_class * tclpd_class_new(const char *name, int flags); t_class * tclpd_guiclass_new(const char *name, int flags); t_tcl * tclpd_new(t_symbol *classsym, int ac, t_atom *at); void tclpd_free (t_tcl *self); void tclpd_anything(t_tcl *self, t_symbol *s, int ac, t_atom *at); void tclpd_inlet_anything(t_tcl *self, int inlet, t_symbol *s, int ac, t_atom *at); void tclpd_loadbang(t_tcl *x); void tclpd_open(t_tcl *x); t_proxyinlet * tclpd_add_proxyinlet(t_tcl *x); /* t_tcl * tclpd_get_instance(const char *objectSequentialId); t_pd * tclpd_get_instance_pd(const char *objectSequentialId); t_text * tclpd_get_instance_text(const char *objectSequentialId); t_object * tclpd_get_object(const char *objectSequentialId); t_pd * tclpd_get_object_pd(const char *objectSequentialId); t_binbuf * tclpd_get_object_binbuf(const char *objectSequentialId); t_glist * tclpd_get_glist(const char *objectSequentialId); t_atom * tclpd_binbuf_get_atom(t_binbuf *b, int n); */ t_atom * binbuf_getatom(t_binbuf *x, int index); t_object * CAST_t_object(t_object *o); t_pd * CAST_t_pd(t_pd *o); t_text * CAST_t_text(t_text *o); t_tcl * CAST_t_tcl(t_tcl *o); void poststring2(const char *s); extern void text_save(t_gobj *z, t_binbuf *b); void tclpd_save(t_gobj *z, t_binbuf *b); void tclpd_properties(t_gobj *z, t_glist *owner); void tclpd_class_namespace_init(const char *classname); /* tcl_widgetbehavior.c */ void tclpd_guiclass_getrect(t_gobj *z, t_glist *owner, int *xp1, int *yp1, int *xp2, int *yp2); void tclpd_guiclass_displace(t_gobj *z, t_glist *glist, int dx, int dy); void tclpd_guiclass_select(t_gobj *z, t_glist *glist, int selected); void tclpd_guiclass_activate(t_gobj *z, t_glist *glist, int state); void tclpd_guiclass_delete(t_gobj *z, t_glist *glist); void tclpd_guiclass_vis(t_gobj *z, t_glist *glist, int vis); int tclpd_guiclass_click(t_gobj *z, t_glist *glist, int xpix, int ypix, int shift, int alt, int dbl, int doit); void tclpd_guiclass_motion(t_tcl *x, t_floatarg dx, t_floatarg dy); void tclpd_guiclass_grab(t_tcl *x, t_glist *glist, int xpix, int ypix); /* tcl_loader.c */ extern int tclpd_do_load_lib(t_canvas *canvas, char *objectname); /* pd loader private stuff: */ typedef int (*loader_t)(t_canvas *canvas, char *classname); extern void sys_register_loader(loader_t loader); extern int sys_onloadlist(char *classname); extern void sys_putonloadlist(char *classname); extern void class_set_extern_dir(t_symbol *s); tclpd-0.3.0/tclpd-meta.pd0000644000175000017500000000026211674625147015446 0ustar zmoelnigzmoelnig#N canvas 15 49 200 200 10; #N canvas 25 49 420 300 META 1; #X text 13 41 NAME tclpd; #X text 10 25 AUTHOR Federico Ferri; #X text 10 10 VERSION 0.3.0; #X restore 10 10 pd META; tclpd-0.3.0/tcl_typemap.c0000644000175000017500000001156511674625147015564 0ustar zmoelnigzmoelnig#include "tclpd.h" #include #include static const char *atomtype_map[] = { /* A_NULL */ "null", /* A_FLOAT */ "float", /* A_SYMBOL */ "symbol", /* A_POINTER */ "pointer", /* A_SEMI */ "semi", /* A_COMMA */ "comma", /* A_DEFFLOAT */ "deffloat", /* A_DEFSYM */ "defsym", /* A_DOLLAR */ "dollar", /* A_DOLLSYM */ "dollsym", /* A_GIMME */ "gimme", /* A_CANT */ "cant", #ifdef A_BLOB /* A_BLOB */ "blob" #endif }; #define atomtype_map_size (sizeof(atomtype_map)/sizeof(atomtype_map[0])) static const char * fwd_atomtype_map(t_atomtype t) { if(t >= atomtype_map_size) return atomtype_map[A_NULL]; return atomtype_map[t]; } static t_atomtype rev_atomtype_map(const char *s) { for(t_atomtype i = 0; i < atomtype_map_size; i++) { if(strcmp(s, atomtype_map[i]) == 0) return i; } return A_NULL; } int tcl_to_pdatom(Tcl_Obj *input, t_atom *output) { int llength; if(Tcl_ListObjLength(tclpd_interp, input, &llength) == TCL_ERROR) return TCL_ERROR; if(llength != 2) return TCL_ERROR; int i; Tcl_Obj *obj[2]; for(i = 0; i < 2; i++) Tcl_ListObjIndex(tclpd_interp, input, i, &obj[i]); char *argv0 = Tcl_GetStringFromObj(obj[0], 0); t_atomtype a_type = rev_atomtype_map(argv0); switch(a_type) { case A_FLOAT: case A_DEFFLOAT: { double dbl; if(Tcl_GetDoubleFromObj(tclpd_interp, obj[1], &dbl) == TCL_ERROR) return TCL_ERROR; SETFLOAT(output, dbl); break; } case A_SYMBOL: case A_DEFSYM: { SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); break; } case A_POINTER: { long gpointer; if(Tcl_GetLongFromObj(tclpd_interp, obj[1], &gpointer) == TCL_ERROR) return TCL_ERROR; SETPOINTER(output, (t_gpointer *)gpointer); break; } case A_SEMI: { SETSEMI(output); break; } case A_COMMA: { SETCOMMA(output); break; } case A_DOLLAR: { char *str = Tcl_GetStringFromObj(obj[1], 0); if(!str) { return TCL_ERROR; } if(*str == '$') str++; int ii = atoi(str); SETDOLLAR(output, ii); break; } case A_DOLLSYM: { SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); break; } // case A_GIMME: // case A_CANT: // case A_BLOB: // case A_NULL: default: { // TODO: set error result return TCL_ERROR; } } return TCL_OK; } int tcl_to_pdsymbol(Tcl_Obj *input, t_symbol **output) { char *s = Tcl_GetStringFromObj(input, 0); *output = gensym(s); return TCL_OK; } int pdatom_to_tcl(t_atom *input, Tcl_Obj **output) { Tcl_Obj *tcl_t_atom[2]; tcl_t_atom[0] = Tcl_NewStringObj(fwd_atomtype_map(input->a_type), -1); switch (input->a_type) { case A_FLOAT: case A_DEFFLOAT: { tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float); break; } case A_SYMBOL: case A_DEFSYM: case A_DOLLSYM: { tcl_t_atom[1] = Tcl_NewStringObj(input->a_w.w_symbol->s_name, strlen(input->a_w.w_symbol->s_name)); break; } case A_POINTER: { tcl_t_atom[1] = Tcl_NewDoubleObj((long)input->a_w.w_gpointer); break; } case A_DOLLAR: { char dolbuf[8]; snprintf(dolbuf, 8, "$%d", (int)input->a_w.w_index); tcl_t_atom[1] = Tcl_NewStringObj(dolbuf, -1); break; } case A_SEMI: { tcl_t_atom[1] = Tcl_NewStringObj(";", 1); break; } case A_COMMA: { tcl_t_atom[1] = Tcl_NewStringObj(",", 1); break; } case A_GIMME: case A_CANT: #ifdef A_BLOB case A_BLOB: #endif case A_NULL: default: { tcl_t_atom[1] = Tcl_NewStringObj("?", 1); break; } } #if 0 verbose(-1, "tclpd: pdatom_to_tcl: atom [type = %s, value = %s]", Tcl_GetStringFromObj(tcl_t_atom[0], 0), Tcl_GetStringFromObj(tcl_t_atom[1], 0)); #endif *output = Tcl_NewListObj(2, &tcl_t_atom[0]); Tcl_IncrRefCount(*output); return TCL_OK; } int pdsymbol_to_tcl(t_symbol *input, Tcl_Obj **output) { #if 0 Tcl_Obj *s[2]; s[0] = Tcl_NewStringObj("symbol", -1); s[1] = Tcl_NewStringObj(input->s_name, -1); *output = Tcl_NewListObj(2, &s[0]); #else *output = Tcl_NewStringObj(input->s_name, -1); #endif Tcl_IncrRefCount(*output); return TCL_OK; } tclpd-0.3.0/hashtable.c0000644000175000017500000000374611674625147015200 0ustar zmoelnigzmoelnig#include "hashtable.h" uint32_t hash_str(const char *s) { const unsigned char *p = (const unsigned char *)s; uint32_t h = 5381; while (*p) { h *= 33; h ^= *p++; } return h ^ (h >> 16); } list_node_t * list_add(list_node_t *head, const char *k, void *v) { list_node_t *n = (list_node_t *)malloc(sizeof(list_node_t)); n->next = head; #ifdef HASHTABLE_COPY_KEYS n->k = strdup(k); #else n->k = k; #endif n->v = v; return n; } list_node_t * list_remove(list_node_t *head, const char *k) { if(!head) return NULL; list_node_t *tmp; // head remove while(head && strcmp(head->k, k) == 0) { tmp = head; head = head->next; #ifdef HASHTABLE_COPY_KEYS free(tmp->k); #endif free(tmp); } list_node_t *p = head; // normal (non-head) remove while(p->next) { if(strcmp(p->next->k, k) == 0) { tmp = p->next; p->next = p->next->next; #ifdef HASHTABLE_COPY_KEYS free(tmp->k); #endif free(tmp); continue; } p = p->next; } return head; } list_node_t * list_get(list_node_t *head, const char *k) { while(head) { if(strcmp(head->k, k) == 0) { return head; } head = head->next; } return NULL; } size_t list_length(list_node_t *head) { size_t length = 0; while(head) { length++; head = head->next; } return length; } hash_table_t * hashtable_new(size_t size) { hash_table_t *ht = NULL; if(size > 0) { ht = (hash_table_t *)malloc(sizeof(hash_table_t)); ht->sz = size; ht->t = (list_node_t **)malloc(sizeof(list_node_t *) * size); for(int i = 0; i < size; i++) ht->t[i] = NULL; } return ht; } void hashtable_free(hash_table_t *ht) { if(ht) { free(ht->t); free(ht); } } tclpd-0.3.0/tcl_loader.c0000644000175000017500000000664111722454560015343 0ustar zmoelnigzmoelnig#include "tclpd.h" #include #include extern int sys_verbose; /* included in pd, also defined in s_stuff.h */ /* from tcl_class.c: */ //void source_table_remove(const char *object_name); void source_table_add(const char *object_name, const char *source_path); extern int tclpd_do_load_lib(t_canvas *canvas, char *objectname) { char filename[MAXPDSTRING], dirbuf[MAXPDSTRING], buf[MAXPDSTRING], *classname, *nameptr; int fd; if ((classname = strrchr(objectname, '/')) != NULL) classname++; else classname = objectname; if(sys_onloadlist(objectname)) { verbose(-1, "tclpd loader: already loaded: %s", objectname); return 1; } /* try looking in the path for (objectname).(tcl) ... */ if(sys_verbose) verbose(-1, "tclpd loader: searching for %s in path...", objectname); if ((fd = canvas_open(canvas, objectname, ".tcl", dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) goto found; /* next try (objectname)/(classname).(tcl) ... */ strncpy(filename, objectname, MAXPDSTRING); filename[MAXPDSTRING - 2] = 0; strcat(filename, "/"); strncat(filename, classname, MAXPDSTRING-strlen(filename)); filename[MAXPDSTRING - 1] = 0; if(sys_verbose) verbose(-1, "tclpd loader: searching for %s in path...", filename); if ((fd = canvas_open(canvas, filename, ".tcl", dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) goto found; if(sys_verbose) verbose(-1, "tclpd loader: found nothing!"); return 0; found: verbose(-1, "tclpd loader: found!"); close(fd); class_set_extern_dir(gensym(dirbuf)); /* rebuild the absolute pathname */ strncpy(filename, dirbuf, MAXPDSTRING); filename[MAXPDSTRING - 2] = 0; strcat(filename, "/"); strncat(filename, nameptr, MAXPDSTRING - strlen(filename)); filename[MAXPDSTRING - 1] = 0; verbose(-1, "tclpd loader: absolute path is %s", filename); int result; // create the required tcl namespace for the class verbose(-1, "tclpd loader: init namespace for class %s", classname); tclpd_class_namespace_init(classname); // add current dir to the Tcl auto_path so objects can use local packages Tcl_Eval(tclpd_interp, "set current_auto_path $auto_path"); snprintf(buf, MAXPDSTRING, "set auto_path \"{%s} $auto_path\"", dirbuf); Tcl_Eval(tclpd_interp, buf); verbose(0, buf); // load tcl external: verbose(-1, "tclpd loader: loading tcl file %s", filename); result = Tcl_EvalFile(tclpd_interp, filename); if(result == TCL_OK) { source_table_add(classname, filename); verbose(0, "tclpd loader: loaded %s", filename); } else { error("tclpd loader: error trying to load %s", filename); tclpd_interp_error(NULL, result); return 0; } // reset auto_path Tcl_Eval(tclpd_interp, "set auto_path $current_auto_path"); #ifdef TCLPD_CALL_SETUP // call the setup method: char cmd[64]; snprintf(cmd, 64, "::%s::setup", classname); verbose(-1, "tclpd loader: calling setup function for %s", classname); result = Tcl_Eval(tclpd_interp, cmd); if(result == TCL_OK) { } else { error("tclpd loader: error in %s %s::setup", filename, classname); tclpd_interp_error(NULL, result); return 0; } #endif // TCLPD_CALL_SETUP class_set_extern_dir(&s_); sys_putonloadlist(objectname); return 1; } tclpd-0.3.0/hashtable.h0000644000175000017500000000247412064640353015170 0ustar zmoelnigzmoelnig#ifndef HASHTABLE_H_INCLUDED #define HASHTABLE_H_INCLUDED /* in order to get strdup(), this needs to be defined */ #define _BSD_SOURCE #include #include #include typedef struct list_node { const char *k; void *v; struct list_node *next; } list_node_t; typedef struct hash_table { list_node_t **t; size_t sz; } hash_table_t; uint32_t hash_str(const char *s); list_node_t * list_add(list_node_t *head, const char *k, void *v); list_node_t * list_remove(list_node_t *head, const char *k); list_node_t * list_get(list_node_t *head, const char *k); size_t list_length(list_node_t *head); hash_table_t * hashtable_new(size_t size); void hash_table_free(hash_table_t *ht); static inline void hashtable_add(hash_table_t *ht, const char *name, void *c) { uint32_t h = hash_str(name) % ht->sz; ht->t[h] = list_add(ht->t[h], name, (void *)c); } static inline void hashtable_remove(hash_table_t *ht, const char *name) { uint32_t h = hash_str(name) % ht->sz; ht->t[h] = list_remove(ht->t[h], name); } static inline void * hashtable_get(hash_table_t *ht, const char *name) { uint32_t h = hash_str(name) % ht->sz; list_node_t *n = list_get(ht->t[h], name); return n ? n->v : NULL; } #endif // HASHTABLE_H_INCLUDED tclpd-0.3.0/tclpd-help.pd0000644000175000017500000000071712064640353015443 0ustar zmoelnigzmoelnig#N canvas 313 235 450 300 10; #X declare -lib tclpd; #X text 24 52 tclpd is a loader that allows Pd to load Tcl scripts as regular Pd objects. Normally you would load it when you start Pd \, so something like:; #X text 50 111 pd -lib tclpd; #X obj 51 169 declare -lib tclpd; #X text 26 135 or you can load it in the patch using:; #X text 24 202 You shouldn't try to create a [tclpd] object \, that will likely cause problems and not give you the desired effect.; tclpd-0.3.0/examples/0000755000175000017500000000000012564450620014674 5ustar zmoelnigzmoelnigtclpd-0.3.0/examples/bitmap.tcl0000644000175000017500000002471011674625147016671 0ustar zmoelnigzmoelnigpackage require Tclpd 0.3.0 package require TclpdLib 0.20 set ::script_path [file dirname [info script]] pd::guiproc bitmap_draw_new {self c x y config data} { set w [dict get $config -uwidth] set h [dict get $config -uheight] set sz [dict get $config -cellsize] set fgcolor [dict get $config -fgcolor] set bgcolor [dict get $config -bgcolor] set colors [list $bgcolor $fgcolor] set z 0 for {set i 0} {$i < $h} {incr i} { for {set j 0} {$j < $w} {incr j} { $c create rectangle \ [expr {0+$x+$j*$sz}] [expr {0+$y+$i*$sz}] \ [expr {1+$x+($j+1)*$sz}] [expr {1+$y+($i+1)*$sz}] \ -outline $fgcolor -fill [lindex $colors [lindex $data $z]] \ -tags [list $self cell_${j}_${i}_$self] incr z } } set x2 [expr {$x+$w*$sz+1}] set y2 [expr {$y+$h*$sz+1}] $c create rectangle $x $y $x2 $y2 \ -outline $fgcolor -tags [list $self border$self] } proc+ bitmap::constructor {self args} { set @canvas [canvas_getcurrent] set s [file join $::script_path properties.tcl] sys_gui "source {$s}\n" pd::add_outlet $self float # set defaults: set @config [list] lappend @config -uwidth 8 lappend @config -uheight 8 lappend @config -cellsize 16 lappend @config -label {} lappend @config -labelpos {top} lappend @config -sendsymbol {} lappend @config -receivesymbol {} lappend @config -fgcolor {#000000} lappend @config -bgcolor {#ffffff} lappend @config -lblcolor {#000000} set @data { 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } # expanded ($n) send/recv symbols: set @send {} set @recv {} 0_config $self {*}$args set @rcvLoadData {#bitmap} set x [pd_findbyclass $@rcvLoadData bitmap] if {$x ne "NULL"} { # prevent crash due to stale bound receivers: pd_unbind $x $@rcvLoadData } pd_bind $self $@rcvLoadData } proc+ bitmap::destructor {self} { set x [pd_findbyclass $@rcvLoadData bitmap] if {$x ne "NULL"} { pd_unbind $x $@rcvLoadData } if {[dict get $@config -receivesymbol] ne {}} { pd_unbind $self $@recv } } proc+ bitmap::0_config {self args} { if {$args eq {}} { return $@config } else { set newconf [list] set optlist [pd::strip_selectors $args] set optlist [pd::strip_empty $optlist] for {set i 0} {$i < [llength $optlist]} {} { set k [lindex $optlist $i] if {![dict exists $@config $k]} { return -code error "unknown option '$k'" } incr i set v [lindex $optlist $i] if {[lsearch -exact {-uwidth -uheight -cellsize} $k] != -1} { set v [expr {int($v)}] } dict set newconf $k $v incr i } if {[dict get $@config -uwidth] != [dict get $newconf -uwidth] || [dict get $@config -uheight] != [dict get $newconf -uheight]} { 0_resize $self {*}[pd::add_selectors [list \ [dict get $newconf -uwidth] \ [dict get $newconf -uheight] \ ]] } set ui 0 foreach opt {label labelpos cellsize fgcolor bgcolor lblcolor} { set old [dict get $@config -$opt] if {[dict exists $newconf -$opt]} { set new [dict get $newconf -$opt] if {$old ne $new} { dict set @config -$opt $new set ui 1 } } } foreach opt {sendsymbol receivesymbol} { set old [dict get $@config -$opt] if {[dict exists $newconf -$opt]} { set new [dict get $newconf -$opt] if {$old ne $new} { if {$opt eq {receivesymbol}} { if {$old ne {}} { pd_unbind $self $@recv } if {$new ne {}} { set @recv [canvas_realizedollar $@canvas $new] pd_bind $self $@recv } else { set @recv {} } } dict set @config -$opt $new } } } if {$ui && [info exists @c]} { sys_gui [list $@c delete $self]\n sys_gui [list bitmap_draw_new $self \ $@c $@x $@y $@config $@data]\n } } } proc+ bitmap::0_resize {self args} { set w [pd::arg 0 int] set h [pd::arg 1 int] set oldw [dict get $@config -uwidth] set oldh [dict get $@config -uheight] set newd {} for {set y 0} {$y < $h} {incr y} { for {set x 0} {$x < $w} {incr x} { if {$x < $oldw && $y < $oldh} { lappend newd [lindex $@data [expr {$y*$oldw+$x}]] } else { lappend newd 0 } } } dict set @config -uwidth $w dict set @config -uheight $h set @data $newd } proc+ bitmap::0_getrow {self args} { set r [list] set n [pd::arg 0 int] set w [dict get $@config -uwidth] for {set i [expr {$n*$w}]} {$i < [expr {($n+1)*$w}]} {incr i} { lappend r [list float [lindex $@data $i]] } pd::outlet $self 0 list $r } proc+ bitmap::0_getcol {self args} { set r [list] set n [pd::arg 0 int] set w [dict get $@config -uwidth] set h [dict get $@config -uheight] for {set i [expr {$n}]} {$i < [expr {$w*$h}]} {incr i $w} { lappend r [list float [lindex $@data $i]] } pd::outlet $self 0 list $r } proc+ bitmap::0_getcell {self args} { set r [pd::arg 0 int] set c [pd::arg 1 int] set w [dict get $@config -uwidth] pd::outlet $self 0 float [lindex $@data [expr {$r*$w+$c}]] } proc+ bitmap::0_setrow {self args} { set row [pd::arg 0 int] set z 1 set col 0 set w [dict get $@config -uwidth] set fgcolor [dict get $@config -fgcolor] set bgcolor [dict get $@config -bgcolor] set colors [list $bgcolor $fgcolor] for {set idx [expr {$row*$w}]} {$idx < [expr {($row+1)*$w}]} {incr idx} { set d [expr {0 != [pd::arg $z int]}] lset @data $idx $d sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ -fill [lindex $colors $d]]\n incr z incr col } } proc+ bitmap::0_setcol {self args} { set col [pd::arg 0 int] set z 1 set row 0 set w [dict get $@config -uwidth] set h [dict get $@config -uheight] set fgcolor [dict get $@config -fgcolor] set bgcolor [dict get $@config -bgcolor] set colors [list $bgcolor $fgcolor] for {set idx [expr {$col}]} {$idx < [expr {$w*$h}]} {incr idx $w} { set d [expr {0 != [pd::arg $z int]}] lset @data $idx $d sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ -fill [lindex $colors $d]]\n incr z incr row } } proc+ bitmap::0_setcell {self args} { set r [pd::arg 0 int] set c [pd::arg 1 int] set d [expr {0 != [pd::arg 2 int]}] set w [dict get $@config -uwidth] set fgcolor [dict get $@config -fgcolor] set bgcolor [dict get $@config -bgcolor] set colors [list $bgcolor $fgcolor] set idx [expr {$r*$w+$c}] lset @data $idx $d sys_gui [list $@c itemconfigure cell_${r}_${c}_$self \ -fill [lindex $colors $d]]\n } proc+ bitmap::0_setdata {self args} { set d [pd::strip_selectors $args] set l [llength $d] set w [dict get $@config -uwidth] set h [dict get $@config -uheight] if {$l != $w*$h} { return -code error "bad data size" } set @data [list] foreach i $d {lappend @data [expr {int($i)}]} set x [pd_findbyclass $@rcvLoadData bitmap] if {$x ne "NULL"} { pd_unbind $self $@rcvLoadData } } proc+ bitmap::save {self args} { return [list #X obj $@x $@y bitmap {*}[pd::add_empty $@config] \; \ \#bitmap setdata {*}$@data \; ] } proc+ bitmap::properties {self args} { set title "\[bitmap\] properties" set buf [list propertieswindow %s $@config $title]\n gfxstub_new $self $self $buf } proc+ bitmap::widgetbehavior_getrect {self args} { lassign $args x1 y1 set w [dict get $@config -uwidth] set h [dict get $@config -uheight] set sz [dict get $@config -cellsize] set x2 [expr {1+$x1+$w*$sz}] set y2 [expr {1+$y1+$h*$sz}] return [list $x1 $y1 $x2 $y2] } proc+ bitmap::widgetbehavior_displace {self args} { set dx [lindex $args 0] set dy [lindex $args 1] if {$dx != 0 || $dy != 0} { incr @x $dx incr @y $dy sys_gui [list $@c move $self $dx $dy]\n } return [list $@x $@y] } proc+ bitmap::widgetbehavior_select {self args} { set sel [lindex $args 0] set fgcolor [dict get $@config -fgcolor] set bgcolor [dict get $@config -bgcolor] set selcolor {blue} set colors [list $selcolor $fgcolor] sys_gui [list $@c itemconfigure $self \ -outline [lindex $colors $sel]]\n } proc+ bitmap::widgetbehavior_activate {self args} { } proc+ bitmap::widgetbehavior_vis {self args} { set @c [lindex $args 0] set @x [lindex $args 1] set @y [lindex $args 2] set vis [lindex $args 3] set w [dict get $@config -uwidth] set h [dict get $@config -uheight] set sz [dict get $@config -cellsize] if {$vis} { sys_gui [list bitmap_draw_new $self $@c $@x $@y $@config $@data]\n } else { sys_gui [list $@c delete $self]\n } } proc+ bitmap::widgetbehavior_click {self args} { set w [dict get $@config -uwidth] set h [dict get $@config -uheight] set sz [dict get $@config -cellsize] set fgcolor [dict get $@config -fgcolor] set bgcolor [dict get $@config -bgcolor] set colors [list $bgcolor $fgcolor] set xpix [expr {[lindex $args 0]-$@x-1}] set ypix [expr {[lindex $args 1]-$@y-1}] if {$xpix < 0 || $xpix >= $w*$sz} {return} if {$ypix < 0 || $ypix >= $h*$sz} {return} set shift [lindex $args 2] set alt [lindex $args 3] set dbl [lindex $args 4] set doit [lindex $args 5] if {$doit} { set j [expr {$xpix/$sz}] set i [expr {$ypix/$sz}] set idx [expr {$w*${i}+${j}}] set d [expr {[lindex $@data $idx] == 0}] lset @data $idx $d sys_gui [list $@c itemconfigure cell_${j}_${i}_$self \ -fill [lindex $colors $d]]\n } } pd::guiclass bitmap tclpd-0.3.0/examples/dynreceive-help.pd0000644000175000017500000000123611674625147020317 0ustar zmoelnigzmoelnig#N canvas 416 120 513 409 10; #X obj 141 168 s \$0.foo; #X msg 46 120 bar baz; #X obj 60 320 dynreceive \$0.foo; #X floatatom 122 123 5 0 0 0 - - -; #X symbolatom 177 125 10 0 0 0 - - -; #X obj 267 125 bng 15 250 50 0 empty empty empty 17 7 0 10 -262144 -1 -1; #X text 43 86 1) send some symbols:; #X text 45 240 2) try to change the receive symbol:; #X msg 60 287 set xyz; #X msg 312 306 \; xyz 1 2 3; #X obj 60 350 print out; #X text 39 23 Works like [receive] \, but allows to dynamically set (or clear) the receive symbol.; #X text 139 288 <--; #X connect 1 0 0 0; #X connect 2 0 10 0; #X connect 3 0 0 0; #X connect 4 0 0 0; #X connect 5 0 0 0; #X connect 8 0 2 0; tclpd-0.3.0/examples/list_change-help.pd0000644000175000017500000000121211674625147020434 0ustar zmoelnigzmoelnig#N canvas 294 76 635 406 10; #X obj 54 240 list_change; #X text 144 236 right inlet sets internal value without output anything ; #X obj 71 271 bng 15 250 50 0 empty empty empty 17 7 0 10 -262144 -1 -1; #X obj 54 309 print; #X text 33 21 Outputs its input (a list) only when it changes. You can set the current value using the right inlet \, or bang to force output; #X msg 117 201 list foo bar; #X msg 69 140 list foo bar; #X msg 77 163 list bar baz; #X msg 54 104 bang; #X text 98 103 output current value; #X connect 0 0 2 0; #X connect 0 0 3 0; #X connect 5 0 0 1; #X connect 6 0 0 0; #X connect 7 0 0 0; #X connect 8 0 0 0; tclpd-0.3.0/examples/slider2.tcl0000644000175000017500000002374211674625147016765 0ustar zmoelnigzmoelnigpackage require Tclpd 0.3.0 package require TclpdLib 0.20 set ::script_path [file dirname [info script]] pd::guiproc slider2_draw_new {self c x y config state} { # import variables from dicts: foreach v {headsz width height fgcolor bgcolor orient} \ {set $v [dict get $config -$v]} set x2 [expr {$x+$width+1}] set y2 [expr {$y+$height+1}] $c create rectangle $x $y $x2 $y2 \ -outline $fgcolor -fill $bgcolor -tags [list $self border$self] switch $orient { horizontal {set y1 $y; set x3 [expr {$x+$headsz}]} vertical {set y1 [expr {$y2-$headsz}]; set x3 $x2} } $c create rectangle $x $y1 $x3 $y2 -outline {} -fill $fgcolor \ -tags [list $self head$self] slider2_update $self $c $x $y $config $state } pd::guiproc slider2_update {self c x y config state} { # import variables from dicts: foreach v {initvalue headsz width height label labelpos lblcolor orient} \ {set $v [dict get $config -$v]} foreach v {min max rev} {set $v [dict get $state _$v]} set realvalue [expr {1.0*($initvalue-$min)/($max-$min)}] if {$realvalue < 0.0} {set realvalue 0} if {$realvalue > 1.0} {set realvalue 1} if {$rev} {set realvalue [expr {1.0-$realvalue}]} if {$orient eq {vertical}} {set realvalue [expr {1.0-$realvalue}]} switch $orient { horizontal { set hr [expr {$width-$headsz}] $c coords head$self [expr {$x+$hr*$realvalue}] $y \ [expr {$x+$hr*$realvalue+$headsz}] [expr {$y+$height+1}] } vertical { set vr [expr {$height-$headsz}] $c coords head$self $x [expr {$y+$vr*$realvalue}] \ [expr {$x+$width+1}] [expr {$y+$vr*$realvalue+$headsz}] } } $c delete label$self if {$label ne {}} { switch $labelpos { top {set lx [expr {$x+$width/2}]; set ly [expr {$y}]; set a "s"} bottom {set lx [expr {$x+$width/2}]; set ly [expr {$y+$height+2}]; set a "n"} left {set lx [expr {$x}]; set ly [expr {$y+$height/2}]; set a "e"} right {set lx [expr {$x+$width+2}]; set ly [expr {$y+$height/2}]; set a "w"} } $c create text $lx $ly -anchor $a -text $label -fill $lblcolor \ -tags [list $self label$self] } } proc+ slider2::constructor {self args} { set @canvas [canvas_getcurrent] pd::add_outlet $self float sys_gui "source {[file join $::script_path properties.tcl]}\n" # set defaults: set @config { -width 15 -height 130 -headsz 3 -rangebottom 0 -rangetop 127 -init 0 -initvalue 0 -jumponclick 0 -label {} -labelpos {top} -orient {vertical} -sendsymbol {} -receivesymbol {} -fgcolor {#000000} -bgcolor {#ffffff} -lblcolor {#000000} } set @state {_min 0 _max 127 _rev 0} # expanded ($n) send/recv symbols: set @send {} set @recv {} 0_config $self {*}$args } proc+ slider2::destructor {self} { if {[dict get $@config -receivesymbol] ne {}} { pd_unbind $self $@recv } } proc+ slider2::0_loadbang {self} { if {[dict get $@config -init]} {0_bang $self} } proc+ slider2::0_printconfig {self args} { if {[llength $args] == 0} { pd::post $@config return } } proc+ slider2::0_config2 {self args} { uplevel "0_config $self [string map {$ @} $args]" } proc+ slider2::0_config {self args} { pd::post [info level 0] set newconf [list] set optlist [pd::strip_selectors $args] set optlist [pd::strip_empty $optlist] set int_opts {-width -height -cellsize} set bool_opts {-init -jumponclick} set ui_opts {-fgcolor -bgcolor -lblcolor -orient -width -height} set upd_opts {-rangebottom -rangetop -label -labelpos} set conn_opts {-sendsymbol -receivesymbol} set ui 0 set upd 0 foreach {k v} $optlist { if {![dict exists $@config $k]} { return -code error "unknown option '$k'" } if {[dict get $@config $k] eq $v} {continue} if {[lsearch -exact $int_opts $k] != -1} {set v [expr {int($v)}]} if {[lsearch -exact $bool_opts $k] != -1} {set v [expr {int($v) != 0}]} if {[lsearch -exact $ui_opts $k] != -1} {set ui 1} if {[lsearch -exact $upd_opts $k] != -1} {set upd 1} dict set newconf $k $v } # process -{send,receive}symbol if {[dict exists $newconf -receivesymbol]} { set new_recv [dict get $newconf -receivesymbol] if {[dict get $@config -receivesymbol] ne {}} { pd_unbind $self $@recv } if {$new_recv ne {}} { set @recv [canvas_realizedollar $@canvas $new_recv] pd_bind $self $@recv } else {set @recv {}} } if {[dict exists $newconf -sendsymbol]} { set new_send [dict get $newconf -sendsymbol] if {$new_send ne {}} { set @send [canvas_realizedollar $@canvas $new_send] } else {set @send {}} } # changing orient -> swap sizes if {[dict exists $newconf -orient] && ![dict exists $newconf -width] && ![dict exists $newconf -height]} { dict set newconf -width [dict get $@config -height] dict set newconf -height [dict get $@config -width] } # no errors up to this point. we can safely merge options set @config [dict merge $@config $newconf] # adjust reverse range set a [dict get $@config -rangebottom] set b [dict get $@config -rangetop] dict set @state _min [expr {$a>$b?$b:$a}] dict set @state _max [expr {$a>$b?$a:$b}] dict set @state _rev [expr {$a>$b}] set orient [dict get $@config -orient] switch $orient { horizontal {set dim [dict get $@config -width]; set mul 1} vertical {set dim [dict get $@config -height]; set mul -1} default {return -code error "invalid value '$orient' for -orient"} } # recompute pix2units conversion set @pix2units [expr {(2.0 * [dict get $@state _rev] - 1.0) * ( [dict get $@state _max] - [dict get $@state _min] ) * $mul / ( $dim - [dict get $@config -headsz])}] # if ui changed, update it if {$ui && [info exists @c]} { sys_gui [list $@c delete $self]\n sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n } elseif {$upd && [info exists @c]} { sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n } if {[dict exists $newconf -width] || [dict exists $newconf -height]} { canvas_fixlinesfor $@canvas $self } } proc+ slider2::0_set {self args} { foreach v {min max} {set $v [dict get $@state _$v]} set f [pd::arg 0 float] if {$f < $min} {set f $min} if {$f > $max} {set f $max} dict set @config -initvalue $f if {[info exists @c]} { # update ui: sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n } } proc+ slider2::0_bang {self} { foreach v {initvalue} {set $v [dict get $@config -$v]} pd::outlet $self 0 float $initvalue if {$@send ne {}} { set s_thing [$@send cget -s_thing] if {$s_thing ne {NULL}} {pd_float $s_thing $initvalue} } } proc+ slider2::0_float {self args} { 0_set $self {*}$args 0_bang $self } proc+ slider2::save {self} { set c $@config # use -sendsymbol and -receivesymbol from original binbuf, because of '$' set c2 [pd::strip_selectors [lrange [pd::get_binbuf $self] 1 end]] foreach opt {-sendsymbol -receivesymbol} { dict set c $opt [dict get $c2 $opt] } set l [list #X obj $@x $@y slider2 {*}[pd::add_empty $c] \;] return $l } proc+ slider2::properties {self} { set c $@config # use -sendsymbol and -receivesymbol from original binbuf, because of '$' set c2 [pd::strip_selectors [lrange [pd::get_binbuf $self] 1 end]] foreach opt {-sendsymbol -receivesymbol} { dict set c $opt [dict get $c2 $opt] } set c [string map {$ @} $c] gfxstub_new $self $self \ [list propertieswindow %s $c "\[slider2\] properties"]\n } proc+ slider2::widgetbehavior_getrect {self args} { lassign $args x1 y1 set x2 [expr {1+$x1+[dict get $@config -width]}] set y2 [expr {1+$y1+[dict get $@config -height]}] return [list $x1 $y1 $x2 $y2] } proc+ slider2::widgetbehavior_displace {self args} { lassign $args dx dy if {$dx != 0 || $dy != 0} { incr @x $dx; incr @y $dy sys_gui [list $@c move $self $dx $dy]\n } return [list $@x $@y] } proc+ slider2::widgetbehavior_select {self args} { lassign $args sel sys_gui [list $@c itemconfigure $self&&!label$self -outline [lindex \ [list [dict get $@config -fgcolor] {blue}] $sel]]\n } proc+ slider2::widgetbehavior_vis {self args} { lassign $args @c @x @y vis if {$vis} { sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n } else { sys_gui [list $@c delete $self]\n } } proc+ slider2::widgetbehavior_click {self args} { lassign $args x y shift alt dbl doit set h [dict get $@config -height] set ypix [expr {[lindex $args 1]-$@y-1}] if {$ypix < 0 || $ypix >= $h} {return} if {$doit} { switch [dict get $@config -orient] { horizontal { set @motion_start_x $x set @motion_curr_x $x } vertical { set @motion_start_y $y set @motion_curr_y $y } } set @motion_start_v [dict get $@config -initvalue] tclpd_guiclass_grab $self $@canvas $x $y } } proc+ slider2::widgetbehavior_motion {self args} { lassign $args dx dy switch [dict get $@config -orient] { horizontal { set @motion_curr_x [expr {$dx+$@motion_curr_x}] set pixdelta [expr {-1*($@motion_curr_x-$@motion_start_x)}] } vertical { set @motion_curr_y [expr {$dy+$@motion_curr_y}] set pixdelta [expr {-1*($@motion_curr_y-$@motion_start_y)}] } } set f [expr {$@motion_start_v+$pixdelta*$@pix2units}] 0_float $self {*}[pd::add_selectors [list $f]] } pd::guiclass slider2 tclpd-0.3.0/examples/list_change.tcl0000644000175000017500000000117011674625147017670 0ustar zmoelnigzmoelnigpackage require Tclpd 0.3.0 package require TclpdLib 0.20 proc+ list_change::constructor {self args} { # add second inlet (first created by default) pd::add_inlet $self list # add outlet pd::add_outlet $self list set @curlist {} } proc+ list_change::0_list {self args} { # HOT inlet if {$args ne $@curlist} { set @curlist $args pd::outlet $self 0 list $@curlist } } proc+ list_change::0_bang {self} { if {$@curlist eq {}} return pd::outlet $self 0 list $@curlist } proc+ list_change::1_list {self args} { # COLD inlet set @curlist $args } pd::class list_change tclpd-0.3.0/examples/dynroute-help.pd0000644000175000017500000000172011674625147020031 0ustar zmoelnigzmoelnig#N canvas 342 108 616 430 10; #X obj 93 268 dynroute 4; #X msg 41 147 apple red \, banana yellow \, pear green \, apple yellow \, strawberry red; #X obj 41 194 list prepend; #X msg 200 224 clear \, add apple 0 \, add banana 1 \, add pear 2; #X msg 206 258 remove pear 2 \, add pear 0 \, add strawberry 2; #X text 39 32 Dynamically route lists based on first element \, according to the mapping specified on right inlet. Creation argument (float) specifies how many outlet to have (including last outlet \, which is used for sending unmatching items); #X text 44 120 Test it with some data:; #X obj 93 379 print out1; #X obj 115 352 print out2; #X obj 137 325 print out3; #X obj 160 298 print other; #X text 256 293 <-- non-matching stuff is sent here; #X text 196 192 Change the mapping:; #X connect 0 0 7 0; #X connect 0 1 8 0; #X connect 0 2 9 0; #X connect 0 3 10 0; #X connect 1 0 2 0; #X connect 2 0 0 0; #X connect 3 0 0 1; #X connect 4 0 0 1; tclpd-0.3.0/examples/bitmap-help.pd0000644000175000017500000000502711674625147017440 0ustar zmoelnigzmoelnig#N canvas 625 330 742 518 10; #X obj 63 244 bitmap -cellsize 15 -uwidth 8 -uheight 8; #bitmap setdata 1 0 0 0 0 0 0 1 1 0 0 0 0 0 1 0 1 0 0 0 0 1 0 1 1 0 0 0 1 0 1 0 1 0 0 1 0 1 0 1 1 0 1 0 1 0 1 0 1 1 0 1 0 1 0 1 1 0 1 0 1 0 1 0; #X obj 87 410 print out; #X msg 39 117 getrow \$1; #X obj 42 245 vradio 15 1 0 8 empty empty empty 0 -8 0 10 -228856 -162280 -1 0; #X obj 42 410 s \$0r; #X obj 39 89 r \$0r; #X text 36 19 [bitmap] - a two dimensional array of bits (toggles) ; #X text 38 49 creation arguments -cellsize <#> -uwidth <#> -uheight <#>; #X msg 111 117 getcol \$1; #X obj 111 89 r \$0c; #X obj 63 213 r \$0b; #X obj 39 157 s \$0b; #X obj 63 372 hradio 15 1 0 8 empty empty empty 0 -8 0 10 -228856 -162280 -1 0; #X obj 157 410 s \$0c; #X obj 227 157 s \$0b; #X msg 227 117 getcell 0 1; #X msg 317 117 getcell 1 1; #X text 226 88 getcell ; #X obj 247 243 bitmap -cellsize 4 -uwidth 16 -uheight 16; #bitmap setdata 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 1 1 1 1 0 1 1 1 1 1 0 0 1 0 1 0 1 0 0 1 0 1 0 0 0 1 0 0 1 1 1 0 1 0 0 1 0 1 0 0 0 1 0 0 0 0 0 0 1 1 1 1 0 1 0 0 0 1 0 0 1 1 1 1 0 0 0 0 0 1 1 1 1 1 0 0 1 0 0 1 0 1 1 1 1 0 0 0 0 0 0 0 1 0 0 1 0 1 0 0 1 0 1 1 1 1 0 0 1 1 1 1 0 1 0 0 1 0 1 0 0 1 0 0 0 0 0 0 0 1 1 1 1 0 1 0 0 1 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 1 0 0 1 0 0 0 1 0 1 1 1 1 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 1 0 1 1 1 0 0 1 0 0 0 1 0 1 0 0 1 0 1 0 1 0 0 1 1 1 1 1 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0; #X msg 447 200 setcell \$1 \$2 \$3; #N canvas 4 117 450 300 randomdata 0; #X obj 220 136 random 2; #X obj 62 89 t b b b; #X obj 62 35 inlet; #X obj 62 187 pack f f f; #X obj 62 222 outlet; #X obj 62 62 metro 10; #X obj 62 136 random 4; #X obj 141 136 random 4; #X connect 0 0 3 2; #X connect 1 0 6 0; #X connect 1 1 7 0; #X connect 1 2 0 0; #X connect 2 0 5 0; #X connect 3 0 4 0; #X connect 5 0 1 0; #X connect 6 0 3 0; #X connect 7 0 3 1; #X restore 447 175 pd randomdata; #X obj 447 151 tgl 15 0 empty empty empty 17 7 0 10 -262144 -1 -1 1 1; #X obj 447 331 bitmap -cellsize 16 -uwidth 4 -uheight 4; #bitmap setdata 1 0 0 0 1 0 0 1 1 0 1 1 1 1 1 0; #X msg 465 231 setcol 1 0 0 0 0 \, setcol 2 0 0 0 0; #X msg 481 292 setrow \$1 \$2 \$2 \$3 \$3; #X msg 481 265 0 1 0 \, 1 1 0 \, 2 0 1 \, 3 0 1; #X connect 0 0 1 0; #X connect 2 0 11 0; #X connect 3 0 4 0; #X connect 5 0 2 0; #X connect 8 0 11 0; #X connect 9 0 8 0; #X connect 10 0 0 0; #X connect 12 0 13 0; #X connect 15 0 14 0; #X connect 16 0 14 0; #X connect 19 0 22 0; #X connect 20 0 19 0; #X connect 21 0 20 0; #X connect 23 0 22 0; #X connect 24 0 22 0; #X connect 25 0 24 0; tclpd-0.3.0/examples/bitmap-madness.pd0000644000175000017500000000465011674625147020143 0ustar zmoelnigzmoelnig#N canvas 5 140 311 321 10; #N canvas 322 138 514 645 in 1; #X obj 20 462 outlet; #X obj 51 8 tgl 15 0 empty empty empty 17 7 0 10 -262144 -1 -1 0 1 ; #X obj 44 60 bng 15 250 50 0 empty empty empty 17 7 0 10 -262144 -1 -1; #N canvas 3 94 332 662 for_X_Y 0; #X obj 61 60 inlet; #X obj 71 223 until; #X msg 125 177 0; #X obj 72 261 f; #X obj 106 260 + 1; #X obj 68 141 t b b; #X obj 78 418 until; #X msg 132 372 0; #X obj 79 456 f; #X obj 113 455 + 1; #X obj 75 336 t b b; #X obj 73 297 t b f; #X obj 82 502 pack f f; #X msg 77 528 \$2 \$1; #X obj 74 589 outlet; #X msg 72 177 32; #X msg 79 372 32; #X connect 0 0 5 0; #X connect 1 0 3 0; #X connect 2 0 3 1; #X connect 3 0 4 0; #X connect 3 0 11 0; #X connect 4 0 3 1; #X connect 5 0 15 0; #X connect 5 1 2 0; #X connect 6 0 8 0; #X connect 7 0 8 1; #X connect 8 0 9 0; #X connect 8 0 12 0; #X connect 9 0 8 1; #X connect 10 0 16 0; #X connect 10 1 7 0; #X connect 11 0 10 0; #X connect 11 1 12 1; #X connect 12 0 13 0; #X connect 13 0 14 0; #X connect 15 0 1 0; #X connect 16 0 6 0; #X restore 50 125 pd for_X_Y; #X obj 78 270 sin; #X obj 78 227 / 64; #X obj 51 154 unpack f f; #X obj 107 190 t f f; #X obj 21 422 pack f f f; #X msg 21 442 setcell \$1 \$2 \$3; #X obj 76 297 + 0.5; #X obj 151 277 sin; #X obj 149 255 / 16; #X obj 79 321 +; #X obj 49 189 t f f f; #X obj 79 249 +; #X obj 228 155 f; #X obj 263 154 + 0.1; #X obj 49 94 t b b; #X obj 78 360 wrap; #X obj 77 401 i; #X obj 148 230 expr sqrt(pow(sin($f3)*32-$f1 \, 2)+pow(cos($f3)*34-$f2 \, 2)); #X obj 79 380 * 1.8; #X obj 79 341 * 1.2; #X obj 151 299 + 0.6; #X obj 52 35 metro 40; #X connect 1 0 25 0; #X connect 2 0 18 0; #X connect 3 0 6 0; #X connect 4 0 10 0; #X connect 5 0 15 0; #X connect 6 0 14 0; #X connect 6 1 7 0; #X connect 7 0 8 1; #X connect 7 1 21 1; #X connect 8 0 9 0; #X connect 9 0 0 0; #X connect 10 0 13 0; #X connect 11 0 24 0; #X connect 12 0 11 0; #X connect 13 0 23 0; #X connect 14 0 8 0; #X connect 14 1 5 0; #X connect 14 2 21 0; #X connect 15 0 4 0; #X connect 16 0 17 0; #X connect 16 0 21 2; #X connect 17 0 16 1; #X connect 18 0 3 0; #X connect 18 1 16 0; #X connect 19 0 22 0; #X connect 20 0 8 2; #X connect 21 0 12 0; #X connect 22 0 20 0; #X connect 23 0 19 0; #X connect 24 0 13 1; #X connect 25 0 18 0; #X restore 17 10 pd in; #X obj 17 34 bitmap -uwidth 32 -uheight 32 -cellsize 8 -label empty -labelpos top -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X connect 0 0 1 0; tclpd-0.3.0/examples/colorpicker.tcl0000644000175000017500000002351111674625147017727 0ustar zmoelnigzmoelnigif {[info exists ::colorpicker::version]} {return} namespace eval ::colorpicker { namespace export colorpicker # ========================================= # colorpicker set version 0.1 # (C) 2009 - Federico Ferri # mescalinum (at) gmail (dot) com # # Released under GPL-3 license: # http://www.gnu.org/licenses/gpl-3.0.html # ========================================= package provide colorpicker $version variable presets { ffffff dfdfdf bbbbbb ffc7c6 ffe3c6 feffc6 c6ffc7 c6feff c7c6ff e3c6ff 9f9f9f 7c7c7c 606060 ff0400 ff8300 faff00 00ff04 00faff 0400ff 9c00ff 404040 202020 000000 551312 553512 535512 0f4710 0e4345 131255 2f004d } proc colorpicker {w mode args} { variable {} set modes {switches hsv} if {[lsearch -exact $modes $mode] == -1} { error "bad mode: $mode. must be one of: $modes." } set ($w:mode) $mode set ($w:color) {#000000} set ($w:command) {} set ($w:textvar) {} frame $w init_$mode $w rename $w ::colorpicker::_$w interp alias {} $w {} ::colorpicker::dispatch $w if {$args ne {}} {uplevel 1 ::colorpicker::config $w $args} return $w } proc dispatch {w cmd args} { variable {} switch -glob -- $cmd { get {set ($w:color)} set {uplevel 1 [linsert $args 0 ::colorpicker::set_color_ext $w]} con* {uplevel 1 [linsert $args 0 ::colorpicker::config $w]} default {uplevel 1 [linsert $args 0 ::colorpicker::_$w $cmd]} } } proc config {w args} { variable {} set options {} set flag 0 foreach {key value} $args { switch -glob -- $key { -com* { set ($w:command) $value set flag 1 } -textvar* { set ($w:textvar) $value set flag 1 } default { lappend options $key $value } } } if {!$flag || $options ne {}} { uplevel 1 [linsert $options 0 ::scrolledframe::_$w config] } } proc set_color_ext {w c} { # called by the widget public method variable {} set c [string tolower $c] if {![regexp {^#[0-9a-f]{6,6}$} $c]} { error "Invalid color: $c. Specify a color in the format #HHHHHH" } switch -exact -- $($w:mode) { switches { set_color $w $c } hsv { set r [expr 0x[string range $c 1 2]] set g [expr 0x[string range $c 3 4]] set b [expr 0x[string range $c 5 6]] set hsv [rgbToHsv $r $g $b] hsv_set $w h [lindex $hsv 0] hsv_set $w s [lindex $hsv 1] hsv_set $w v [lindex $hsv 2] set_color $w $c } } } proc set_color {w c} { # called internally in reaction to events variable {} set c [string tolower $c] set ($w:color) $c if {$($w:command) ne {}} { set cmd $($w:command) lappend cmd $c uplevel #0 $cmd } if {$($w:textvar) ne {}} { uplevel #0 [list set $($w:textvar) $c] } switch -exact -- $($w:mode) { switches { variable presets set q 0 for {set row 0} {$row < 3} {incr row} { for {set col 0} {$col < 10} {incr col} { set b [expr {$c eq "#[lindex $presets $q]"}] ${w}.r${row}c${col} configure \ -relief [lindex {raised sunken} $b] incr q } } } hsv { } } } proc mkColor {rgb} { set r [lindex $rgb 0]; set g [lindex $rgb 1]; set b [lindex $rgb 2] if {$r < 0} {set r 0} elseif {$r > 255} {set r 255} if {$g < 0} {set g 0} elseif {$g > 255} {set g 255} if {$b < 0} {set b 0} elseif {$b > 255} {set b 255} return #[format {%2.2x%2.2x%2.2x} $r $g $b] } proc rgbToHsv {r g b} { set sorted [lsort -real [list $r $g $b]] set temp [lindex $sorted 0] set v [lindex $sorted 2] set value $v set bottom [expr {$v-$temp}] if {$bottom == 0} { set hue 0 set saturation 0 set value $v } else { if {$v == $r} { set top [expr {$g-$b}] if {$g >= $b} { set angle 0 } else { set angle 360 } } elseif {$v == $g} { set top [expr {$b-$r}] set angle 120 } elseif {$v == $b} { set top [expr {$r-$g}] set angle 240 } set hue [expr {round(60*(double($top)/$bottom)+$angle)}] } if {$v == 0} { set saturation 0 } else { set saturation [expr {round(255-255*(double($temp)/$v))}] } return [list $hue $saturation $value] } proc hsvToRgb {h s v} { set hi [expr {int(double($h)/60)%6}] set f [expr {double($h)/60-$hi}] set s [expr {double($s)/255}] set v [expr {double($v)/255}] set p [expr {double($v)*(1-$s)}] set q [expr {double($v)*(1-$f*$s)}] set t [expr {double($v)*(1-(1-$f)*$s)}] switch -- $hi { 0 {set r $v; set g $t; set b $p} 1 {set r $q; set g $v; set b $p} 2 {set r $p; set g $v; set b $t} 3 {set r $p; set g $q; set b $v} 4 {set r $t; set g $p; set b $v} 5 {set r $v; set g $p; set b $q} default {error "[lindex [info level 0] 0]: bad H value"} } set r [expr {round($r*255)}] set g [expr {round($g*255)}] set b [expr {round($b*255)}] return [list $r $g $b] } proc init_switches {w} { variable {} variable presets set q 0 for {set row 0} {$row < 3} {incr row} { for {set col 0} {$col < 10} {incr col} { set c "#[lindex $presets $q]" set b [expr {$($w:color) eq $c}] grid [frame ${w}.r${row}c${col} -width 18 -height 16 \ -borderwidth 1 -relief [lindex {raised sunken} $b] \ -background $c -highlightthickness 0] \ -row $row -column $col bind ${w}.r${row}c${col} \ "[namespace current]::set_color $w $c" incr q } } } proc init_hsv {w} { variable colorhsv set colorhsv($w:h) 0 set colorhsv($w:s) 255 set colorhsv($w:v) 255 grid [canvas ${w}.hue -width 130 -height 15 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 0 grid [canvas ${w}.sat -width 130 -height 14 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 1 grid [canvas ${w}.val -width 130 -height 14 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 2 grid [canvas ${w}.test -width 46 -height 46 -borderwidth 1 \ -relief sunken -highlightthickness 0 -background red] \ -column 1 -row 0 -rowspan 3 variable mh variable ms variable mv set mh($w) 0; set ms($w) 0; set mv($w) 0; set sh "[namespace current]::hsv_set $w h \[expr {%x*360.0/130.0}\]" set ss "[namespace current]::hsv_set $w s \[expr {%x*255.0/130.0}\]" set sv "[namespace current]::hsv_set $w v \[expr {%x*255.0/130.0}\]" bind ${w}.hue "set [namespace current]::mh($w) 1; $sh" bind ${w}.sat "set [namespace current]::ms($w) 1; $ss" bind ${w}.val "set [namespace current]::mv($w) 1; $sv" bind ${w}.hue "set [namespace current]::mh($w) 0" bind ${w}.sat "set [namespace current]::ms($w) 0" bind ${w}.val "set [namespace current]::mv($w) 0" bind ${w}.hue "if {\$[namespace current]::mh($w)} {$sh}" bind ${w}.sat "if {\$[namespace current]::ms($w)} {$ss}" bind ${w}.val "if {\$[namespace current]::mv($w)} {$sv}" for {set x 0} {$x < 130} {incr x 3} { set c [mkColor [hsvToRgb [expr {$x*360.0/130.0}] 255 255]] ${w}.hue create rectangle $x 0 [expr {4+$x}] 16 -fill $c -outline {} } hsv_regen $w $colorhsv($w:h) } proc hsv_regen {w hue} { ${w}.sat delete all ${w}.val delete all for {set x 0} {$x < 130} {incr x 3} { set x1 [expr {$x*255.0/130.0}] set c1 [mkColor [hsvToRgb $hue $x1 255]] set c2 [mkColor [hsvToRgb $hue 255 $x1]] ${w}.sat create rectangle $x 0 [expr {4+$x}] 16 \ -fill $c1 -outline {} ${w}.val create rectangle $x 0 [expr {4+$x}] 16 \ -fill $c2 -outline {} } } proc hsv_set {w what val} { variable colorhsv if {$what ne {h} && $what ne {s} && $what ne {v}} {return} set colorhsv($w:$what) $val if {$colorhsv($w:$what) < 0.0} {set colorhsv($w:$what) 0} if {$what eq {h}} { if {$colorhsv($w:$what) >= 360.0} {set colorhsv($w:$what) 0} hsv_regen $w $colorhsv($w:$what) } else { if {$colorhsv($w:$what) > 255.0} {set colorhsv($w:$what) 255} } set c [mkColor [hsvToRgb \ $colorhsv($w:h) $colorhsv($w:s) $colorhsv($w:v)]] ${w}.test configure -background $c set_color $w $c } } tclpd-0.3.0/examples/properties.tcl0000644000175000017500000003531611674625147017615 0ustar zmoelnigzmoelnigif {[catch {package require colorpicker}]} { source [file join [file dirname [info script]] colorpicker.tcl] package require colorpicker } namespace import ::colorpicker::colorpicker proc propertieswindow {gfxstub_id {options {}} {title {}}} { set win $gfxstub_id set ::id($win.p) $gfxstub_id set ::optkeys($win.p) [list] set options [string map {@ $} $options] foreach {k v} $options { if {$v eq {empty}} {set v {}} #set v [string map {\\$ $} $v] set ::config($win.p:$k) $v lappend ::optkeys($win.p) $k } toplevel $win pack [propertiespanel $win.p] wm resizable $win 0 0 wm title $win $title set win } proc has_key {w key} { expr {[lsearch -exact $::optkeys($w) $key] != -1} } proc propertiespanel {w} { set pad [propertiespanel_padding $w] incr pad $pad frame $w -borderwidth 0 -relief raised -padx $pad -pady $pad set subpanels {dimensions output behavior connective label colors} foreach subpanel $subpanels { set x [propertiespanel_$subpanel $w] if {$x ne {}} {grid $x -sticky ew -in $w} } set x [propertiespanel_buttons $w] grid $x -in $w grid columnconfigure . 0 -weight 1 set w } proc propertiespanel_padding {w} { return 3 } proc propertiespanel_dimensions {w} { set x ${w}.dimensions set pad [propertiespanel_padding $w] labelframe $x -text "Dimensions:" -borderwidth 1 -relief raised set count 0 set row 0; set col 0 if {[has_key $w -width]} { grid [label ${x}.wl -text "Width (px):" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.w -textvar ::config($w:-width) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -height]} { grid [label ${x}.hl -text "Height (px):" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.h -textvar ::config($w:-height) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -uwidth]} { grid [label ${x}.uwl -text "Width (cells):" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.uw -textvar ::config($w:-uwidth) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -uheight]} { grid [label ${x}.uhl -text "Height (cells):" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.uh -textvar ::config($w:-uheight) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -cellsize]} { grid [label ${x}.csl -text "Cell size (pixels):" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.cs -textvar ::config($w:-cellsize) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -cellwidth]} { grid [label ${x}.uwl -text "Cell width:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.uw -textvar ::config($w:-cellwidth) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -cellheight]} { grid [label ${x}.uhl -text "Cell height:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.uh -textvar ::config($w:-cellheight) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {$count == 0} {return {}} set x } proc propertiespanel_output {w} { set x ${w}.output set pad [propertiespanel_padding $w] labelframe $x -text "Output range:" -borderwidth 1 -relief raised set count 0 set row 0; set col 0 if {[has_key $w -rangebottom]} { grid [label ${x}.rbl -text "Bottom:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rb -textvar ::config($w:-rangebottom) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -rangetop]} { grid [label ${x}.rtl -text "Top:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rt -textvar ::config($w:-rangetop) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -rangeleft]} { grid [label ${x}.rll -text "Left:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rl -textvar ::config($w:-rangeleft) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -rangeright]} { grid [label ${x}.rrl -text "Right:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rr -textvar ::config($w:-rangeright) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -rangemin]} { grid [label ${x}.rml -text "Min:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rm -textvar ::config($w:-rangemin) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } if {[has_key $w -rangemax]} { grid [label ${x}.rMl -text "Max:" -anchor e] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col grid [entry ${x}.rM -textvar ::config($w:-rangemax) -width 5] \ -row $row -column $col -sticky ew -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {[has_key $w -logarithmic]} { incr col grid [checkbutton ${x}.rL -variable ::config($w:-logarithmic) \ -text "Logarithmic"] \ -row $row -column $col -columnspan 3 -sticky w -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {$count == 0} {return {}} set x } proc propertiespanel_behavior {w} { set x ${w}.behavior set pad [propertiespanel_padding $w] labelframe $x -text "Widget behavior:" -borderwidth 1 -relief raised set count 0 set row 0; set col 0 if {[has_key $w -jumponclick]} { grid [checkbutton ${x}.joc -variable ::config($w:-jumponclick) \ -text "Jump on click"] \ -row $row -column $col -sticky w -padx $pad -pady $pad incr col incr count } if {[has_key $w -init]} { grid [checkbutton ${x}.init -variable ::config($w:-init) \ -text "Output init value"] \ -row $row -column $col -sticky w -padx $pad -pady $pad incr col incr count } incr row; set col 0 if {$count == 0} {return {}} set x } proc propertiespanel_label {w} { set x ${w}.label set pad [propertiespanel_padding $w] labelframe $x -text "Label:" -borderwidth 1 -relief raised set count 0 set row 0 if {[has_key $w -label]} { grid [label ${x}.ll -text "Text:" -anchor e] \ -row $row -column 0 -sticky ew -padx $pad -pady $pad grid [entry ${x}.l -textvar ::config($w:-label)] \ -row $row -column 1 -sticky ew -padx $pad -pady $pad incr row incr count } if {[has_key $w -labelpos]} { grid [label ${x}.lpl -text "Position:" -anchor e] \ -row $row -column 0 -sticky ew -padx $pad -pady $pad frame ${x}.f if {![info exists ::config($w:-labelpos)]} { set ::config($w:-labelpos) top } grid [radiobutton ${x}.f.lp1 -variable ::config($w:-labelpos) \ -value top -text Top] \ -row 1 -column 1 -sticky w -padx $pad -pady $pad -in ${x}.f grid [radiobutton ${x}.f.lp2 -variable ::config($w:-labelpos) \ -value bottom -text Bottom] \ -row 1 -column 2 -sticky w -padx $pad -pady $pad -in ${x}.f grid [radiobutton ${x}.f.lp3 -variable ::config($w:-labelpos) \ -value left -text Left] \ -row 2 -column 1 -sticky w -padx $pad -pady $pad -in ${x}.f grid [radiobutton ${x}.f.lp4 -variable ::config($w:-labelpos) \ -value right -text Right] \ -row 2 -column 2 -sticky w -padx $pad -pady $pad -in ${x}.f grid ${x}.f -sticky w -row $row -column 1 incr row incr count } if {$count == 0} {return {}} set x } proc propertiespanel_connective {w} { set x ${w}.connective set pad [propertiespanel_padding $w] labelframe $x -text "Messages:" -borderwidth 1 -relief raised set count 0 set row 0 if {[has_key $w -sendsymbol]} { grid [label ${x}.ssl -text "Send symbol:" -anchor e] \ -row $row -column 0 -sticky ew -padx $pad -pady $pad grid [entry ${x}.ss -textvar ::config($w:-sendsymbol) -width 15] \ -row $row -column 1 -sticky ew -padx $pad -pady $pad incr row incr count } if {[has_key $w -receivesymbol]} { grid [label ${x}.rsl -text "Receive symbol:" -anchor e] \ -row $row -column 0 -sticky ew -padx $pad -pady $pad grid [entry ${x}.rs -textvar ::config($w:-receivesymbol) -width 15] \ -row $row -column 1 -sticky ew -padx $pad -pady $pad incr row incr count } if {$count == 0} {return {}} set x } proc propertiespanel_colors {w} { set colors {-bgcolor Background -fgcolor Foreground -lblcolor Label} set x ${w}.colors set pad [propertiespanel_padding $w] labelframe $x -text "Colors:" -borderwidth 1 -relief raised set count 0 set row 0 foreach {optkey color} $colors { if {![has_key $w $optkey]} {continue} grid [label ${x}.l$color -text "${color}:" -anchor e] \ -row $row -column 0 -sticky ew -padx $pad -pady $pad grid [entry ${x}.t$color -textvar ::config($w:$optkey) -width 8] \ -row $row -column 1 -sticky ew -padx $pad -pady $pad grid [frame ${x}.p$color -width 20 -height 20 \ -borderwidth 1 -relief sunken] \ -row $row -column 2 -sticky ew -padx $pad -pady $pad grid [button ${x}.b$color -text "Pick..." -overrelief {} \ -command {} \ ] -row $row -column 3 -sticky ew -padx $pad -pady $pad bind ${x}.b$color {break} bind ${x}.b$color {break} bind ${x}.b$color [list \ propertiespanel_colors_pick \ $w $x $colors ${x}.b$color ${x}.p$color ${x}.t$color] trace add variable ::config($w:$optkey) write [list \ propertiespanel_colors_set_wrap $w $x ${x}.p$color $optkey] incr row incr count } if {![info exists ::cpt($w)]} {set ::cpt($w) switches} foreach {optkey color} $colors { if {![has_key $w $optkey]} {continue} # trigger the variable trace: if {[info exists ::config($w:$optkey)]} { set ::config($w:$optkey) $::config($w:$optkey) } } if {$count == 0} {return {}} frame ${x}.f grid [radiobutton ${x}.f.cpt1 -variable ::cpt($w) -justify right \ -value switches -text Switches] \ -row 0 -column 0 -sticky ew -padx $pad -pady $pad grid [radiobutton ${x}.f.cpt2 -variable ::cpt($w) -justify right \ -value hsv -text HSV] \ -row 1 -column 0 -sticky ew -padx $pad -pady $pad grid ${x}.f -row $row -column 0 grid [colorpicker ${x}.cp2 hsv] \ -row $row -column 1 -columnspan 3 -sticky ew -padx $pad -pady $pad grid [colorpicker ${x}.cp1 switches -command [list ${x}.cp2 set]] \ -row $row -column 1 -columnspan 3 -sticky ew -padx $pad -pady $pad raise ${x}.cp1 trace add variable ::cpt($w) write \ [list propertiespanel_colors_switchpicker $w $x $row] set x } proc propertiespanel_colors_set_wrap {w x wp optkey config_ idx op} { propertiespanel_colors_set $w $x $wp {} -1 $::config($w:$optkey) } proc propertiespanel_colors_switchpicker {w x row cpt idx op} { raise ${x}.cp[expr {1+($::cpt($w) eq {hsv})}] } proc propertiespanel_colors_pick {w x colors wb wp wt} { foreach {k color} $colors { ${x}.b$color configure -relief raised -state normal } set r [$wb cget -relief] if {$r eq {sunken}} { $wb configure -relief raised ${x}.cp1 configure -command {} ${x}.cp2 configure -command {} } else { $wb configure -relief sunken ${x}.cp1 configure -command \ [list propertiespanel_colors_set $w $x $wp $wt 1] ${x}.cp2 configure -command \ [list propertiespanel_colors_set $w $x $wp $wt 2] } } proc propertiespanel_colors_set {w x wp wt from color} { if {$wt ne {}} {$wt delete 0 end ; $wt insert 0 $color} $wp configure -background $color if {$::cpt($w) eq {switches} && $from == 1} { ${x}.cp2 set $color } } proc propertiespanel_buttons {w} { set x ${w}.buttons set pad [propertiespanel_padding $w] frame $x -padx $pad -pady $pad set col 0 foreach action {Cancel Apply Ok} { grid [button ${x}.btn$action \ -command [list propertiespanel_buttons_action $w $action] \ -text $action] \ -row 0 -column $col -padx $pad -pady $pad incr col } set x } proc propertiespanel_buttons_action {w action} { switch -- $action { Cancel { propertiespanel_close $w } Apply { propertiespanel_apply $w } Ok { propertiespanel_apply $w propertiespanel_close $w } } } proc propertiespanel_apply {w} { set newconf [list] foreach key $::optkeys($w) { set v $::config($w:$key) if {$v eq {}} {set v {empty}} lappend newconf $key $v } #set newconf [string map {$ \\$} $newconf] set newconf [string map {$ @} $newconf] pdsend "$::id($w) config2 $newconf" } proc propertiespanel_close {w} { pdsend "$::id($w) cancel" } tclpd-0.3.0/examples/dynreceive.tcl0000644000175000017500000000220711674625147017547 0ustar zmoelnigzmoelnigpackage require Tclpd 0.3.0 package require TclpdLib 0.20 proc+ dynreceive::constructor {self args} { set @sym {} if {[pd::args] > 0} { set @sym [pd::arg 0 symbol] pd_bind $self $@sym } pd::add_outlet $self } proc+ dynreceive::destructor {self} { # don't forget to call pd_unbind, or sending things to a symbol # bound to dead object will crash pd! if {$@sym ne {}} { pd_unbind $self $@sym } } proc+ dynreceive::0_set {self args} { # send [set empty( to clear the receive symbol set s [pd::arg 0 symbol] if {$@sym eq {}} { pd_unbind $self $@sym } if {$s eq {empty}} { set @sym {} } else { set @sym $s pd_bind $self $@sym } } proc+ dynreceive::0_bang {self} { pd::outlet $self 0 bang } proc+ dynreceive::0_float {self args} { pd::outlet $self 0 float [pd::arg 0 float] } proc+ dynreceive::0_symbol {self args} { pd::outlet $self 0 symbol [pd::arg 0 symbol] } proc+ dynreceive::0_anything {self args} { set sel [pd::arg 0 symbol] set argz [lrange $args 1 end] pd::outlet $self 0 $sel $argz } pd::class dynreceive tclpd-0.3.0/examples/dynroute.tcl0000644000175000017500000000271411674625147017266 0ustar zmoelnigzmoelnigpackage require Tclpd 0.3.0 package require TclpdLib 0.20 # dynroute: dynamically route messages based on first element # non-matching arguments are sent to last inlet # constructor: specify the number of outlets (default: 1) # send commands to the right inlet # available commands: # add route selector to output number # remove remove previously created routing # clear proc+ dynroute::constructor {self args} { pd::add_inlet $self list set @num_outlets [pd::arg 0 int] if {$@num_outlets < 0} {set @num_outlets 2} for {set i 0} {$i < $@num_outlets} {incr i} { pd::add_outlet $self list } set @routing {} } proc+ dynroute::0_list {self args} { set sel [pd::arg 0 any] set out [expr {$@num_outlets-1}] catch {set out [dict get $@routing $sel]} pd::outlet $self $out list $args } proc+ dynroute::1_add {self args} { set sel [pd::arg 0 any] set out [pd::arg 1 int] if {$out < 0 || $out >= $@num_outlets} { pd::post "error: add: outlet number out of range" return } dict set @routing $sel $out } proc+ dynroute::1_remove {self args} { set sel [pd::arg 0 any] set out [pd::arg 1 int] if {$out < 0 || $out >= $@num_outlets} { pd::post "error: add: outlet number out of range" return } catch {dict unset @routing $sel $out} } proc+ dynroute::1_clear {self} { set @routing {} } pd::class dynroute tclpd-0.3.0/examples/slider2-help.pd0000644000175000017500000000450011674625147017523 0ustar zmoelnigzmoelnig#N canvas 79 235 731 505 10; #X obj 343 150 slider2 -width 15 -height 130 -headsz 3 -rangebottom 0 -rangetop 127 -init 0 -initvalue 94 -jumponclick 0 -label norm -labelpos top -orient vertical -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X obj 401 150 slider2 -width 15 -height 130 -headsz 3 -rangebottom 127 -rangetop 0 -init 0 -initvalue 63 -jumponclick 0 -label rev -labelpos top -orient vertical -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X obj 522 154 slider2 -width 130 -height 15 -headsz 3 -rangebottom 0 -rangetop 127 -init 0 -initvalue 95 -jumponclick 0 -label norm -labelpos top -orient horizontal -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X obj 522 213 slider2 -width 130 -height 15 -headsz 3 -rangebottom 127 -rangetop 0 -init 0 -initvalue 70 -jumponclick 0 -label rev -labelpos top -orient horizontal -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X floatatom 343 295 5 0 0 0 - - -; #X floatatom 401 295 5 0 0 0 - - -; #X floatatom 522 177 5 0 0 0 - - -; #X floatatom 522 236 5 0 0 0 - - -; #X text 324 109 -orient vertical; #X text 523 111 -orient horizontal; #X text 321 61 Output range test:; #X obj 46 174 slider2 -width 15 -height 130 -headsz 3 -rangebottom 0 -rangetop 127 -init 0 -initvalue 10 -jumponclick 0 -label empty -labelpos top -orient vertical -sendsymbol empty -receivesymbol empty -fgcolor #000000 -bgcolor #ffffff -lblcolor #000000; #X msg 46 143 config -orient vertical; #X msg 46 113 config -orient horizontal; #X floatatom 46 321 5 0 0 0 - - -; #X obj 159 358 slider2 -width 130 -height 15 -headsz 3 -rangebottom 0 -rangetop 255 -init 0 -initvalue 202.795 -jumponclick 0 -label empty -labelpos top -orient horizontal -sendsymbol \$0.sl-out -receivesymbol \$0.sl-in -fgcolor #000000 -bgcolor #20ca34 -lblcolor #000000; #X obj 45 358 r \$0.sl-out; #X obj 45 466 s \$0.sl-in; #X msg 45 439 config -bgcolor \$1; #X obj 45 412 makefilename #%6.6x; #X obj 45 385 expr (0x20 << 16) | ($f1 << 8) | (0xff - $f1); #X connect 0 0 4 0; #X connect 1 0 5 0; #X connect 2 0 6 0; #X connect 3 0 7 0; #X connect 11 0 14 0; #X connect 12 0 11 0; #X connect 13 0 11 0; #X connect 16 0 20 0; #X connect 18 0 17 0; #X connect 19 0 18 0; #X connect 20 0 19 0; tclpd-0.3.0/TODO.txt0000644000175000017500000000040311674625147014372 0ustar zmoelnigzmoelnigTODO-list for tclpd (most important things first) ================================================= - bitmap's help make pd crash only when opened via context menu Help -> investigate - slider2.tcl is broken - add (or check) GOP - signal externals? (really?) tclpd-0.3.0/tclpd.c0000644000175000017500000000404511674625147014344 0ustar zmoelnigzmoelnig#include "tclpd.h" #include #include #include #include Tcl_Interp *tclpd_interp = NULL; void tclpd_setup(void) { if(tclpd_interp) { return; } /* verbose(-1) post to the pd window at level 3 */ verbose(-1, "tclpd loader v" TCLPD_VERSION); proxyinlet_setup(); tclpd_interp = Tcl_CreateInterp(); Tcl_Init(tclpd_interp); Tclpd_SafeInit(tclpd_interp); Tcl_Eval(tclpd_interp, "package provide Tclpd " TCLPD_VERSION); t_class *foo_class = class_new(gensym("tclpd_init"), 0, 0, 0, 0, 0); char buf[PATH_MAX]; snprintf(buf, PATH_MAX, "%s/tclpd.tcl", foo_class->c_externdir->s_name); verbose(-1, "tclpd: trying to load %s...", buf); int result = Tcl_EvalFile(tclpd_interp, buf); switch(result) { case TCL_ERROR: error("tclpd: error loading %s", buf); break; case TCL_RETURN: error("tclpd: warning: %s exited with code return", buf); break; case TCL_BREAK: case TCL_CONTINUE: error("tclpd: warning: %s exited with code break/continue", buf); break; } verbose(-1, "tclpd: loaded %s", buf); sys_register_loader(tclpd_do_load_lib); } void tclpd_interp_error(t_tcl *x, int result) { error("tclpd error: %s", Tcl_GetStringResult(tclpd_interp)); logpost(x, 3, "------------------- Tcl error: -------------------"); // Tcl_GetReturnOptions and Tcl_DictObjGet only available in Tcl >= 8.5 #if ((TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 5) || (TCL_MAJOR_VERSION > 8)) Tcl_Obj *dict = Tcl_GetReturnOptions(tclpd_interp, result); Tcl_Obj *errorInfo = NULL; Tcl_Obj *errorInfoK = Tcl_NewStringObj("-errorinfo", -1); Tcl_IncrRefCount(errorInfoK); Tcl_DictObjGet(tclpd_interp, dict, errorInfoK, &errorInfo); Tcl_DecrRefCount(errorInfoK); logpost(x, 3, "%s\n", Tcl_GetStringFromObj(errorInfo, 0)); #else logpost(x, 3, "Backtrace not available in Tcl < 8.5. Please upgrade Tcl."); #endif logpost(x, 3, "--------------------------------------------------"); } tclpd-0.3.0/tcl_class.c0000644000175000017500000003212012033756135015170 0ustar zmoelnigzmoelnig /* in order to get strdup(), this needs to be defined */ #define _POSIX_C_SOURCE 200809L #include "tclpd.h" #include #include #include #include "hashtable.h" static hash_table_t *class_table = NULL; static hash_table_t *object_table = NULL; static hash_table_t *source_table = NULL; void class_table_add(const char *n, t_class *c) { hashtable_add(class_table, n, (void *)c); } void class_table_remove(const char *n) { hashtable_remove(class_table, n); } t_class * class_table_get(const char *n) { return (t_class *)hashtable_get(class_table, n); } void object_table_add(const char *n, t_tcl *o) { hashtable_add(object_table, n, (void *)o); } void object_table_remove(const char *n) { hashtable_remove(object_table, n); } t_tcl * object_table_get(const char *n) { return (t_tcl *)hashtable_get(object_table, n); } static unsigned long objectSequentialId = 0; /* set up the class that handles loading of tcl classes */ t_class * tclpd_class_new(const char *name, int flags) { t_class *c = class_new(gensym(name), (t_newmethod)tclpd_new, (t_method)tclpd_free, sizeof(t_tcl), flags, A_GIMME, A_NULL); if(!class_table) class_table = hashtable_new(1 << 7); if(!class_table_get(name)) class_table_add(name, c); class_addanything(c, tclpd_anything); // is this really necessary given that there is already a 'anything' handler? class_addmethod(c, (t_method)tclpd_loadbang, gensym("loadbang"), A_NULL); class_addmethod(c, (t_method)tclpd_open, gensym("menu-open"), A_NULL); char buf[80]; Tcl_Obj *res; int res_i; // use properties function if exists in tcl space. snprintf(buf, 80, "llength [info procs ::%s::properties]", name); if(Tcl_Eval(tclpd_interp, buf) == TCL_OK) { res = Tcl_GetObjResult(tclpd_interp); if(Tcl_GetIntFromObj(tclpd_interp, res, &res_i) == TCL_OK && res_i > 0) { class_setpropertiesfn(c, tclpd_properties); } } // use save function if exists in tcl space. snprintf(buf, 80, "llength [info procs ::%s::save]", name); if(Tcl_Eval(tclpd_interp, buf) == TCL_OK) { res = Tcl_GetObjResult(tclpd_interp); if(Tcl_GetIntFromObj(tclpd_interp, res, &res_i) == TCL_OK && res_i > 0) { class_setsavefn(c, tclpd_save); } } return c; } t_class * tclpd_guiclass_new(const char *name, int flags) { t_class *c = tclpd_class_new(name, flags); t_widgetbehavior *wb = (t_widgetbehavior *)getbytes(sizeof(t_widgetbehavior)); wb->w_getrectfn = tclpd_guiclass_getrect; wb->w_displacefn = tclpd_guiclass_displace; wb->w_selectfn = tclpd_guiclass_select; wb->w_activatefn = NULL; wb->w_deletefn = tclpd_guiclass_delete; wb->w_visfn = tclpd_guiclass_vis; wb->w_clickfn = tclpd_guiclass_click; class_setwidget(c, wb); return c; } t_tcl * tclpd_new(t_symbol *classsym, int ac, t_atom *at) { // lookup in class table const char *name = classsym->s_name; t_class *qlass = class_table_get(name); while(!qlass) { // try progressively skipping namespace/ prefixes (bug 3436716) name = strchr(name, '/'); if(!name || !*++name) break; qlass = class_table_get(name); } if(!qlass) { error("tclpd: class not found: %s", name); return NULL; } t_tcl *x = (t_tcl *)pd_new(qlass); if(!x) { error("tclpd: failed to create object of class %s", name); return NULL; } /* used for numbering proxy inlets: */ x->ninlets = 1 /* qlass->c_firstin ??? */; x->source_file = (char *)hashtable_get(source_table, name); if(!x->source_file) { post("tclpd: missing source file information. open command will not work."); } x->classname = Tcl_NewStringObj(name, -1); char so[64]; snprintf(so, 64, "tclpd.%s.x%lx", name, objectSequentialId++); x->self = Tcl_NewStringObj(so, -1); char sd[64]; snprintf(sd, 64, "::%s::dispatcher", name); x->dispatcher = Tcl_NewStringObj(sd, -1); // obj instance -> classname mapping char addmapcmd[256]; snprintf(addmapcmd, 256, "array set ::pd::classname {{%s} {%s}}", so, name); Tcl_Eval(tclpd_interp, addmapcmd); // the lifetime of x->{classname,self,dispatcher} is greater than this // function, hence they get an extra Tcl_IncrRefCount here: // (see tclpd_free()) Tcl_IncrRefCount(x->classname); Tcl_IncrRefCount(x->self); Tcl_IncrRefCount(x->dispatcher); // store in object table (for later lookup) if(!object_table) object_table = hashtable_new(1 << 10); if(!object_table_get(so)) object_table_add(so, x); // build constructor command Tcl_Obj *av[ac+3]; InitArray(av, ac+3, NULL); av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("constructor", -1); Tcl_IncrRefCount(av[2]); for(int i=0; idispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("destructor", -1); Tcl_IncrRefCount(av[2]); // call destructor if(Tcl_EvalObjv(tclpd_interp, 3, av, 0) != TCL_OK) { #ifdef DEBUG post("tclpd_free: failed to call destructor"); #endif } // decrement reference counter Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); // remove obj instance -> classname mapping char delmapcmd[256]; snprintf(delmapcmd, 256, "unset ::pd::classname(%s)", Tcl_GetStringFromObj(x->self, NULL)); Tcl_Eval(tclpd_interp, delmapcmd); // here ends the lifetime of x->classname and x->self Tcl_DecrRefCount(x->self); Tcl_DecrRefCount(x->classname); Tcl_DecrRefCount(x->dispatcher); #ifdef DEBUG post("tclpd_free called"); #endif } void tclpd_anything(t_tcl *x, t_symbol *s, int ac, t_atom *at) { tclpd_inlet_anything(x, 0, s, ac, at); } void tclpd_inlet_anything(t_tcl *x, int inlet, t_symbol *s, int ac, t_atom *at) { // proxy method - format: method args... Tcl_Obj *av[ac+5]; InitArray(av, ac+5, NULL); int result; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("method", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewIntObj(inlet); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewStringObj(s->s_name, -1); Tcl_IncrRefCount(av[4]); for(int i=0; isource_file) return; sys_vgui("::pd_menucommands::menu_openfile {%s}\n", x->source_file); } /* Tcl glue: */ t_proxyinlet * tclpd_add_proxyinlet(t_tcl *x) { t_proxyinlet *proxy = (t_proxyinlet *)pd_new(proxyinlet_class); proxyinlet_init(proxy); proxy->target = x; proxy->ninlet = x->ninlets++; inlet_new(&x->o, &proxy->obj.ob_pd, 0, 0); return proxy; } /* t_tcl * tclpd_get_instance(const char *objectSequentialId) { return (t_tcl *)object_table_get(objectSequentialId); } t_pd * tclpd_get_instance_pd(const char *objectSequentialId) { return (t_pd *)object_table_get(objectSequentialId); } t_text * tclpd_get_instance_text(const char *objectSequentialId) { return (t_text *)object_table_get(objectSequentialId); } t_object * tclpd_get_object(const char *objectSequentialId) { t_tcl *x = tclpd_get_instance(objectSequentialId); return &x->o; } t_pd * tclpd_get_object_pd(const char *objectSequentialId) { t_object *o = tclpd_get_object(objectSequentialId); return &o->ob_pd; } t_binbuf * tclpd_get_object_binbuf(const char *objectSequentialId) { t_object *o = tclpd_get_object(objectSequentialId); return o->ob_binbuf; } t_glist * tclpd_get_glist(const char *objectSequentialId) { t_tcl *x = tclpd_get_instance(objectSequentialId); return x->x_glist; } t_atom * tclpd_binbuf_get_atom(t_binbuf *b, int n) { if(binbuf_getnatom(b) <= n || n < 0) return NULL; return binbuf_getvec(b) + n; } */ /* helper function for accessing binbuf's atoms cause, accessing C arrays and doing typemaps is not that easy */ t_atom * binbuf_getatom(t_binbuf *x, int index) { return binbuf_getvec(x) + index; } t_object * CAST_t_object(t_object *o) { return o; } t_pd * CAST_t_pd(t_pd *o) { return o; } t_text * CAST_t_text(t_text *o) { return o; } t_tcl * CAST_t_tcl(t_tcl *o) { return o; } void poststring2 (const char *s) { post("%s", s); } void tclpd_save(t_gobj *z, t_binbuf *b) { Tcl_Obj *av[3]; InitArray(av, 3, NULL); Tcl_Obj *res; t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("save", -1); Tcl_IncrRefCount(av[2]); int result = Tcl_EvalObjv(tclpd_interp, 3, av, 0); if(result == TCL_OK) { res = Tcl_GetObjResult(tclpd_interp); Tcl_IncrRefCount(res); int objc; Tcl_Obj **objv; result = Tcl_ListObjGetElements(tclpd_interp, res, &objc, &objv); if(result == TCL_OK) { if(objc == 0 && objv == NULL) { // call default savefn text_save(z, b); } else { // do custom savefn int i; double tmp; for(i = 0; i < objc; i++) { result = Tcl_GetDoubleFromObj(tclpd_interp, objv[i], &tmp); if(result == TCL_OK) { binbuf_addv(b, "f", (t_float)tmp); } else { char *tmps = Tcl_GetStringFromObj(objv[i], NULL); if(!strcmp(tmps, ";")) { binbuf_addv(b, ";"); } else { binbuf_addv(b, "s", gensym(tmps)); } } } } } else { pd_error(x, "Tcl: object save: failed"); tclpd_interp_error(x, result); } Tcl_DecrRefCount(res); } else { pd_error(x, "Tcl: object save: failed"); tclpd_interp_error(x, result); } Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); } void tclpd_properties(t_gobj *z, t_glist *owner) { Tcl_Obj *av[3]; InitArray(av, 3, NULL); t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("properties", -1); Tcl_IncrRefCount(av[2]); int result = Tcl_EvalObjv(tclpd_interp, 3, av, 0); if(result != TCL_OK) { //res = Tcl_GetObjResult(tclpd_interp); pd_error(x, "Tcl: object properties: failed"); tclpd_interp_error(x, result); } Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); } void tclpd_class_namespace_init(const char *classname) { char cmd[256]; snprintf(cmd, 256, "if [namespace exists ::%s] " "{namespace delete ::%s}; " "namespace eval ::%s {}", classname, classname, classname); Tcl_Eval(tclpd_interp, cmd); } void source_table_remove(const char *object_name) { if(!source_table) source_table = hashtable_new(1 << 7); hashtable_remove(source_table, object_name); } void source_table_add(const char *object_name, const char *source_file) { source_table_remove(object_name); hashtable_add(source_table, object_name, strdup(source_file)); } tclpd-0.3.0/tcl_widgetbehavior.c0000644000175000017500000002267511674625147017114 0ustar zmoelnigzmoelnig#include "tclpd.h" #include void tclpd_guiclass_motion(t_tcl *x, t_floatarg dx, t_floatarg dy) { Tcl_Obj *av[6]; InitArray(av, 6, NULL); av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("motion", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewDoubleObj(dx); Tcl_IncrRefCount(av[4]); av[5] = Tcl_NewDoubleObj(dy); Tcl_IncrRefCount(av[5]); int result = Tcl_EvalObjv(tclpd_interp, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } goto cleanup; error: cleanup: Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_grab(t_tcl *x, t_glist *glist, int xpix, int ypix) { glist_grab(glist, &x->o.te_g, (t_glistmotionfn)tclpd_guiclass_motion, 0, \ (t_floatarg)xpix, (t_floatarg)ypix); } int tclpd_guiclass_click(t_gobj *z, t_glist *glist, int xpix, int ypix, int shift, int alt, int dbl, int doit) { Tcl_Obj *av[10]; InitArray(av, 10, NULL); Tcl_Obj *o = NULL; int i = 0; t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("click", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewIntObj(xpix); Tcl_IncrRefCount(av[4]); av[5] = Tcl_NewIntObj(ypix); Tcl_IncrRefCount(av[5]); av[6] = Tcl_NewIntObj(shift); Tcl_IncrRefCount(av[6]); av[7] = Tcl_NewIntObj(alt); Tcl_IncrRefCount(av[7]); av[8] = Tcl_NewIntObj(dbl); Tcl_IncrRefCount(av[8]); av[9] = Tcl_NewIntObj(doit); Tcl_IncrRefCount(av[9]); int result = Tcl_EvalObjv(tclpd_interp, 10, av, 0); if(result != TCL_OK) { goto error; } o = Tcl_GetObjResult(tclpd_interp); Tcl_IncrRefCount(o); if(strlen(Tcl_GetStringFromObj(o, NULL)) > 0) { result = Tcl_GetIntFromObj(tclpd_interp, o, &i); if(result != TCL_OK) { goto error; } } goto cleanup; error: tclpd_interp_error(x, result); cleanup: if(o) Tcl_DecrRefCount(o); Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); Tcl_DecrRefCount(av[6]); Tcl_DecrRefCount(av[7]); Tcl_DecrRefCount(av[8]); Tcl_DecrRefCount(av[9]); // return value (BOOL) means 'object wants to be clicked' (g_editor.c:1270) return i; } void tclpd_guiclass_getrect(t_gobj *z, t_glist *owner, int *xp1, int *yp1, int *xp2, int *yp2) { Tcl_Obj *av[6]; InitArray(av, 6, NULL); Tcl_Obj *o; Tcl_Obj *theList = NULL; int tmp[4], i, length; t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("getrect", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewIntObj(text_xpix(&x->o, owner)); Tcl_IncrRefCount(av[4]); av[5] = Tcl_NewIntObj(text_ypix(&x->o, owner)); Tcl_IncrRefCount(av[5]); int result = Tcl_EvalObjv(tclpd_interp, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } theList = Tcl_GetObjResult(tclpd_interp); Tcl_IncrRefCount(theList); length = 0; //result = Tcl_ListObjGetElements(tclpd_interp, theList, @, @); result = Tcl_ListObjLength(tclpd_interp, theList, &length); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } if(length != 4) { pd_error(x, "widgetbehavior getrect: must return a list of 4 integers"); goto error; } o = NULL; for(i = 0; i < 4; i++) { result = Tcl_ListObjIndex(tclpd_interp, theList, i, &o); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } result = Tcl_GetIntFromObj(tclpd_interp, o, &tmp[i]); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } } *xp1 = tmp[0]; *yp1 = tmp[1]; *xp2 = tmp[2]; *yp2 = tmp[3]; goto cleanup; error: cleanup: if(theList) Tcl_DecrRefCount(theList); Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_displace(t_gobj *z, t_glist *glist, int dx, int dy) { Tcl_Obj *av[6]; InitArray(av, 6, NULL); Tcl_Obj *theList = NULL; Tcl_Obj *o; int length, i, tmp[2]; t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("displace", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewIntObj(dx); Tcl_IncrRefCount(av[4]); av[5] = Tcl_NewIntObj(dy); Tcl_IncrRefCount(av[5]); int result = Tcl_EvalObjv(tclpd_interp, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } theList = Tcl_GetObjResult(tclpd_interp); Tcl_IncrRefCount(theList); length = 0; //result = Tcl_ListObjGetElements(tclpd_interp, theList, @, @); result = Tcl_ListObjLength(tclpd_interp, theList, &length); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } if(length != 2) { pd_error(x, "widgetbehavior displace: must return a list of 2 integers"); goto error; } o = NULL; for(i = 0; i < 2; i++) { result = Tcl_ListObjIndex(tclpd_interp, theList, i, &o); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } result = Tcl_GetIntFromObj(tclpd_interp, o, &tmp[i]); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } } x->o.te_xpix = tmp[0]; x->o.te_ypix = tmp[1]; canvas_fixlinesfor(glist_getcanvas(glist), (t_text *)x); goto cleanup; error: cleanup: if(theList) Tcl_DecrRefCount(theList); Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_select(t_gobj *z, t_glist *glist, int selected) { Tcl_Obj *av[5]; InitArray(av, 5, NULL); t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("select", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewIntObj(selected); Tcl_IncrRefCount(av[4]); int result = Tcl_EvalObjv(tclpd_interp, 5, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } goto cleanup; error: cleanup: Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); } void tclpd_guiclass_activate(t_gobj *z, t_glist *glist, int state) { Tcl_Obj *av[5]; InitArray(av, 5, NULL); t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("activate", -1); Tcl_IncrRefCount(av[3]); av[4] = Tcl_NewIntObj(state); Tcl_IncrRefCount(av[4]); int result = Tcl_EvalObjv(tclpd_interp, 5, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } goto cleanup; error: cleanup: Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); } void tclpd_guiclass_delete(t_gobj *z, t_glist *glist) { /* will this be ever need to be accessed in Tcl land? */ canvas_deletelinesfor(glist_getcanvas(glist), (t_text *)z); } void tclpd_guiclass_vis(t_gobj *z, t_glist *glist, int vis) { Tcl_Obj *av[8]; InitArray(av, 8, NULL); t_tcl *x = (t_tcl *)z; av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); av[3] = Tcl_NewStringObj("vis", -1); Tcl_IncrRefCount(av[3]); char buf[32]; snprintf(buf, 32, ".x%lx.c", glist_getcanvas(glist)); av[4] = Tcl_NewStringObj(buf, -1); Tcl_IncrRefCount(av[4]); av[5] = Tcl_NewIntObj(text_xpix(&x->o, glist)); Tcl_IncrRefCount(av[5]); av[6] = Tcl_NewIntObj(text_ypix(&x->o, glist)); Tcl_IncrRefCount(av[6]); av[7] = Tcl_NewIntObj(vis); Tcl_IncrRefCount(av[7]); int result = Tcl_EvalObjv(tclpd_interp, 8, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; } goto cleanup; error: cleanup: Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); Tcl_DecrRefCount(av[6]); Tcl_DecrRefCount(av[7]); }