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 + } +