[PD-cvs] pd/src desire.tk, 1.1.2.344, 1.1.2.345 objective.tcl, 1.1.2.13, 1.1.2.14
Mathieu Bouchard
matju at users.sourceforge.net
Tue Aug 15 21:47:33 CEST 2006
Update of /cvsroot/pure-data/pd/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22320
Modified Files:
Tag: devel_0_39
desire.tk objective.tcl
Log Message:
fixed bug of canvas items gradually disappearing due to conflict between
objective.tcl's pointers and canvas tags interpreted as octal indices.
Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.344
retrieving revision 1.1.2.345
diff -C2 -d -r1.1.2.344 -r1.1.2.345
*** desire.tk 15 Aug 2006 17:47:23 -0000 1.1.2.344
--- desire.tk 15 Aug 2006 19:47:31 -0000 1.1.2.345
***************
*** 1936,1944 ****
eval $@dehighlight
set @dehighlight {}
- # backup values
set oldpos $@curpos
set @curpos [list $x $y]
# detects if the focus is not on the canvas itself in run mode, ie. numbox
if {!$@editmode & [$self focus] != $self & [$self focus] != ""} {[$self focus] motion $x $y $f}
switch $@action {
move {
--- 1936,1945 ----
eval $@dehighlight
set @dehighlight {}
set oldpos $@curpos
set @curpos [list $x $y]
# detects if the focus is not on the canvas itself in run mode, ie. numbox
if {!$@editmode & [$self focus] != $self & [$self focus] != ""} {[$self focus] motion $x $y $f}
+ set target [$self identify_target $x $y $f "motion"]
+ mset {type id detail} $target
switch $@action {
move {
***************
*** 1957,1966 ****
#default {error "unknown action '$@action'"}
default {
- set target [$self identify_target $x $y $f "motion"]
$@action motion $x $y $f $target
}
}
- set target [$self identify_target $x $y -1 "move"]
- mset {type id detail} $target
switch $type {
inlet {set port [$id hilite_io i $x $y]; set @dehighlight [list $c delete ${id}i${port}b]}
--- 1958,1964 ----
***************
*** 1988,2004 ****
foreach tag $stack {
set tags [$c gettags $tag]
! if {[regexp {^x([a-f0-9]{6,8})} $tags id]} {
! if {[info exists _($id:pdclass)]} {set class $_($id:pdclass)} {set class unknown}
! mset {x1 y1 x2 y2} [$id bbox]
! set outs [$id noutlets]
! set ins [$id ninlets]
! if {$y>=$y2-6 && $outs} {return [list "outlet" $id [expr int(($x-$x1)*$outs/($x2-$x1))]]}
! if {$y< $y1+2 && $ins} {return [list "inlet" $id [expr int(($x-$x1)* $ins/($x2-$x1))]]}
! return [list "object" $id]
}
}
foreach tag $stack {
set tags [$c gettags $tag]
- if {[regexp {^([0-9a-f]{6,8})} $tags id]} {return [list "wire" $id]}
}
return [list "nothing"]
--- 1986,2007 ----
foreach tag $stack {
set tags [$c gettags $tag]
! if {[regexp {^[xo][0-9a-f]{6,8}} $tags id]} {
! # prior to Aug 15th, Wires had lower priority as all objects together
! # now it's same priority, so just stacking order (and it's prolly wrong)
! set class [$id _class]
! if {[$class inherit? Wire]} {return [list "wire" $id]}
! if {[$class inherit? Box]} {
! mset {x1 y1 x2 y2} [$id bbox]
! set outs [$id noutlets]
! set ins [$id ninlets]
! if {$y>=$y2-6 && $outs} {return [list "outlet" $id [expr int(($x-$x1)*$outs/($x2-$x1))]]}
! if {$y< $y1+2 && $ins} {return [list "inlet" $id [expr int(($x-$x1)* $ins/($x2-$x1))]]}
! return [list "object" $id]
! }
! puts "skipped a $class"
}
}
foreach tag $stack {
set tags [$c gettags $tag]
}
return [list "nothing"]
***************
*** 2007,2011 ****
def Canvas identify_target {x y f label} {
set r [$self identify_target2 $x $y $f $label]
! #puts "\[identify_target $x $y $f $label\] returns: $r"
return $r
}
--- 2010,2014 ----
def Canvas identify_target {x y f label} {
set r [$self identify_target2 $x $y $f $label]
! puts "\[identify_target $x $y $f $label\] returns: $r"
return $r
}
***************
*** 2035,2048 ****
$self addw 1 action 4 " Action: "
$self addw 1 sel 4 " Sel: "
! $self addw 2 wfrom 12 " WireFrom: "
! $self addw 2 wto 12 " WireTo: "
}
def Canvas statusbar_draw {x y} {$@statusbar draw $x $y}
def Canvas action {} {return $@action}
- #def Canvas wire_from {} {return $@wire_from}
- #def Canvas wire_to {} {return $@wire_to}
- def Canvas wire_from {} {return somewhere.}
- def Canvas wire_to {} {return someplace.}
def Canvas scale {} {return $@scale}
--- 2038,2047 ----
$self addw 1 action 4 " Action: "
$self addw 1 sel 4 " Sel: "
! #$self addw 2 wfrom 12 " WireFrom: "
! #$self addw 2 wto 12 " WireTo: "
}
def Canvas statusbar_draw {x y} {$@statusbar draw $x $y}
def Canvas action {} {return $@action}
def Canvas scale {} {return $@scale}
***************
*** 2071,2076 ****
$f.1.action configure -text [$@canvas action]
$f.1.sel configure -text [llength [$@canvas selection]]
! $f.2.wfrom configure -text [$@canvas wire_from]
! $f.2.wto configure -text [$@canvas wire_to]
}
--- 2070,2075 ----
$f.1.action configure -text [$@canvas action]
$f.1.sel configure -text [llength [$@canvas selection]]
! #$f.2.wfrom configure -text [$@canvas wire_from]
! #$f.2.wto configure -text [$@canvas wire_to]
}
***************
*** 2332,2336 ****
mset {x1 y1 x2 y2} [$c bbox ${obj1}o${outlet}]
$c create line [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] $x $y -dash {4 4 4 4} -tags lnew -fill [look wiredash]
! set @wire_from [list $obj1 $outlet]
set @action wire
}
--- 2331,2335 ----
mset {x1 y1 x2 y2} [$c bbox ${obj1}o${outlet}]
$c create line [expr ($x1+$x2)/2] [expr ($y1+$y2)/2] $x $y -dash {4 4 4 4} -tags lnew -fill [look wiredash]
! #set @wire_from [list $obj1 $outlet]
set @action wire
}
Index: objective.tcl
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/objective.tcl,v
retrieving revision 1.1.2.13
retrieving revision 1.1.2.14
diff -C2 -d -r1.1.2.13 -r1.1.2.14
*** objective.tcl 21 Jun 2006 06:05:59 -0000 1.1.2.13
--- objective.tcl 15 Aug 2006 19:47:31 -0000 1.1.2.14
***************
*** 58,62 ****
proc ${self}_new {args} "
global nextid _
! set self \[format %08x \$nextid\]
incr nextid
set _(\$self:_class) $self
--- 58,62 ----
proc ${self}_new {args} "
global nextid _
! set self \[format o%07x \$nextid\]
incr nextid
set _(\$self:_class) $self
***************
*** 117,125 ****
class_new Thing {}
#set _(Thing:_super) {}
! def* Thing init {} {}
def Thing == {other} {return [expr ![string compare $self $other]]}
# virtual destructor
! def* Thing _delete {} {}
def Thing _vars {} {
--- 117,125 ----
class_new Thing {}
#set _(Thing:_super) {}
! def Thing init {} {}
def Thing == {other} {return [expr ![string compare $self $other]]}
# virtual destructor
! def Thing _delete {} {}
def Thing _vars {} {
***************
*** 139,144 ****
--- 139,157 ----
}
+ def Thing _class {} {return $@_class}
+
class_new Class
def Class subclasses {} {return $@subclasses}
+ def Class inherit? {class} {
+ return [expr [lsearch [$self ancestors] $class]>=0]
+ }
+
+ def Class ancestors {} {
+ set r [list $self]
+ foreach super $@_super {eval [concat [list lappend r] [$super ancestors]]}
+ return $r
+ }
+
+ # those are static methods, and objective.tcl doesn't distinguish them yet.
def Class new { args} {eval [concat [list ${self}_new ] $args]}
def Class new_as {id args} {eval [concat [list ${self}_new_as $id] $args]}
More information about the Pd-cvs
mailing list