aboutsummaryrefslogtreecommitdiff
path: root/examples
diff options
context:
space:
mode:
authormescalinum <mescalinum@users.sourceforge.net>2011-10-14 21:32:49 +0000
committermescalinum <mescalinum@users.sourceforge.net>2011-10-14 21:32:49 +0000
commit9ea4e9fc1b4775a0e6b1c387a2a0965686c1c20e (patch)
tree1e34e08655343287c27aed8ecfc1ff7a1f630191 /examples
parent27e3734f86554c31a4593b998ca5312cf1b1af5b (diff)
reorder tcl land into namespaces and streamline and standardize syntax
svn path=/trunk/externals/loaders/tclpd/; revision=15600
Diffstat (limited to 'examples')
-rw-r--r--examples/binbuf-test.tcl21
-rw-r--r--examples/bitmap.tcl546
-rw-r--r--examples/dynreceive.tcl84
-rw-r--r--examples/dynroute.tcl74
-rw-r--r--examples/list_change-help.pd42
-rw-r--r--examples/list_change.tcl47
-rw-r--r--examples/slider2.tcl366
7 files changed, 589 insertions, 591 deletions
diff --git a/examples/binbuf-test.tcl b/examples/binbuf-test.tcl
index 9c9117f..62fc8c1 100644
--- a/examples/binbuf-test.tcl
+++ b/examples/binbuf-test.tcl
@@ -1,15 +1,12 @@
-package require Tclpd 0.2.2
-package require TclpdLib 0.18
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
-pd::class binbuf-test {
- constructor {
- pd::add_outlet $self list
- }
-
- destructor {
- }
+proc binbuf-test::constructor {self args} {
+ pd::add_outlet $self list
+}
- 0_bang {
- pd::outlet $self 0 list [pd::get_binbuf $self]
- }
+proc binbuf-test::0_bang {self} {
+ pd::outlet $self 0 list [pd::get_binbuf $self]
}
+
+pd::class binbuf-test
diff --git a/examples/bitmap.tcl b/examples/bitmap.tcl
index 43241d2..97b9491 100644
--- a/examples/bitmap.tcl
+++ b/examples/bitmap.tcl
@@ -1,5 +1,5 @@
-package require Tclpd 0.2.2
-package require TclpdLib 0.17
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
set ::script_path [file dirname [info script]]
@@ -27,320 +27,320 @@ pd::guiproc bitmap_draw_new {self c x y config data} {
-outline $fgcolor -tags [list $self border$self]
}
-pd::guiclass bitmap {
- constructor {
- set s [file join $::script_path properties.tcl]
- sys_gui "source {$s}\n"
+proc+ bitmap::constructor {self args} {
+ set s [file join $::script_path properties.tcl]
+ sys_gui "source {$s}\n"
- pd::add_outlet $self float
+ 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 {}
+ # 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 {}
- ::$self 0 config {*}$args
+ 0_config $self {*}$args
- set @rcvLoadData {#bitmap}
- pd_bind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData]
- }
+ set @rcvLoadData {#bitmap}
+ pd_bind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData]
+}
- destructor {
- set pdself [tclpd_get_instance_pd $self]
- if {$@rcvLoadData != {}} {
- #should not happen!
- pd_unbind $pdself [gensym $@rcvLoadData]
- }
- if {[dict get $@config -receivesymbol] != {}} {
- pd_unbind $pdself $@recv
- }
+proc+ bitmap::destructor {self} {
+ set pdself [tclpd_get_instance_pd $self]
+ if {$@rcvLoadData != {}} {
+ #should not happen!
+ pd_unbind $pdself [gensym $@rcvLoadData]
+ }
+ if {[dict get $@config -receivesymbol] != {}} {
+ pd_unbind $pdself $@recv
}
+}
- 0_config {
- if {$args == {}} {
- 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
+proc+ bitmap::0_config {self args} {
+ if {$args == {}} {
+ 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'"
}
- if {[dict get $@config -uwidth] != [dict get $newconf -uwidth] ||
- [dict get $@config -uheight] != [dict get $newconf -uheight]} {
- $self 0 resize {*}[pd::add_selectors [list \
- [dict get $newconf -uwidth] \
- [dict get $newconf -uheight] \
- ]]
+ incr i
+ set v [lindex $optlist $i]
+ if {[lsearch -exact {-uwidth -uheight -cellsize} $k] != -1} {
+ set v [expr {int($v)}]
}
- 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 != $new} {
- dict set @config -$opt $new
- set ui 1
- }
+ 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 != $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 != $new} {
- if {$opt == "receivesymbol"} {
- set selfpd [tclpd_get_instance_pd $self]
- if {$old != {}} {
- pd_unbind $selfpd $@recv
- }
- if {$new != {}} {
- set @recv [canvas_realizedollar \
- [tclpd_get_glist $self] [gensym $new]]
- pd_bind $selfpd $@recv
- } else {
- set @recv {}
- }
+ }
+ foreach opt {sendsymbol receivesymbol} {
+ set old [dict get $@config -$opt]
+ if {[dict exists $newconf -$opt]} {
+ set new [dict get $newconf -$opt]
+ if {$old != $new} {
+ if {$opt == "receivesymbol"} {
+ set selfpd [tclpd_get_instance_pd $self]
+ if {$old != {}} {
+ pd_unbind $selfpd $@recv
+ }
+ if {$new != {}} {
+ set @recv [canvas_realizedollar \
+ [tclpd_get_glist $self] [gensym $new]]
+ pd_bind $selfpd $@recv
+ } else {
+ set @recv {}
}
- dict set @config -$opt $new
}
+ 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
- }
}
- }
-
- 0_resize {
- 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
- }
- }
+ 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
}
- dict set @config -uwidth $w
- dict set @config -uheight $h
- set @data $newd
}
+}
- 0_getrow {
- 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]]
+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
+ }
}
- pd::outlet $self 0 list $r
}
+ dict set @config -uwidth $w
+ dict set @config -uheight $h
+ set @data $newd
+}
- 0_getcol {
- 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_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
+}
- 0_getcell {
- 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_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
+}
- 0_setrow {
- 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_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}]]
+}
- 0_setcol {
- 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_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
}
+}
- 0_setcell {
- 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}]
+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_${r}_${c}_$self \
+ sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \
-fill [lindex $colors $d]]\n
+ incr z
+ incr row
}
+}
- 0_setdata {
- 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)}]}
- if {$@rcvLoadData != {}} {
- pd_unbind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData]
- set @rcvLoadData {}
- }
- }
+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
+}
- object_save {
- return [list #X obj $@x $@y bitmap {*}[pd::add_empty $@config] \; \
- \#bitmap setdata {*}$@data \; ]
+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"
}
-
- object_properties {
- set title "\[bitmap\] properties"
- set x_xobj_obpd [tclpd_get_object_pd $self]
- set x [tclpd_get_instance $self]
- set buf [list propertieswindow %s $@config $title]\n
- gfxstub_new $x_xobj_obpd $x $buf
+ set @data [list]
+ foreach i $d {lappend @data [expr {int($i)}]}
+ if {$@rcvLoadData != {}} {
+ pd_unbind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData]
+ set @rcvLoadData {}
}
+}
- widgetbehavior_getrect {
- 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::save {self args} {
+ return [list #X obj $@x $@y bitmap {*}[pd::add_empty $@config] \; \
+ \#bitmap setdata {*}$@data \; ]
+}
- widgetbehavior_displace {
- 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::properties {self args} {
+ set title "\[bitmap\] properties"
+ set x_xobj_obpd [tclpd_get_object_pd $self]
+ set x [tclpd_get_instance $self]
+ set buf [list propertieswindow %s $@config $title]\n
+ gfxstub_new $x_xobj_obpd $x $buf
+}
- widgetbehavior_select {
- 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_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]
+}
- widgetbehavior_activate {
+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]
+}
- widgetbehavior_vis {
- 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_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
}
+}
- widgetbehavior_click {
- 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
- }
+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
diff --git a/examples/dynreceive.tcl b/examples/dynreceive.tcl
index 8a269f7..6903da9 100644
--- a/examples/dynreceive.tcl
+++ b/examples/dynreceive.tcl
@@ -1,53 +1,53 @@
-package require Tclpd 0.2.1
-package require TclpdLib 0.17
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
-pd::class dynreceive {
- constructor {
- set @sym {}
- if {[pd::args] > 0} {
- set @sym [pd::arg 0 symbol]
- pd_bind [tclpd_get_instance_pd $self] [gensym $@sym]
- }
- pd::add_outlet $self
+proc+ dynreceive::constructor {self args} {
+ set @sym {}
+ if {[pd::args] > 0} {
+ set @sym [pd::arg 0 symbol]
+ pd_bind [tclpd_get_instance_pd $self] [gensym $@sym]
}
+ pd::add_outlet $self
+}
- destructor {
- # don't forget to call pd_unbind, or sending things to a symbol
- # bound to dead object will crash pd!
- if {$@sym != {}} {
- pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym]
- }
+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 != {}} {
+ pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym]
}
+}
- 0_set {
- # send [set empty( to clear the receive symbol
- set s [pd::arg 0 symbol]
- if {$@sym != {}} {
- pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym]
- }
- if {$s == {empty}} {
- set @sym {}
- } else {
- set @sym $s
- pd_bind [tclpd_get_instance_pd $self] [gensym $@sym]
- }
+proc+ dynreceive::0_set {self args} {
+ # send [set empty( to clear the receive symbol
+ set s [pd::arg 0 symbol]
+ if {$@sym != {}} {
+ pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym]
}
-
- 0_bang {
- pd::outlet $self 0 bang
+ if {$s == {empty}} {
+ set @sym {}
+ } else {
+ set @sym $s
+ pd_bind [tclpd_get_instance_pd $self] [gensym $@sym]
}
+}
- 0_float {
- pd::outlet $self 0 float [pd::arg 0 float]
- }
+proc+ dynreceive::0_bang {self} {
+ pd::outlet $self 0 bang
+}
- 0_symbol {
- pd::outlet $self 0 symbol [gensym [pd::arg 0 symbol]]
- }
+proc+ dynreceive::0_float {self args} {
+ pd::outlet $self 0 float [pd::arg 0 float]
+}
- 0_anything {
- set sel [pd::arg 0 symbol]
- set argz [lrange $args 1 end]
- pd::outlet $self 0 $sel $argz
- }
+proc+ dynreceive::0_symbol {self args} {
+ pd::outlet $self 0 symbol [gensym [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
diff --git a/examples/dynroute.tcl b/examples/dynroute.tcl
index 2309ac7..04cb3c9 100644
--- a/examples/dynroute.tcl
+++ b/examples/dynroute.tcl
@@ -1,5 +1,5 @@
-package require Tclpd 0.2.1
-package require TclpdLib 0.17
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
# dynroute: dynamically route messages based on first element
# non-matching arguments are sent to last inlet
@@ -10,48 +10,48 @@ package require TclpdLib 0.17
# remove <atom> <float> remove previously created routing
# clear
-pd::class dynroute {
- constructor {
- pd::add_inlet $self list
+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}
+ 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 {}
+ for {set i 0} {$i < $@num_outlets} {incr i} {
+ pd::add_outlet $self list
}
- 0_list {
- 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
- }
+ set @routing {}
+}
- 1_add {
- 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::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
+}
- 1_remove {
- 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_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
+}
- 1_clear {
- set @routing {}
+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
diff --git a/examples/list_change-help.pd b/examples/list_change-help.pd
index 430b23d..3b3a8ba 100644
--- a/examples/list_change-help.pd
+++ b/examples/list_change-help.pd
@@ -1,21 +1,21 @@
-#N canvas 617 384 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;
+#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;
diff --git a/examples/list_change.tcl b/examples/list_change.tcl
index 2c70937..26190e4 100644
--- a/examples/list_change.tcl
+++ b/examples/list_change.tcl
@@ -1,31 +1,32 @@
-package require Tclpd 0.2.1
-package require TclpdLib 0.17
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
-pd::class list_change {
- constructor {
- # add second inlet (first created by default)
- pd::add_inlet $self list
+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
+ # add outlet
+ pd::add_outlet $self list
- set @curlist {}
- }
-
- 0_list {
- # HOT inlet
- if {$args != $@curlist} {
- set @curlist $args
- pd::outlet $self 0 list $@curlist
- }
- }
+ set @curlist {}
+}
- 0_bang {
+proc+ list_change::0_list {self args} {
+ # HOT inlet
+ if {$args != $@curlist} {
+ set @curlist $args
pd::outlet $self 0 list $@curlist
}
+}
- 1_list {
- # COLD inlet
- set @curlist $args
- }
+proc+ list_change::0_bang {self} {
+ if {$@curlist == {}} return
+ pd::outlet $self 0 list $@curlist
}
+
+proc+ list_change::1_list {self args} {
+ # COLD inlet
+ set @curlist $args
+}
+
+pd::class list_change
diff --git a/examples/slider2.tcl b/examples/slider2.tcl
index 23a2141..adc2e35 100644
--- a/examples/slider2.tcl
+++ b/examples/slider2.tcl
@@ -1,5 +1,5 @@
-package require Tclpd 0.2.2
-package require TclpdLib 0.17
+package require Tclpd 0.2.3
+package require TclpdLib 0.19
set ::script_path [file dirname [info script]]
@@ -59,215 +59,215 @@ pd::guiproc slider2_update {self c x y config state} {
}
}
-pd::guiclass slider2 {
- constructor {
- 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 {}
- ::$self 0 config {*}$args
+proc+ slider2::constructor {self args} {
+ 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
+}
- destructor {
- if {[dict get $@config -receivesymbol] != {}} {
- pd_unbind [tclpd_get_instance_pd $self] $@recv
- }
+proc+ slider2::destructor {self} {
+ if {[dict get $@config -receivesymbol] != {}} {
+ pd_unbind [tclpd_get_instance_pd $self] $@recv
}
+}
- 0_loadbang {
- if {[dict get $@config -init]} {$self 0 bang}
- }
+proc+ slider2::0_loadbang {self} {
+ if {[dict get $@config -init]} {0_bang $self}
+}
- 0_config {
- 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] == $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]
- set selfpd [tclpd_get_instance_pd $self]
- if {[dict get $@config -receivesymbol] != {}} {
- pd_unbind $selfpd $@recv
- }
- if {$new_recv != {}} {
- set @recv [canvas_realizedollar \
- [tclpd_get_glist $self] [gensym $new_recv]]
- pd_bind $selfpd $@recv
- } else {set @recv {}}
- }
- if {[dict exists $newconf -sendsymbol]} {
- set new_send [dict get $newconf -sendsymbol]
- if {$new_send != {}} {
- set @send [canvas_realizedollar \
- [tclpd_get_glist $self] [gensym $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 \
- [tclpd_get_glist $self] [tclpd_get_instance_text $self]
+proc+ slider2::0_config {self args} {
+ 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] == $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
}
-
- 0_set {
- 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
+ # process -{send,receive}symbol
+ if {[dict exists $newconf -receivesymbol]} {
+ set new_recv [dict get $newconf -receivesymbol]
+ set selfpd [tclpd_get_instance_pd $self]
+ if {[dict get $@config -receivesymbol] != {}} {
+ pd_unbind $selfpd $@recv
}
+ if {$new_recv != {}} {
+ set @recv [canvas_realizedollar \
+ [tclpd_get_glist $self] [gensym $new_recv]]
+ pd_bind $selfpd $@recv
+ } else {set @recv {}}
}
-
- 0_bang {
- foreach v {initvalue} {set $v [dict get $@config -$v]}
- pd::outlet $self 0 float $initvalue
- if {$@send != {}} {
- set s_thing [$@send cget -s_thing]
- if {$s_thing != {NULL}} {pd_float $s_thing $initvalue}
- }
+ if {[dict exists $newconf -sendsymbol]} {
+ set new_send [dict get $newconf -sendsymbol]
+ if {$new_send != {}} {
+ set @send [canvas_realizedollar \
+ [tclpd_get_glist $self] [gensym $new_send]]
+ } else {set @send {}}
}
-
- 0_float {
- $self 0 set {*}$args
- $self 0 bang
+ # 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]
}
-
- object_save {
- return [list #X obj $@x $@y slider2 {*}[pd::add_empty $@config] \;]
+ # 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"}
}
-
- object_properties {
- set c [string map {$ \\$} $@config]
- gfxstub_new [tclpd_get_object_pd $self] [tclpd_get_instance $self] \
- [list propertieswindow %s $c "\[slider2\] properties"]\n
+ # 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
}
-
- widgetbehavior_getrect {
- 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]
+ if {[dict exists $newconf -width] || [dict exists $newconf -height]} {
+ canvas_fixlinesfor \
+ [tclpd_get_glist $self] [tclpd_get_instance_text $self]
}
+}
- widgetbehavior_displace {
- 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::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
}
+}
- widgetbehavior_select {
- lassign $args sel
- sys_gui [list $@c itemconfigure $self&&!label$self -outline [lindex \
- [list [dict get $@config -fgcolor] {blue}] $sel]]\n
+proc+ slider2::0_bang {self} {
+ foreach v {initvalue} {set $v [dict get $@config -$v]}
+ pd::outlet $self 0 float $initvalue
+ if {$@send != {}} {
+ set s_thing [$@send cget -s_thing]
+ if {$s_thing != {NULL}} {pd_float $s_thing $initvalue}
}
+}
- widgetbehavior_vis {
- 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::0_float {self args} {
+ 0_set $self {*}$args
+ 0_bang $self
+}
+
+proc+ slider2::save {self} {
+ return [list #X obj $@x $@y slider2 {*}[pd::add_empty $@config] \;]
+}
+
+proc+ slider2::properties {self} {
+ set c [string map {$ \\$} $@config]
+ gfxstub_new [tclpd_get_object_pd $self] [tclpd_get_instance $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]
+}
- widgetbehavior_click {
- 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 [tclpd_get_instance $self] \
- [tclpd_get_glist $self] $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
}
+}
- widgetbehavior_motion {
- lassign $args dx dy
+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_curr_x [expr {$dx+$@motion_curr_x}]
- set pixdelta [expr {-1*($@motion_curr_x-$@motion_start_x)}]
+ set @motion_start_x $x
+ set @motion_curr_x $x
}
vertical {
- set @motion_curr_y [expr {$dy+$@motion_curr_y}]
- set pixdelta [expr {-1*($@motion_curr_y-$@motion_start_y)}]
+ set @motion_start_y $y
+ set @motion_curr_y $y
}
}
- set f [expr {$@motion_start_v+$pixdelta*$@pix2units}]
- $self 0 float {*}[pd::add_selectors [list $f]]
+ set @motion_start_v [dict get $@config -initvalue]
+ tclpd_guiclass_grab [tclpd_get_instance $self] \
+ [tclpd_get_glist $self] $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