pd/src objective.tcl, NONE, 1.1.2.1 desire.tk, 1.1.2.82, 1.1.2.83 - Pd-cvs

13 Oct 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 {} {}