pd/src desire.tk, 1.1.2.344, 1.1.2.345 objective.tcl, 1.1.2.13, 1.1.2.14 - Pd-cvs

15 Aug 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]}