[PD-cvs] pd/src desire.tk,1.1.2.39,1.1.2.40
Mathieu Bouchard
matju at users.sourceforge.net
Sat Sep 10 22:30:42 CEST 2005
Update of /cvsroot/pure-data/pd/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20849
Modified Files:
Tag: devel_0_39
desire.tk
Log Message:
added the properties dialog generator (for future use)
Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.39
retrieving revision 1.1.2.40
diff -C2 -d -r1.1.2.39 -r1.1.2.40
*** desire.tk 10 Sep 2005 18:18:27 -0000 1.1.2.39
--- desire.tk 10 Sep 2005 20:30:40 -0000 1.1.2.40
***************
*** 3005,3011 ****
set ins [expr 2*([string compare $@rcv empty]==0)]
set outs 2
- #[expr [string compare $@snd empty]==0]
set colour [parse_color $@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
--- 3005,3009 ----
***************
*** 3491,3492 ****
--- 3489,3616 ----
}
+ ############ properties_dialog #########
+
+ proc color_popup_select {self name c} {
+ global _ preset_colors
+ set _($self:$name) $c
+ .$self.$name.color configure \
+ -background [format #%6.6x $_($self:$name)] \
+ -highlightbackground [format #%6.6x $_($self:$name)]
+ }
+
+ proc color_popup {self w name i} {
+ set w $w.$name.popup
+ if [winfo exists $w] {destroy $w}
+ menu $w -tearoff false
+ global preset_colors
+ for {set i 0} {$i<[llength $preset_colors]} {incr i} {
+ set c [lindex $preset_colors $i]
+ $w add command -label " " \
+ -background "#$c" -foreground "#$c" \
+ -command [list color_popup_select $self $name [expr 0x$c]]
+ }
+ tk_popup $w \
+ [expr [winfo rootx .$self.$name]] \
+ [expr [winfo rooty .$self.$name]] 0
+ }
+
+ proc iemgui_choose_col {id var title} {
+ set self [string trimleft $id .]
+ global _
+ set c $_($self:$var)
+ if {[string index $c 0]=="#"} {set c [string replace $c 0 0 0x]}
+ set color [tk_chooseColor -title $title \
+ -initialcolor [format "#%6.6x" [expr $c&0xFFFFFF]]]
+ if {$color != ""} {
+ color_popup_select $self $var [expr [string replace $color 0 0 "0x"]&0xFFFFFF]
+ }
+ }
+
+ proc change_entry {self val} {
+ set v [expr [$self get]+$val]
+ $self delete 0 end
+ $self insert 0 $v
+ }
+
+ proc properties_dialog {self w ok struct} {
+ global _
+ foreach {name label type options} $struct {
+ set f $w.$name
+ switch -- $type {
+ side {
+ frame $f
+ label $f.label -text $label
+ pack $f.label -side left
+ frame $f.side -relief ridge -borderwidth 2
+ foreach {i side} {0 left 1 right 2 top 3 bottom} {
+ radiobutton $f.side.$side -value $i \
+ -variable _($self:$name) -text $side
+ }
+ pack $f.side.left -side left -fill y
+ pack $f.side.right -side right -fill y
+ pack $f.side.top -side top
+ pack $f.side.bottom -side bottom
+ pack $f.side -side left
+ }
+ color {
+ frame $f
+ label $f.label -text $label
+ # wtf, %6.6x sometimes gives me _8_ chars !?!
+ set c $_($self:$name)
+ switch -regexp -- $c { ^# { set c 0x[string trimleft $c #] } }
+ set c [expr $c & 0xFCFCFC]
+ button $f.color -text " " -font {Courier 8} -width 10 -pady 2 \
+ -command [list iemgui_choose_col $w $name $label] \
+ -relief sunken -background [format #%6.6x $c] \
+ -highlightbackground [format #%6.6x $c]
+
+ button $f.preset -text "..." -pady 2 -font {Helvetica 8} -command [list color_popup $self $w $name $i]
+ pack $f.label $f.color $f.preset -side left
+ }
+ choice {
+ frame $f
+ set i 0
+ label $f.label -text [lindex $label 0]
+ pack $f.label $f -side left
+ foreach part [lrange $label 1 end] {
+ radiobutton $f.$i -text $part -value $i -variable _($self:$name) -anchor w
+ pack $f.$i -side top -fill x
+ incr i
+ }
+ }
+ toggle {
+ frame $f
+ label $f.label -text $label
+ checkbutton $f.toggle -variable _($self:name)
+ }
+ section {
+ label $f -text $label -bg "#0000aa" -fg "#ffff55" -font {helvetica -10 bold}
+ }
+ default {
+ frame $f
+ label $f.label -text $label
+ pack $f.label -side left
+ eval "entry $f.entry -textvariable _($self:$name) $options"
+ pack $f.entry -side left
+ bind $f.entry <Return> "$ok $w"
+ switch -regexp -- $type {
+ integer|float|fontsize {
+ frame $f.b -borderwidth 0
+ button $f.b.1 -image icon_uparrow -command "change_entry $f.entry +1"
+ button $f.b.2 -image icon_downarrow -command "change_entry $f.entry -1"
+ pack $f.b.1 $f.b.2 -side top
+ pack $f.b -side left
+ }
+ entry {}
+ default {
+ label $f.type -text "($type)" -fg "#808080"
+ pack $f.type -side right -anchor e
+ }
+ }
+ }
+ }
+ pack $f -side top -fill x
+ catch {$f.label configure -width 15 -anchor e}
+ }
+ }
+
More information about the Pd-cvs
mailing list