aboutsummaryrefslogtreecommitdiff
path: root/slider2.tcl
diff options
context:
space:
mode:
authormescalinum <mescalinum@users.sourceforge.net>2011-10-02 16:42:06 +0000
committermescalinum <mescalinum@users.sourceforge.net>2011-10-02 16:42:06 +0000
commit44f29524444a96d9e40a76f48750f17e2fdc2974 (patch)
tree179e086e72dd64cd130ee493e78d8535a74a76ec /slider2.tcl
parent5a38f01421e93db2cf5b5c05afe84fb73eb89425 (diff)
reorganize tree following template structure
svn path=/trunk/externals/loaders/tclpd/; revision=15443
Diffstat (limited to 'slider2.tcl')
-rw-r--r--slider2.tcl273
1 files changed, 0 insertions, 273 deletions
diff --git a/slider2.tcl b/slider2.tcl
deleted file mode 100644
index ff4678a..0000000
--- a/slider2.tcl
+++ /dev/null
@@ -1,273 +0,0 @@
-package require Tclpd 0.2.1
-package require TclpdLib 0.17
-
-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 == "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 != {}} {
- 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]
- }
-}
-
-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
- }
-
- destructor {
- if {[dict get $@config -receivesymbol] != {}} {
- pd_unbind [tclpd_get_instance_pd $self] $@recv
- }
- }
-
- 0_loadbang {
- if {[dict get $@config -init]} {$self 0 bang}
- }
-
- 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]
- }
- }
-
- 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
- }
- }
-
- 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}
- }
- }
-
- 0_float {
- $self 0 set {*}$args
- $self 0 bang
- }
-
- object_save {
- return [list #X obj $@x $@y slider2 {*}[pd::add_empty $@config] \;]
- }
-
- 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
- }
-
- 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]
- }
-
- 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]
- }
-
- widgetbehavior_select {
- lassign $args sel
- sys_gui [list $@c itemconfigure $self&&!label$self -outline [lindex \
- [list [dict get $@config -fgcolor] {blue}] $sel]]\n
- }
-
- 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
- }
- }
-
- 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
- }
- }
-
- widgetbehavior_motion {
- 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}]
- $self 0 float {*}[pd::add_selectors [list $f]]
- }
-}