[PD-cvs] pd/src desire.tk,1.1.2.18,1.1.2.19
Mathieu Bouchard
matju at users.sourceforge.net
Sun Sep 4 07:24:44 CEST 2005
Update of /cvsroot/pure-data/pd/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24912
Modified Files:
Tag: devel_0_39
desire.tk
Log Message:
adding a large chunk of code from impd_0_37 (namely, all gui objects that
were not there yet. but that code is not doing anything yet)
Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.18
retrieving revision 1.1.2.19
diff -C2 -d -r1.1.2.18 -r1.1.2.19
*** desire.tk 31 Aug 2005 03:35:44 -0000 1.1.2.18
--- desire.tk 4 Sep 2005 05:24:41 -0000 1.1.2.19
***************
*** 1,8 ****
#-----------------------------------------------------------------------------------#
#
! #thanks for taking time looking at this code:)
#
! #this is desiredata
! #this code is still in early development
#-----------------------------------------------------------------------------------#
--- 1,14 ----
+ #!/usr/bin/env wish
#-----------------------------------------------------------------------------------#
#
! # DesireData
! # Copyright (c) 2004 by Mathieu Bouchard
! # Copyright (c) 2005 by Chun Lee
! # This software has no license yet
! # And is not covered by the license on the rest of PureData.
! # All Rights Reserved (for now)
#
! # this code is still in early development
! # (thanks for taking time looking at this code)
#-----------------------------------------------------------------------------------#
***************
*** 2863,2864 ****
--- 2869,3711 ----
# [lrange $d 0 3] {}
#}
+ #-----------------------------------------------------------------------------------#
+
+ ############ colouring
+
+ proc bluify {colour} {
+ global look
+ scan $colour #%02x%02x%02x r g b
+ scan $look(sliderbg) #%02x%02x%02x R G B
+ return [format #%02x%02x%02x [expr ($r*$R)>>8] [expr ($g*$G)>>8] [expr ($b*$B)>>8]]
+ }
+
+ proc darker {colour} {
+ scan $colour #%02x%02x%02x r g b
+ set r [expr $r*3/4]
+ set g [expr $g*3/4]
+ set b [expr $b*3/4]
+ return [format #%02x%02x%02x $r $g $b]
+ }
+
+ proc parse_color {c} {
+ regsub {;$} $c {} c
+ if {$c<0} {
+ set c [expr ~$c]
+ set r [expr round((($c>>12)&63)*255/63)]
+ set g [expr round((($c>> 6)&63)*255/63)]
+ set b [expr round((($c>> 0)&63)*255/63)]
+ set foo [format #%02x%02x%02x $r $g $b]
+ #puts $foo
+ return $foo
+ } {
+ global preset_colors2
+ return #[lindex $preset_colors2 $c]
+ }
+ }
+
+ proc unparse_color {c} {
+ if {[string index $c 0]=="#"} {set c [string replace $c 0 0 0x]}
+ set r [expr round((($c>>16)&255)*63/255)]
+ set g [expr round((($c>> 8)&255)*63/255)]
+ set b [expr round((($c>> 0)&255)*63/255)]
+ set foo [expr ~0[format %02o%02o%02o $r $g $b]]
+ #puts "$r $g $b $foo"
+ return $foo
+ }
+
+ ############ data transfer
+
+ # abstract classes
+ set fields1 {foo bar x1 y1 class}
+ set fields2 {snd rcv lab ldx ldy fstyle fs bcol fcol lcol}
+
+ # real classes
+ set fields(obj) [eval list $fields1]
+ set fields(tgl) [eval list $fields1 w isa $fields2 on nonzero]
+ set fields(bng) [eval list $fields1 w hold break isa $fields2]
+ set fields(nbx) [eval list $fields1 w h min max is_log isa $fields2 val log_height]
+ set fields(hsl) [eval list $fields1 w h min max is_log isa $fields2 val steady]
+ set fields(hradio) [eval list $fields1 w change isa n $fields2 on]
+ set fields(vu) [eval list $fields1 w h rcv lab ldx ldy fstyle fs bcol lcol scale isa]
+ set fields(cnv) [eval list $fields1 hh w h snd rcv lab ldx ldy fstyle fs bcol lcol isa]
+ set fields(dropper) [eval list $fields1 w isa $fields2]
+ set fields(vsl) $fields(hsl)
+ set fields(vradio) $fields(hradio)
+ set fields(hdl) $fields(hradio)
+ set fields(vdl) $fields(hradio)
+ #set fields(msg)
+
+ set classinfo(obj) {Object object}
+ set classinfo(tgl) {Toggle toggle}
+ set classinfo(bng) {Bang bang}
+ set classinfo(nbx) {Numberbox numbox}
+ set classinfo(hsl) {Slider slider}
+ set classinfo(hradio) {Radiobutton radio}
+ set classinfo(vu) {Vumeter vu}
+ set classinfo(cnv) {Canvas cnv}
+ set classinfo(dropper) {Dropper dropper}
+ set classinfo(vsl) $classinfo(hsl)
+ set classinfo(vradio) $classinfo(hradio)
+ set classinfo(hdl) $classinfo(hradio)
+ set classinfo(vdl) $classinfo(hradio)
+
+ proc call {sel self args} {
+ global _ classinfo
+ set class [lindex $classinfo($_($self:class)) 1]
+ eval [linsert $args 0 ${class}_$sel $self]
+ }
+
+ proc update_object {x d} {
+ global _
+ global fields
+ set d [string trimright $d "\n"]
+ set d [string trimright $d ";"]
+ set i 1
+ set class [lindex $d $i]
+ switch -- $class { obj { set i 4; set class [lindex $d $i] }}
+ if {![info exists fields($class)]} {set class obj}
+ #puts "${class} $x = $d"
+ #if {[llength $fields] != [llength $d]} {huh}
+ set i 0
+ foreach f $fields($class) {
+ set _($x:$f) [lindex $d $i]
+ incr i
+ }
+ }
+
+ ############ rendering
+
+ # for future use
+ proc update_item {self canvas suffix type coords args} {
+ if {![llength [$canvas gettags ${self}${suffix}]]} {
+ $canvas create $type $coords -tags ${self}$suffix $args...
+ } {
+ $canvas itemconfigure ${self}$suffix $args...
+ }
+ }
+
+ global pd_nt
+ switch $pd_nt {
+ 2 { set look(extrapix) 2 }
+ default { set look(extrapix) 1 }
+ }
+
+ set look(iowidth) 7
+ set look(iopos) 1
+
+ proc shadow_draw {self canvas coords} {
+ global look
+ set light [darker ${look(objectbg)}]
+ set dark [darker $light]
+ if {[llength [$canvas gettags ${self}SHAD]] != 0} {
+ $canvas coords ${self}SHAD $coords
+ } {
+ $canvas create rectangle $coords -tag ${self}SHAD \
+ -fill $dark -outline $light -width 2
+ }
+ $canvas move ${self}SHAD 4 4
+ }
+
+ proc brokenbox_erase {self canvas} {objectbox_erase $self $canvas}
+
+ proc message_draw {self canvas xs ys ins outs} {
+ global look
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set points [list $x1 $y1 [expr $x2+4] $y1 $x2 [expr $y1+4] $x2 [expr $y2-4] \
+ [expr $x2+4] $y2 $x1 $y2 $x2 $y2 $x1 $y2]
+ #shadow_draw $self $canvas $points
+ if {[llength [$canvas gettags ${self}BASE]] != 0} {
+ $canvas coords ${self}BASE $points
+ } {
+ $canvas create polygon $points -tag ${self}BASE -fill $look(objectbg) -outline $look(objectframe3)
+ }
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {[canvas_isselected $canvas $self]} {set frcol $look(objectframe4)} {set frcol $look(objectframe3)}
+ $canvas itemconfigure ${self}BASE -outline $frcol
+ }
+
+ proc message_bang {self canvas flag} {
+ global _ look
+ if {$flag} {
+ $canvas itemconfigure ${self}BASE -fill #ffff00
+ } {
+ $canvas itemconfigure ${self}BASE -fill $look(objectbg)
+ }
+
+ }
+
+ proc message_erase {self canvas} {
+ $canvas delete ${self}BASE
+ io_erase $self $canvas
+ }
+
+ #proc message_click {self canvas} {}
+ #proc message_tick {self canvas} {}
+
+ proc atom_draw {self canvas xs ys ins outs} {
+ global look
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set points [list $x1 $y1 [expr $x2-4] $y1 $x2 [expr $y1+4] $x2 $y2 $x1 $y2]
+ #shadow_draw $self $canvas $points
+ if {[catch {$canvas canvasx $x1}]} {
+ post "atom_draw: canvas $canvas does not exist"
+ return
+ }
+ if {[llength [$canvas gettags ${self}BASE]] != 0} {
+ $canvas coords ${self}BASE $points
+ } {
+ $canvas create polygon $points -tag ${self}BASE -fill $look(objectbg) -outline $look(objectframe3)
+ }
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {[canvas_isselected $canvas $self]} {set frcol $look(objectframe4)} {set frcol $look(objectframe3)}
+ $canvas itemconfigure ${self}BASE -outline $frcol
+ }
+
+ proc atom_erase {self canvas} {
+ $canvas delete ${self}BASE
+ io_erase $self $canvas
+ }
+
+ proc numbox_draw {self canvas} {
+ global look
+ global _
+ if {![info exists _($self:buf)]} {set _($self:buf) ""}
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs [expr 4+10*$_($self:w)]
+ set ys $_($self:h)
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ set points [list $x1 $y1 [expr $x2-4] $y1 $x2 [expr $y1+4] $x2 $y2 $x1 $y2]
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ set font courier
+ set xt [expr $x1+$ys/2+2]
+ set yt [expr $y1+$ys/2+1+$xs/34]
+ #shadow_draw $self $canvas $points
+ set points2 [list $x1 $y1 [expr $x1+$ys/2] [expr $y1+$ys/2] $x1 $y2]
+ puts "numbox_draw $self $canvas"
+ if {$isnew} {
+ $canvas create polygon $points -tag ${self}BASE
+ $canvas create polygon $points2 -tag ${self}BASE4
+ $canvas create text $xt $yt -anchor w -tags ${self}NUMBER
+ set _($self:clicking) 0
+ } {
+ $canvas coords ${self}BASE $points
+ $canvas coords ${self}BASE4 $points2
+ $canvas coords ${self}NUMBER $xt $yt
+ }
+ set grabbed [expr ![string compare $self [canvas_grabber $canvas]]]
+ if {$grabbed} {set color4 #00ff00} {set color4 $look(objectbg)}
+ $canvas itemconfigure ${self}BASE -fill [parse_color $_($self:bcol)] -outline $look(objectframe3)
+ $canvas itemconfigure ${self}BASE4 -fill $color4 -outline $look(objectframe3)
+ $canvas itemconfigure ${self}NUMBER -text [numbox_ftoa $self] -font [list $font $_($self:fs) bold] -fill [parse_color $_($self:fcol)]
+ $canvas delete ${self}CURS
+ if {[string length $_($self:buf)]>0} {
+ foreach {blah blah x3 blah} [$canvas bbox ${self}NUMBER] {}
+ $canvas create line $x3 $y1 $x3 $y2 -tags ${self}CURS -fill red
+ }
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ label_draw $self $canvas
+ set _($self:clickevent) numbox_click
+ set _($self:keyevent) numbox_key
+ set _($self:ungrabevent) numbox_ungrab
+ set _($self:motionevent) numbox_motion
+ set _($self:unclickevent) numbox_unclick
+ if {[canvas_isselected $canvas $self]} {set frcol $look(objectframe4)} {set frcol $look(objectframe3)}
+ $canvas itemconfigure ${self}BASE -outline $frcol
+ puts "/numbox_draw $self $canvas"
+ }
+
+ proc numbox_ftoa {self} {
+ global _
+ set f $_($self:val)
+ set is_exp 0
+ if {[string length $_($self:buf)]>0} {return $_($self:buf)}
+ set buf [format %g $f]
+ set bufsize [string length buf]
+ if {$bufsize >= 5} {
+ # exponential mode
+ set is_exp [regexp -nocase e]
+ }
+ if {$bufsize > $_($self:w)} {
+ # must shrink number
+ if {$is_exp} {
+ #if(x->x_gui.x_w <= 5) {x->x_buf[0] = (f < 0.0 ? '-' : '+'); x->x_buf[1] = 0;}
+ #i = bufsize - 4;
+ #for(idecimal=0; idecimal < i; idecimal++) if(x->x_buf[idecimal] == '.') break;
+ #if(idecimal > (x->x_gui.x_w - 4)) {
+ # x->x_buf[0]=f<0.0?'-':'+';x->x_buf[1] = 0;
+ #} {
+ # int new_exp_index=x->x_gui.x_w-4, old_exp_index=bufsize-4;
+ # for(i=0; i < 4; i++, new_exp_index++, old_exp_index++)
+ # x->x_buf[new_exp_index] = x->x_buf[old_exp_index];
+ # x->x_buf[x->x_gui.x_w] = 0;
+ #}
+ } {
+ #for(idecimal=0; idecimal < bufsize; idecimal++)
+ #if(x->x_buf[idecimal] == '.') break;
+ #if(idecimal > x->x_gui.x_w) {x->x_buf[0] = (f < 0.0 ? '-' : '+');
+ # x->x_buf[1] = 0;
+ #} {x->x_buf[x->x_gui.x_w] = 0;}
+ }
+ }
+ return $buf
+ }
+
+ proc numbox_erase {self canvas} {
+ $canvas delete ${self}BASE ${self}NUMBER ${self}BASE4
+ io_erase $self $canvas
+ label_erase $self $canvas
+ }
+
+ proc numbox_click {self canvas x y b f} {
+ global _
+ canvas_grab $canvas $self
+ $canvas itemconfigure ${self}BASE4 -fill #00ff00
+ set _($self:mouse) [list $x $y]
+ set _($self:oval) $_($self:val)
+ set _($self:clicking) 1
+ set _($self:rate) [expr $f&1 ? 0.01 : 1.00]
+ }
+
+ proc numbox_motion {self canvas x y mod} {
+ global _
+ set grabbed [expr ![string compare $self [canvas_grabber $canvas]]]
+ if {!$grabbed} {return}
+ foreach {ox oy} $_($self:mouse) {}
+ set _($self:val) [expr $_($self:val)-$_($self:rate)*($y-$oy)]
+ numbox_draw $self $canvas
+ set _($self:mouse) [list $x $y]
+ if {$_($self:clicking)} {pd "x$self float $_($self:val) ;"}
+ }
+
+ proc numbox_ungrab {self canvas} {
+ global _
+ set _($self:buf) ""
+ numbox_draw $self $canvas
+ }
+
+ proc numbox_unclick {self canvas x y} {
+ global _
+ set _($self:clicking) 0
+ if {$_($self:oval)!=$_($self:val)} {
+ canvas_ungrab $canvas
+ pd "x$self float $_($self:val) ;"
+ }
+ }
+
+ proc numbox_key {self canvas key shift} {
+ global _ look
+ set c -1
+ catch {set c [format %c $key]}
+ if {[string first $c 0123456789.eE+-]>=0} {
+ set _($self:buf) "$_($self:buf)$c"
+ numbox_draw $self $canvas
+ } elseif {$key==13} {
+ # Return
+ catch {set _($self:val) [expr $_($self:buf)]}
+ canvas_ungrab $canvas
+ pd "x$self float $_($self:val) ;"
+ } elseif {$key==8 || $key==127} {
+ # Backspace
+ if {[string length $_($self:buf)] >= 0} {
+ set _($self:buf) [string range $_($self:buf) 0 end-1]
+ }
+ numbox_draw $self $canvas
+ } elseif {$key==27} {
+ # Escape
+ set _($self:val) $_($self:oval)
+ canvas_ungrab $canvas
+ } else {
+ puts "numbox_key $key"
+ }
+ }
+
+ proc comment_draw {self canvas xs ys ins outs} {
+ if {[llength [$canvas gettags $self]] != 0} {}
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ }
+
+ proc comment_erase {self canvas} {}
+
+ proc bluebox_draw {self canvas x1 y1 xs ys ins outs} {
+ global _ look
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set xya [list $x1 $y1 $x2 $y2]
+ set xyb [list [expr $x2-1] [expr $y1+1] [expr $x1+1] [expr $y1+1] [expr $x1+1] [expr $y2-1]]
+ set xyc [list [expr $x2-1] [expr $y1+1] [expr $x2-1] [expr $y2-1] [expr $x1+1] [expr $y2-1]]
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ #puts "bluebox: [parse_color $_($self:bcol)] [parse_color $_($self:fcol)] [parse_color $_($self:lcol)]"
+ set color [bluify [parse_color $_($self:bcol)]]
+ if {$isnew} {
+ $canvas create rectangle $xya -tag ${self}BASE -fill $color
+ $canvas create line $xyb -tag ${self}BASE2 -fill #ffffff
+ $canvas create line $xyc -tag ${self}BASE3 -fill [darker $color]
+ } {
+ $canvas coords ${self}BASE $xya; $canvas itemconfigure ${self}BASE -fill $color
+ $canvas coords ${self}BASE2 $xyb; $canvas itemconfigure ${self}BASE2 -fill #ffffff
+ $canvas coords ${self}BASE3 $xyc; $canvas itemconfigure ${self}BASE3 -fill [darker $color]
+ }
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {[canvas_isselected $canvas $self]} {set frcol $look(objectframe4)} {set frcol $look(objectframe3)}
+ $canvas itemconfigure ${self}BASE -outline $frcol
+ }
+
+ proc bluebox_erase {self canvas} {
+ $canvas delete ${self}BASE ${self}BASE2 ${self}BASE3
+ io_erase $self $canvas
+ }
+
+ proc radio_orient {self} {
+ global _
+ switch $_($self:class) {
+ hradio {set orient 0} hdl {set orient 0}
+ vradio {set orient 1} vdl {set orient 1}
+ default {set orient 0}
+ }
+ return $orient
+ }
+
+ proc radio_draw {self canvas} {
+ global _
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ set orient [radio_orient $self]
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set n $_($self:n)
+ set xs [expr $_($self:w)*($orient?1:$n)]
+ set ys [expr $_($self:w)*($orient?$n:1)]
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ bluebox_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {$orient} {set size $ys} {set size $xs}
+ set size [expr $size/$n]
+ for {set i 0} {$i<$n} {incr i} {
+ if {$isnew} {
+ $canvas create rectangle \
+ [expr $x1+3] [expr $y1+3] \
+ [expr $x1+$size-3] [expr $y1+$size-3] \
+ -fill #ffffff -outline #000000 -tags "${self}BUT ${self}BUT$i"
+ } else {
+ $canvas coords ${self}BUT$i \
+ [expr $x1+3] [expr $y1+3] \
+ [expr $x1+$size-3] [expr $y1+$size-3]
+ }
+ if {$orient} {set y1 [expr $y1+$size]} {set x1 [expr $x1+$size]}
+ }
+ label_draw $self $canvas
+ radio_set $self $canvas $_($self:on)
+ set _($self:clickevent) radio_click
+ }
+
+ proc radio_set {self canvas value} {
+ $canvas itemconfigure ${self}BUT -fill #ffffff
+ $canvas itemconfigure ${self}BUT$value -fill #000000
+ }
+
+ proc radio_erase {self canvas} {
+ bluebox_erase $self $canvas
+ $canvas delete ${self}BUT
+ label_erase $self $canvas
+ }
+
+ proc radio_click {self canvas x y b f} {
+ global _
+ set x [expr $x-$_($self:x1)]
+ set y [expr $y-$_($self:y1)]
+ set orient [radio_orient $self]
+ set i [expr ($orient?$y:$x)/$_($self:w)]
+ pd "x$self fout $i ;"
+ }
+
+ proc clamp {x min max} {
+ if {$x<$min} {return $min}
+ if {$x>$max} {return $max}
+ return $x
+ }
+
+ proc slider_orient {self} {
+ global _
+ switch $_($self:class) {
+ vsl {set orient 1} default {set orient 0}
+ }
+ return $orient
+ }
+
+ proc slider_draw {self canvas} {
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ global _ look
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:h)
+ set orient [slider_orient $self]
+ if {$orient} {set y1 [expr $y1-2]} {set x1 [expr $x1-2]}
+ if {$orient} {set ys [expr $ys+5]} {set xs [expr $xs+5]}
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ switch $_($self:class) {hsl {set orient 0} vsl {set orient 1}}
+ bluebox_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {![info exists _($self:clicking)]} {set _($self:clicking) 0}
+ if {$isnew} {
+ set color [bluify #ffffff]
+ $canvas create rectangle $x1 $y1 $x1 $y1 -tags ${self}KNOB \
+ -outline #000000 -fill [darker $color]
+ }
+ label_draw $self $canvas
+ set _($self:clickevent) slider_click
+ set _($self:motionevent) slider_motion
+ set _($self:unclickevent) slider_unclick
+ set _($self:ungrabevent) slider_ungrab
+
+ set pos [$canvas coords ${self}BASE]
+ set span [expr $_($self:max)-$_($self:min)]
+ set l [expr $orient?$_($self:h):$_($self:w)]
+ set value [expr $_($self:val)*$span/($l-1)/100]
+ set _($self:value) $value
+ if {$orient} {
+ set size [expr [lindex $pos 2]-$x1]
+ set y1 [expr [lindex $pos 3]-$value*($l-1)/$span-2]
+ set y2 [expr $y1-2]
+ $canvas coords ${self}KNOB \
+ [expr $x1+2] $y1 [expr $x1+$size-2] $y2
+ } {
+ set size [expr [lindex $pos 3]-$y1]
+ set x1 [expr $x1+$value*($l-1)/$span]
+ set x2 [expr $x1+2]
+ set y2 [expr $y1+$size]
+ $canvas coords ${self}KNOB \
+ $x1 [expr $y1+2] $x2 [expr $y1+$size-2]
+ }
+ }
+
+ # not used
+ proc slider_draw_notches {self canvas} {
+ if {$orient} {
+ set thick [clamp [expr $xs/3] 1 5]
+ set x3 [expr $x1+$xs-$thick/2-2]
+ set eighth [expr round($ys/8-1)]
+ set coords [list $x3 $y1 $x3 [expr $y1+$ys]]
+ } else {
+ set thick [clamp [expr $ys/3] 1 5]
+ set y3 [expr $y1+$ys-$thick/2-2]
+ set eighth [expr $xs/8]
+ set coords [list $x1 $y3 [expr $x1+$xs] $y3]
+ }
+ $canvas create line $coords -dash [list 1 $eighth 1 $eighth] -width $thick -fill [darker $look(sliderbg)]
+ }
+
+ proc slider_erase {self canvas} {
+ bluebox_erase $self $canvas
+ label_erase $self $canvas
+ $canvas delete ${self}KNOB
+ }
+
+ proc slider_click {self canvas x y b f} {
+ global _
+ canvas_grab $canvas $self
+ set _($self:first) [list $x $y]
+ set _($self:ovalue) $_($self:value)
+ set _($self:clicking) 1
+ set _($self:rate) [expr $f&1 ? 0.01 : 1.00]
+ }
+
+ proc slider_unclick {self canvas x y} {
+ global _
+ set _($self:clicking) 0
+ if {[lindex $_($self:first) 1] != $y} {
+ canvas_ungrab $canvas
+ pd "x$self float $_($self:value) ;"
+ }
+ }
+
+ proc slider_motion {self canvas x y mods} {
+ global _
+ set grabbed [expr ![string compare $self [canvas_grabber $canvas]]]
+ if {!$grabbed} {return}
+ set dx [expr $x-[lindex $_($self:first) 0]]
+ set dy [expr $y-[lindex $_($self:first) 1]]
+ set orient [slider_orient $self]
+ set span [expr $_($self:max)-$_($self:min)]
+ set l [expr $orient?$_($self:h):$_($self:w)]
+ set d [expr ($orient?-$dy:$dx)*$span/($l+0.0)]
+ set _($self:value) [expr $_($self:ovalue)+$d*$_($self:rate)]
+ pd "x$self float $_($self:value) ;"
+ }
+
+ proc slider_ungrab {self canvas} {
+ global _
+ slider_draw $self $canvas
+ }
+
+ proc label_draw {self canvas} {
+ global _
+ set isnew [expr [llength [$canvas gettags ${self}LABEL]] == 0]
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set lx [expr $x1+$_($self:ldx)]
+ set ly [expr $y1+$_($self:ldy)]
+ set label $_($self:lab); switch -- $label { empty { set label "" }}
+ set lfont [list \
+ [lindex {courier helvetica times} $_($self:fstyle)] \
+ $_($self:fs) bold]
+ set lcolor [parse_color $_($self:lcol)]
+ if {$isnew} {
+ $canvas create text $lx $ly -text $label -anchor w \
+ -font $lfont -fill $lcolor -tags ${self}LABEL
+ } {
+ $canvas coords ${self}LABEL $lx $ly
+ $canvas itemconfigure ${self}LABEL -text $label -anchor w \
+ -font $lfont -fill $lcolor
+ }
+ }
+
+ proc label_erase {self canvas} {
+ $canvas delete ${self}LABEL
+ }
+
+ proc bang_draw {self canvas} {
+ global _
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:w)
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ set colour [parse_color $_($self:bcol)]
+ bluebox_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ if {$isnew} {
+ $canvas create oval \
+ [expr $x1+2] [expr $y1+2] [expr $x2-2] [expr $y2-2] \
+ -fill [bluify $colour] -tags ${self}BUT
+ } {
+ $canvas coords ${self}BUT \
+ [expr $x1+2] [expr $y1+2] [expr $x2-2] [expr $y2-2]
+ }
+ label_draw $self $canvas
+ set _($self:clickevent) bang_click
+ }
+
+ proc bang_erase {self canvas} {
+ bluebox_erase $self $canvas
+ io_erase $self $canvas
+ $canvas delete ${self}BUT ${self}LABEL
+ }
+
+ proc bang_click {self canvas x y b f} {
+ pd "x$self click $x $y 0 0 0 ;"
+ }
+
+ proc bang_bang {self canvas} {
+ global _
+ $canvas itemconfigure ${self}BUT -fill [bluify [parse_color $_($self:fcol)]]
+ after 300 [list $canvas itemconfigure ${self}BUT -fill [bluify [parse_color $_($self:bcol)]]]
+ }
+
+ proc toggle_draw {self canvas} {
+ global _
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:w)
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ set colour [parse_color $_($self:bcol)]
+ bluebox_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ io_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ set w 1
+ if {$xs >= 30} {set w 2}
+ if {$xs >= 60} {set w 3}
+ set fill [bluify $colour]
+ set x3 [expr $x1+$w+2]
+ set y3 [expr $y1+$w+2]
+ set x4 [expr $x2-$w-2]
+ set y4 [expr $y2-$w-2]
+ if {$isnew} {
+ $canvas create line $x3 $y3 [expr $x4+1] [expr $y4+1] -width $w -fill $fill -tags ${self}X1
+ $canvas create line $x3 $y4 [expr $x4+1] [expr $y3-1] -width $w -fill $fill -tags ${self}X2
+ } {
+ $canvas coords ${self}X1 $x3 $y3 [expr $x4+1] [expr $y4+1]
+ $canvas coords ${self}X2 $x3 $y4 [expr $x4+1] [expr $y3-1]
+ }
+ label_draw $self $canvas
+ if {$_($self:on)} {
+ set fill [parse_color $_($self:fcol)]
+ } {
+ set fill [bluify [parse_color $_($self:bcol)]]
+ }
+ $canvas itemconfigure ${self}X1 -fill $fill
+ $canvas itemconfigure ${self}X2 -fill $fill
+
+ set _($self:clickevent) toggle_click
+ }
+
+
+ proc toggle_erase {self canvas} {
+ bluebox_erase $self $canvas
+ io_erase $self $canvas
+ $canvas delete ${self}BUT ${self}LABEL ${self}X1 ${self}X2
+ }
+
+ proc toggle_click {self canvas x y b f} {
+ pd "x$self bang ;"
+ }
+
+ set vu_col {
+ 0 17 16 16 16 16 16 16 16 16 16 16 16 16 16 16 16
+ 15 15 15 15 15 15 15 15 15 15 14 14 13 13 13 13 13 13 13 13 13 13 13 19 19 19
+ }
+
+ proc vu_led_size {self} {
+ global _
+ set n [expr $_($self:h)/40]
+ if {$n < 2} {set n 2}
+ return [expr $n-1]
+ }
+
+ proc vu_draw {self canvas} {
+ global _
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:h)
+ set x2 [expr $x1+$xs]
+ set y2 [expr $y1+$ys]
+ set ins [expr 2*([string compare $_($self:rcv) empty]==0)]
+ set outs 2
+ #[expr [string compare $_($self:snd) empty]==0]
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ set colour [parse_color $_($self:bcol)]
+ # bluebox_draw $self $canvas $x1 $y1 $xs $ys $ins $outs
+ bluebox_draw $self $canvas [expr $x1-1] [expr $y1-2] [expr $xs+2] [expr $ys+4] $ins $outs
+ label_draw $self $canvas
+
+ set led_size [vu_led_size $self]
+ set x3 [expr $x1+$xs/4]
+ set x4 [expr $x1+$xs-$xs/4]
+ global vu_col
+
+ $canvas delete ${self}RMS
+ for {set i 1} {$i<=40} {incr i} {
+ set y [expr $y1 + ($led_size+1)*(41-$i) - ($led_size+1)/2]
+ $canvas create rectangle $x3 $y $x4 [expr $y+$led_size] \
+ -fill [parse_color [lindex $vu_col $i]] -tags ${self}RMS -width 0
+ }
+
+ if {$isnew} {
+ $canvas create rectangle $x3 $y1 $x4 $y1 -tags ${self}MASK \
+ -width 0 -fill [bluify $colour]
+ } {
+ $canvas coords ${self}MASK $x3 $y1 $x4 $y1
+ }
+
+ if {!$_($self:scale)} {return}
+
+ $canvas delete ${self}SCALE
+ set lfont [list \
+ [lindex {courier helvetica times} $_($self:fstyle)] \
+ $_($self:fs) bold]
+ set lcolor [parse_color $_($self:lcol)]
+ set i 0
+ foreach level { <-99 -50 -30 -20 -12 -6 -2 -0dB +2 +6 >+12 } {
+ set k1 [expr $led_size+1]
+ set k2 41
+ set k3 [expr $k1/2]
+ set k4 [expr $y1-$k3]
+ set yyy [expr $k4 + $k1*($k2-4*$i)]
+ $canvas create text [expr $x2+4] [expr $yyy+$k3-3] -text $level -anchor w \
+ -font $lfont -fill $lcolor -tags ${self}SCALE
+ incr i
+ }
+ #vu_set 0
+ #vu_peak 0
+ }
+
+ proc vu_set {self canvas i j} {
+ global _ vu_col
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:h)
+ set led_size [vu_led_size $self]
+
+ set y [expr $y1 + ($led_size+1)*(41-$i) - ($led_size+1)/2]
+ set x3 [expr $x1+$xs/4]
+ set x4 [expr $x1+$xs-$xs/4]
+ $canvas coords ${self}MASK $x3 $y1 $x4 $y
+
+ $canvas delete ${self}PEAK
+ set c [lindex $vu_col $j]
+ if {!$j} {return}
+ set y1 [expr $y1 + ($led_size+1)*(41-$j) - ($led_size+1)/2]
+ $canvas create rectangle $x1 $y1 [expr $x1+$xs] [expr $y1+$led_size] \
+ -fill [parse_color $c] -tags ${self}PEAK -width 0
+ }
+
+ proc vu_erase {self canvas} {
+ bluebox_erase $self $canvas
+ label_erase $self $canvas
+ $canvas delete ${self}SCALE ${self}RMS ${self}MASK
+ }
+
+ catch {
+ package require tkdnd
+ dnd bindtarget . text/uri-list <Drop> {open_file %D}
+ }
+
+ proc dropper_draw {self canvas} {
+ global _
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set colour [parse_color $_($self:fcol)]
+ set lcolour [parse_color $_($self:lcol)]
+ set ins [expr [string compare $_($self:rcv) empty]==0]
+ set outs [expr [string compare $_($self:snd) empty]==0]
+ bluebox_draw $self $canvas $x1 $y1 [expr $xs + 1] [expr $xs + 1] $ins $outs
+ if {$isnew} {
+ canvas $canvas.${self}DROP -width $xs -height $xs -bg $colour -highlightbackground $lcolour -highlightcolor $colour
+ $canvas create window [expr $x1 + 7] [expr $y1 - 2] -window $canvas.${self}DROP -anchor nw -tags $canvas.${self}window
+ dnd bindtarget $canvas.${self}DROP text/uri-list <Drop> "pd \"x[list ${self}] symbol \[ pdtk_enquote %D \] ;\""
+ } {
+ $canvas coords $canvas.${self}window [expr $x1 + 7] [expr $y1 - 2]
+ $canvas.${self}DROP configure -width $xs -height $xs -bg $colour -highlightbackground $lcolour -highlightcolor $colour
+ }
+ return
+ }
+
+ proc dropper_erase {self canvas} {
+ bluebox_erase $self $canvas
+ destroy $canvas.${self}DROP
+ $canvas delete ${self}window
+ }
+
+ proc cnv_draw {self canvas} {
+ global _
+ foreach {x1 y1} [object_xy $self $canvas] {}
+ set xs $_($self:w)
+ set ys $_($self:h)
+ set isnew [expr [llength [$canvas gettags ${self}BASE]] == 0]
+ if {$isnew} {
+ $canvas create rectangle $x1 $y1 [expr $x1+$xs] [expr $y1+$ys] \
+ -tags ${self}BASE -fill [parse_color $_($self:bcol)]
+ } {
+ $canvas coords ${self}BASE $x1 $y1 [expr $x1+$xs] [expr $y1+$ys]
+ }
+ label_draw $self $canvas
+ }
+
+ proc cnv_erase {self canvas} {
+ label_erase $self $canvas
+ $canvas delete ${self}BASE ${self}LABEL
+ }
+
More information about the Pd-cvs
mailing list