diff options
Diffstat (limited to 'examples/slider2.tcl')
| -rw-r--r-- | examples/slider2.tcl | 366 |
1 files changed, 183 insertions, 183 deletions
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 |