home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / math / math.tcl next >
Encoding:
Text File  |  2001-08-17  |  7.7 KB  |  339 lines
  1. # math.tcl --
  2. #
  3. #    Collection of math functions.
  4. #
  5. # Copyright (c) 1998-2000 by Ajuba Solutions.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. # 
  10. # RCS: @(#) $Id: math.tcl,v 1.9 2001/08/02 16:38:06 andreas_kupries Exp $
  11.  
  12. package require Tcl 8.2        ;# uses [lindex $l end-$integer]
  13. namespace eval ::math {
  14. }
  15.  
  16. # ::math::cov --
  17. #
  18. #    Return the coefficient of variation of three or more values
  19. #
  20. # Arguments:
  21. #    val1    first value
  22. #    val2    second value
  23. #    args    other values
  24. #
  25. # Results:
  26. #    cov    coefficient of variation expressed as percent value
  27.  
  28. proc ::math::cov {val1 val2 args} {
  29.      set sum [ expr { $val1+$val2 } ]
  30.      set N [ expr { [ llength $args ] + 2 } ]
  31.      foreach val $args {
  32.         set sum [ expr { $sum+$val } ]
  33.      }
  34.      set mean [ expr { $sum/$N } ]
  35.      set sigma_sq 0
  36.      foreach val [ concat $val1 $val2 $args ] {
  37.         set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
  38.      }
  39.      set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
  40.      set sigma [ expr { sqrt($sigma_sq) } ]
  41.      set cov [ expr { ($sigma/$mean)*100 } ]
  42.      set cov
  43. }
  44.  
  45. # ::math::fibonacci --
  46. #
  47. #    Return the n'th fibonacci number.
  48. #
  49. # Arguments:
  50. #    n    The index in the sequence to compute.
  51. #
  52. # Results:
  53. #    fib    The n'th fibonacci number.
  54.  
  55. proc ::math::fibonacci {n} {
  56.     if { $n == 0 } {
  57.     return 0
  58.     } else {
  59.     set prev0 0
  60.     set prev1 1
  61.     for {set i 1} {$i < $n} {incr i} {
  62.         set tmp $prev1
  63.         incr prev1 $prev0
  64.         set prev0 $tmp
  65.     }
  66.     return $prev1
  67.     }
  68. }
  69.  
  70. # ::math::integrate --
  71. #
  72. #    calculate the area under a curve defined by a set of (x,y) data pairs.
  73. #    the x data must increase monotonically throughout the data set for the 
  74. #    calculation to be meaningful, therefore the monotonic condition is
  75. #    tested, and an error is thrown if the x value is found to be
  76. #    decreasing.
  77. #
  78. # Arguments:
  79. #    xy_pairs    list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5
  80. #            data pairs are required, and if the number of data
  81. #            pairs is even, a padding value of (x0, 0) will be
  82. #            added.
  83. # 
  84. # Results:
  85. #    result        A two-element list consisting of the area and error
  86. #            bound (calculation is "Simpson's rule")
  87.  
  88. proc ::math::integrate { xy_pairs } {
  89.      
  90.      set length [ llength $xy_pairs ]
  91.      
  92.      if { $length < 10 } {
  93.         return -code error "at least 5 x,y pairs must be given"
  94.      }   
  95.      
  96.      ;## are we dealing with x,y pairs?
  97.      if { [ expr {$length % 2} ] } {
  98.         return -code error "unmatched xy pair in input"
  99.      }
  100.      
  101.      ;## are there an even number of pairs?  Augment.
  102.      if { ! [ expr {$length % 4} ] } {
  103.         set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
  104.      }
  105.      set x0   [ lindex $xy_pairs 0     ]
  106.      set x1   [ lindex $xy_pairs 2     ]
  107.      set xn   [ lindex $xy_pairs end-1 ]
  108.      set xnminus1 [ lindex $xy_pairs end-3 ]
  109.     
  110.      if { $x1 < $x0 } {
  111.         return -code error "monotonicity broken by x1"
  112.      }
  113.  
  114.      if { $xn < $xnminus1 } {
  115.         return -code error "monotonicity broken by xn"
  116.      }   
  117.      
  118.      ;## handle the assymetrical elements 0, n, and n-1.
  119.      set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ]
  120.      set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ]
  121.  
  122.      set data [ lrange $xy_pairs 2 end-4 ]
  123.      
  124.      set xmax $x1
  125.      set i 1
  126.      foreach {x1 y1 x2 y2} $data {
  127.         incr i
  128.         if { $x1 < $xmax } {
  129.            return -code error "monotonicity broken by x$i"
  130.         }
  131.         set xmax $x1
  132.         incr i
  133.         if { $x2 < $xmax } {
  134.            return -code error "monotonicity broken by x$i"
  135.         }
  136.         set xmax $x2
  137.         set sum [ expr {$sum + (4*$y1) + (2*$y2)} ]
  138.      }   
  139.      
  140.      if { $xmax > $xnminus1 } {
  141.         return -code error "monotonicity broken by xn-1"
  142.      }   
  143.     
  144.      set h [ expr { ( $xn - $x0 ) / $i } ]
  145.      set area [ expr { ( $h / 3.0 ) * $sum } ]
  146.      set err_bound  [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]  
  147.      return [ list $area $err_bound ]
  148. }
  149.  
  150. # ::math::max --
  151. #
  152. #    Return the maximum of two or more values
  153. #
  154. # Arguments:
  155. #    val    first value
  156. #    args    other values
  157. #
  158. # Results:
  159. #    max    maximum value
  160.  
  161. proc ::math::max {val args} {
  162.     set max $val
  163.     foreach val $args {
  164.     if { $val > $max } {
  165.         set max $val
  166.     }
  167.     }
  168.     set max
  169. }
  170.  
  171. # ::math::mean --
  172. #
  173. #    Return the mean of two or more values
  174. #
  175. # Arguments:
  176. #    val    first value
  177. #    args    other values
  178. #
  179. # Results:
  180. #    mean    arithmetic mean value
  181.  
  182. proc ::math::mean {val args} {
  183.     set sum $val
  184.     set N [ expr { [ llength $args ] + 1 } ]
  185.     foreach val $args {
  186.         set sum [ expr { $sum + $val } ]
  187.     }
  188.     set mean [expr { double($sum) / $N }]
  189. }
  190.  
  191. # ::math::min --
  192. #
  193. #    Return the minimum of two or more values
  194. #
  195. # Arguments:
  196. #    val    first value
  197. #    args    other values
  198. #
  199. # Results:
  200. #    min    minimum value
  201.  
  202. proc ::math::min {val args} {
  203.     set min $val
  204.     foreach val $args {
  205.     if { $val < $min } {
  206.         set min $val
  207.     }
  208.     }
  209.     set min
  210. }
  211.  
  212. # ::math::product --
  213. #
  214. #    Return the product of one or more values
  215. #
  216. # Arguments:
  217. #    val    first value
  218. #    args    other values
  219. #
  220. # Results:
  221. #    prod     product of multiplying all values in the list
  222.  
  223. proc ::math::product {val args} {
  224.     set prod $val
  225.     foreach val $args {
  226.         set prod [ expr { $prod*$val } ]
  227.     }
  228.     set prod
  229. }
  230.  
  231. # ::math::random --
  232. #
  233. #    Return a random number in a given range.
  234. #
  235. # Arguments:
  236. #    args    optional arguments that specify the range within which to
  237. #        choose a number:
  238. #            (null)        choose a number between 0 and 1
  239. #            val        choose a number between 0 and val
  240. #            val1 val2    choose a number between val1 and val2
  241. #
  242. # Results:
  243. #    num    a random number in the range.
  244.  
  245. proc ::math::random {args} {
  246.     set num [expr {rand()}]
  247.     if { [llength $args] == 0 } {
  248.     return $num
  249.     } elseif { [llength $args] == 1 } {
  250.     return [expr {int($num * [lindex $args 0])}]
  251.     } elseif { [llength $args] == 2 } {
  252.     foreach {lower upper} $args break
  253.     set range [expr {$upper - $lower}]
  254.     return [expr {int($num * $range) + $lower}]
  255.     } else {
  256.     set fn [lindex [info level 0] 0]
  257.     error "wrong # args: should be \"$fn ?value1? ?value2?\""
  258.     }
  259. }
  260.  
  261. # ::math::sigma --
  262. #
  263. #    Return the standard deviation of three or more values
  264. #
  265. # Arguments:
  266. #    val1    first value
  267. #    val2    second value
  268. #    args    other values
  269. #
  270. # Results:
  271. #    sigma    population standard deviation value
  272.  
  273. proc ::math::sigma {val1 val2 args} {
  274.      set sum [ expr { $val1+$val2 } ]
  275.      set N [ expr { [ llength $args ] + 2 } ]
  276.      foreach val $args {
  277.         set sum [ expr { $sum+$val } ]
  278.      }
  279.      set mean [ expr { $sum/$N } ]
  280.      set sigma_sq 0
  281.      foreach val [ concat $val1 $val2 $args ] {
  282.         set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
  283.      }
  284.      set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
  285.      set sigma [ expr { sqrt($sigma_sq) } ]
  286.      set sigma
  287. }     
  288.  
  289. # ::math::stats --
  290. #
  291. #    Return the mean, standard deviation, and coefficient of variation as
  292. #    percent, as a list.
  293. #
  294. # Arguments:
  295. #    val1    first value
  296. #    val2    first value
  297. #    args    all other values
  298. #
  299. # Results:
  300. #    {mean stddev coefvar}
  301.  
  302. proc ::math::stats {val1 val2 args} {
  303.      set sum [ expr { $val1+$val2 } ]
  304.      set N [ expr { [ llength $args ] + 2 } ]
  305.      foreach val $args {
  306.         set sum [ expr { $sum+$val } ]
  307.      }
  308.      set mean [ expr { $sum/$N } ]
  309.      set sigma_sq 0
  310.      foreach val [ concat $val1 $val2 $args ] {
  311.         set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
  312.      }
  313.      set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
  314.      set sigma [ expr { sqrt($sigma_sq) } ]
  315.      set cov [ expr { ($sigma/$mean)*100 } ]
  316.      return [ list $mean $sigma $cov ]
  317. }
  318.  
  319. # ::math::sum --
  320. #
  321. #    Return the sum of one or more values
  322. #
  323. # Arguments:
  324. #    val    first value
  325. #    args    all other values
  326. #
  327. # Results:
  328. #    sum    arithmetic sum of all values in args
  329.  
  330. proc ::math::sum {val args} {
  331.     set sum $val
  332.     foreach val $args {
  333.         set sum [ expr { $sum+$val } ]
  334.     }
  335.     set sum
  336. }
  337.  
  338. package provide math 1.1
  339.