[PD-cvs] pd/src objective.tcl, NONE, 1.1.2.1 desire.tk, 1.1.2.82, 1.1.2.83

Thu Oct 13 09:03:27 CEST 2005

Update of /cvsroot/pure-data/pd/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2744

Modified Files:
      Tag: devel_0_39
	desire.tk 
Added Files:
      Tag: devel_0_39
	objective.tcl 
Log Message:
just made Objective Tcl a separate file

Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.82
retrieving revision 1.1.2.83
diff -C2 -d -r1.1.2.82 -r1.1.2.83
*** desire.tk	27 Sep 2005 11:07:34 -0000	1.1.2.82
--- desire.tk	13 Oct 2005 07:03:25 -0000	1.1.2.83
***************
*** 17,108 ****
  # if {$tcl_version < 8.5} {source pre8.5.tcl}

! #-----------------------------------------------------------------------------------#
! # OBJECT ORIENTED PROGRAMMING IN TCL (by Mathieu Bouchard)
! # (please distinguish between what this is and what dataflow is)
! # note, the toplevel class is called "thing".
! 
! set nextid 0
! set _(class:_class) class
! set _(class:_super) {thing}
! 
! proc class_new {self {super {thing}}} {
! 	global _
! 	set _($self:_class) class
! 	set _($self:_super) $super
! 	proc ${self}_new {args} "
! 		global nextid _
! 		set self \[format %08x \$nextid\]
! 		incr nextid
! 		set _(\$self:_class) $self
! 		eval [concat [list \$self init] \$args]
! 	"
! 	proc ${self}_new_as {self args} "
! 		global _
! 		set _(\$self:_class) $self
! 		eval [concat [list \$self init] \$args]
! 	"
! }
! 
! proc proc* {name args body} {
! 	set argl {}
! 	foreach arg $args {lappend argl "$arg=\$$arg"}
! 	proc $name $args "puts \"CALL TO PROC $name [join $argl " "]\"; $body"
! }
! 
! proc def {class selector args body} {
! 	proc ${class}_$selector "self $args" \
! 		"global _; [regsub -all @(\\w+) $body _(\$self:\\1)]"
! }
! 
! proc def* {class selector args body} {
! 	proc* ${class}_$selector "self $args" \
! 		"global _; [regsub -all @(\\w+) $body _(\$self:\\1)]"
! }
! 
! proc lookup_method {class selector methodsv ancestorsv} {
! 	global _
! 	upvar $methodsv   methods
! 	upvar $ancestorsv ancestors
! 	set name ${class}_$selector
! 	if {[llength [info procs $name]]} {lappend methods $name}
! 	lappend ancestors $class
! 	foreach super $_($class:_super) {lookup_method $super $selector methods ancestors}
! }
! 
! rename unknown _original_unknown
! # TODO: remove duplicates in lookup
! # TODO: cache lookup for greater speed
! proc unknown {args} {
! 	global _
! 	set self [lindex $args 0]
! 	if {"$self" == ""} {error "null pointer you black emperor"}
! 	set selector [lindex $args 1]
! 	if {[llength [array names _ $self:_class]] == 0} {
! 		return [uplevel 1 [linsert $args 0 _original_unknown]]
! 	}
! 	set methods {}
! 	set ancestors {}
! 	lookup_method $_($self:_class) $selector methods ancestors
! 	set i 0
! 	if {![llength $methods]} {
! 		error "no such method '$selector' for object '$self'\nwith ancestors {$ancestors}"
! 	}
! 	set name [lindex $methods $i]
! 	set r [eval [concat [list $name $self] [lrange $args 2 end]]]
! 	return $r
! }
! 
! proc super {args} {
! 	upvar 2 methods methods self self i oi
! 	set i [expr 1+$oi]
! 	if {[llength $methods] < $i} {error "no more supermethods"}
! 	set name [lindex $methods $i]
! 	set r [eval [concat [list $name $self] $args]]
! }
! 
! class_new thing
! set _(thing:_super) {}
! # virtual destructor
! def* thing _delete {} {}

  #-----------------------------------------------------------------------------------#
--- 17,21 ----
  # if {$tcl_version < 8.5} {source pre8.5.tcl}

! source objective.tcl

  #-----------------------------------------------------------------------------------#
***************
*** 152,156 ****

  def observable notify {} {
! 	set dirty [lsort -uniq $dirty]
  	if {$dirty == "(all)"} {
  		foreach x $@subscribers {$x notice $self}
--- 65,69 ----

  def observable notify {} {
! 	set dirty [lsort -uniq $@dirty]
  	if {$dirty == "(all)"} {
  		foreach x $@subscribers {$x notice $self}
***************
*** 158,161 ****
--- 71,75 ----
  		foreach x $@subscribers {foreach k $dirty {$x notice $self $k}}
  	}
+ 	set @dirty {}
  }

***************
*** 1705,1712 ****
        }
      }
      set size [$c bbox all]
      if {$size != ""} {
- 	# not entirely sure what this is, but it executes when there are objects
- 	# on canvas and there is an unclick --chun
  	set xmin 0; set xmax 100
      	set ymin 0; set ymax 100
--- 1619,1631 ----
        }
      }
+     $self adjust_scrollbars
+     $self checkgeometry
+     set @action none
+ }
+ 
+ def canvas adjust_scrollbars {} {
+     set c .x$self.c
      set size [$c bbox all]
      if {$size != ""} {
  	set xmin 0; set xmax 100
      	set ymin 0; set ymax 100
***************
*** 1716,1726 ****
      	if {$y1 < 0} {set ymin $y1}; if {$y2 > 100} {set ymax $y2}
  	set bbox [list $xmin $ymin $xmax $ymax]
!     	if {$@bbox != $bbox } {
  	    	$c configure -scrollregion $bbox
  	    	set @bbox $bbox
      	}
      }
-     $self checkgeometry
-     set @action none
  }

--- 1635,1643 ----
      	if {$y1 < 0} {set ymin $y1}; if {$y2 > 100} {set ymax $y2}
  	set bbox [list $xmin $ymin $xmax $ymax]
!     	if {$@bbox != $bbox} {
  	    	$c configure -scrollregion $bbox
  	    	set @bbox $bbox
      	}
      }
  }

--- NEW FILE: objective.tcl ---
#----------------------------------------------------------------#
# OBJECTIVE TCL
#
#   Copyright (c) 2005 by Mathieu Bouchard
#   This software has no license yet
#   And is not covered by the license on the rest of PureData.
#   All Rights Reserved (for now)

#-----------------------------------------------------------------------------------#
# OBJECT ORIENTED PROGRAMMING IN TCL (by Mathieu Bouchard)
# (please distinguish between what this is and what dataflow is)
# note, the toplevel class is called "thing".

set nextid 0
set _(class:_class) class
set _(class:_super) {thing}

proc class_new {self {super {thing}}} {
	global _
	set _($self:_class) class
	set _($self:_super) $super
	proc ${self}_new {args} "
		global nextid _
		set self \[format %08x \$nextid\]
		incr nextid
		set _(\$self:_class) $self
		eval [concat [list \$self init] \$args]
	"
	proc ${self}_new_as {self args} "
		global _
		set _(\$self:_class) $self
		eval [concat [list \$self init] \$args]
	"
}

proc proc* {name args body} {
	set argl {}
	foreach arg $args {lappend argl "$arg=\$$arg"}
	proc $name $args "puts \"CALL TO PROC $name [join $argl " "]\"; $body"
}

proc def {class selector args body} {
	proc ${class}_$selector "self $args" \
		"global _; [regsub -all @(\\w+) $body _(\$self:\\1)]"
}

proc def* {class selector args body} {
	proc* ${class}_$selector "self $args" \
		"global _; [regsub -all @(\\w+) $body _(\$self:\\1)]"
}

proc lookup_method {class selector methodsv ancestorsv} {
	global _
	upvar $methodsv   methods
	upvar $ancestorsv ancestors
	set name ${class}_$selector
	if {[llength [info procs $name]]} {lappend methods $name}
	lappend ancestors $class
	foreach super $_($class:_super) {lookup_method $super $selector methods ancestors}
}

rename unknown _original_unknown
# TODO: remove duplicates in lookup
# TODO: cache lookup for greater speed
proc unknown {args} {
	global _
	set self [lindex $args 0]
	if {"$self" == ""} {error "null pointer you black emperor"}
	set selector [lindex $args 1]
	if {[llength [array names _ $self:_class]] == 0} {
		return [uplevel 1 [linsert $args 0 _original_unknown]]
	}
	set methods {}
	set ancestors {}
	lookup_method $_($self:_class) $selector methods ancestors
	set i 0
	if {![llength $methods]} {
		error "no such method '$selector' for object '$self'\nwith ancestors {$ancestors}"
	}
	set name [lindex $methods $i]
	set r [eval [concat [list $name $self] [lrange $args 2 end]]]
	return $r
}

proc super {args} {
	upvar 2 methods methods self self i oi
	set i [expr 1+$oi]
	if {[llength $methods] < $i} {error "no more supermethods"}
	set name [lindex $methods $i]
	set r [eval [concat [list $name $self] $args]]
}

class_new thing
set _(thing:_super) {}
# virtual destructor
def* thing _delete {} {}