[PD-cvs] pd/src desire.tk,1.1.2.199,1.1.2.200

[Mathieu Bouchard]

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

Modified Files:
      Tag: devel_0_39
	desire.tk 
Log Message:
[lastlevel] gives the length of the callstack minus one
Tcl box now evals in the global frame using [lastlevel]


Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.199
retrieving revision 1.1.2.200
diff -C2 -d -r1.1.2.199 -r1.1.2.200
*** desire.tk	6 May 2006 23:46:40 -0000	1.1.2.199
--- desire.tk	7 May 2006 04:36:09 -0000	1.1.2.200
***************
*** 18,22 ****
--- 18,29 ----
  #-----------------------------------------------------------------------------------#
  # some list processing functions and some math too
+ # these could become another library like objective.tcl
+ # if they become substantial enough
  
+ # min finds the smallest of two values
+ # max finds the biggest of two values
+ # [clip $v $min $max] does [max $min [min $max $v]]
+ proc min {x y} {if {$x<$y} {return $x} {return $y}}
+ proc max {x y} {if {$x>$y} {return $x} {return $y}}
  proc clip {x min max} {
  	if {$x<$min} {return $min}
***************
*** 24,37 ****
  	return $x
  }
! proc min {x y} {if {$x<$y} {return $x} {return $y}}
! proc max {x y} {if {$x>$y} {return $x} {return $y}}
  proc mset {vars list} {uplevel 1 "foreach {$vars} {$list} {}"}
  proc l+   {   al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a +   $b]}; return $r}
  proc l-   {   al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a -   $b]}; return $r}
  proc lzip {op al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a $op $b]}; return $r}
  proc lmap {op al   } {set r {}; foreach a $al b $bl {lappend r [expr $a $op   ]}; return $r}
  proc l/2  {   al   } {set r {}; foreach a $al       {lappend r [expr $a /    2]}; return $r}
  proc lsum  {al} {set r 0; foreach a $al {set r [expr $r+$a]}; return $r}
  proc lprod {al} {set r 1; foreach a $al {set r [expr $r*$a]}; return $r}
  proc lreverse {list} {
  	set r {}
--- 31,54 ----
  	return $x
  }
! 
! # set several variables from elements of a list
  proc mset {vars list} {uplevel 1 "foreach {$vars} {$list} {}"}
+ 
+ # add or substract one value to a list
  proc l+   {   al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a +   $b]}; return $r}
  proc l-   {   al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a -   $b]}; return $r}
+ 
+ # like l+ or l- but for any infix supported by expr
  proc lzip {op al bl} {set r {}; foreach a $al b $bl {lappend r [expr $a $op $b]}; return $r}
  proc lmap {op al   } {set r {}; foreach a $al b $bl {lappend r [expr $a $op   ]}; return $r}
+ 
+ # halve a list
  proc l/2  {   al   } {set r {}; foreach a $al       {lappend r [expr $a /    2]}; return $r}
+ 
+ # sum and product of a list, like math's capital Sigma and capital Pi.
  proc lsum  {al} {set r 0; foreach a $al {set r [expr $r+$a]}; return $r}
  proc lprod {al} {set r 1; foreach a $al {set r [expr $r*$a]}; return $r}
+ 
+ # all elements from end to beginning
  proc lreverse {list} {
  	set r {}
***************
*** 40,43 ****
--- 57,62 ----
  }
  
+ # list substraction is like set substraction but order-preserving
+ # this is the same algorithm as Ruby's - operation on Arrays
  proc lwithout {a b} {
  	set r {}
***************
*** 47,50 ****
--- 66,70 ----
  }
  
+ # removes duplicates from a list, but it must be already sorted.
  proc luniq {a} {
  	set r {}
***************
*** 58,61 ****
--- 78,94 ----
  }
  
+ # finds the current length of the callstack, minus one.
+ # uplevel [thislevel] {...} gives access to the global context.
+ proc lastlevel {} {
+ 	set m 0; set n 1
+ 	while {![catch {uplevel $n {}}]} {set m $n; incr n $n}
+ 	# from now on, m <= lastlevel < n
+ 	while {$n-$m>1} {
+ 		set p [expr ($m+$n)/2]
+ 		if {[catch {uplevel $p {}}]} {set n $p} {set m $p}
+ 	}
+ 	return [expr $m-1]
+ }
+ 
  #-----------------------------------------------------------------------------------#
  # Observer pattern
***************
*** 3115,3119 ****
  }
  
! proc tcl_eval {self l} {post %s "tcl: $l"; post %s "returns: [eval $l]"}
  proc  pd_eval {self l} {post %s "pd: $l"; pd $l}
  proc gdb_eval {self l} {post %s "gdb: $l"; global gdb; puts $gdb "$l"}
--- 3148,3152 ----
  }
  
! proc tcl_eval {self l} {post %s "tcl: $l"; post %s "returns: [uplevel [lastlevel] $l]"}
  proc  pd_eval {self l} {post %s "pd: $l"; pd $l}
  proc gdb_eval {self l} {post %s "gdb: $l"; global gdb; puts $gdb "$l"}