home *** CD-ROM | disk | FTP | other *** search
/ CyberMycha 2006 April / SGP.iso / dema / Keepsake-Demo-en-li-v1.0.exe / res / bin / prime / vector3.tcl < prev    next >
Text File  |  2005-10-29  |  3KB  |  127 lines
  1. namespace eval vector {}
  2.  
  3. proc vector::norm2 {V1} {
  4.     set n 0
  5.     foreach v1 $V1 {set n [expr {$n + ($v1 * $v1)}]}
  6.     return [expr {sqrt($n)}]
  7. }
  8.  
  9. proc vector::normalize {V1} {
  10.     set n [norm2 $V1]
  11.     if {$n == 0} {return $V1}
  12.     set W ""
  13.     foreach v1 $V1 {lappend W [expr {$v1 / $n}]}
  14.     return $W
  15. }
  16.  
  17. proc vector::add {V1 V2} {
  18.     set W ""
  19.     foreach v1 $V1 v2 $V2 {lappend W [expr {$v1 + $v2}]}
  20.     return $W
  21. }
  22.  
  23. proc vector::sub {V1 V2} {
  24.     set W ""
  25.     foreach v1 $V1 v2 $V2 {lappend W [expr {$v1 - $v2}]}
  26.     return $W
  27. }
  28.  
  29. proc vector::mul {V1 a} {
  30.     set W ""
  31.     foreach v1 $V1 {lappend W [expr {$v1 * $a}]}
  32.     return $W
  33. }
  34.  
  35. proc vector::div {V1 a} {
  36.     set W ""
  37.     foreach v1 $V1 {lappend W [expr {$v1 / $a}]}
  38.     return $W
  39. }
  40.  
  41. proc vector::simple_expr {l op r} {
  42.     case $op {
  43.         {+} {
  44.             if {[llength $l] != [llength $r]} {
  45.                 error "$ls and $rs must be of equal length."
  46.             }
  47.             vector::add $l $r
  48.         }
  49.  
  50.         {-} {
  51.             if {[llength $l] != [llength $r]} {
  52.                 error "$l and $r must be of equal length."
  53.             }
  54.             vector::sub $l $r
  55.         }
  56.  
  57.         {\\*} {
  58.             if {[llength $l] == 1} {
  59.                 vector::mul $r $l
  60.             } elseif {[llength $r] == 1} {
  61.                 vector::mul $l $r
  62.             } else {
  63.                 error "$l or $r must be a scalar."
  64.             }
  65.         }
  66.  
  67.         {/} {
  68.             if {[llength $l] == 1} {
  69.                 vector::div $r [expr double($l)]
  70.             } elseif {[llength $r] == 1} {
  71.                 vector::div $l [expr double($r)]
  72.             } else {
  73.                 error "$l or $r must be a scalar."
  74.             }
  75.         }
  76.     }
  77. }
  78.  
  79. proc vector::vexpr {args} {
  80.     if {[llength $args] == 1} {
  81.         set a [lindex $args 0]
  82.     } else {
  83.         set a $args
  84.     }
  85.  
  86.     regsub -all {\$[^ ^)]*} $a {{&}} a
  87.     set a [uplevel 1 subst \{$a\}]
  88.  
  89.     set ::i 0
  90.     while {[regexp {([^\{]*)\{([^\}]*)\}(.*)} $a -> h v f]} {
  91.         incr ::i
  92.         set a "$h%$::i$f"
  93.         set ::vector($::i) $v
  94.     }
  95.  
  96.     do $a
  97. }
  98.  
  99. proc vector::do {a} {
  100.     if {[regexp {^%([0-9]+)$} [string trim $a] -> i]} {
  101.         return $::vector($i)
  102.     }
  103.  
  104.     if {[regexp {(.*)\((.*)\)(.*)} $a -> h exp f]} {
  105.         regexp {([^\)]*)(.*)} $exp -> exp br
  106.         set f $br$f
  107.  
  108.         if {[regexp {(.*)(norm2|normalize)$} $h -> h func]} {
  109.             set exp [$func [do $exp]]
  110.         } else {
  111.             set exp [do $exp]
  112.         }
  113.  
  114.         incr ::i
  115.         set ::vector($::i) $exp
  116.         
  117.         return [do $h%$::i$f]
  118.     } elseif {[regexp {(.*)([\+\-])(.*)} $a -> l op r]} {
  119.         return [simple_expr [do $l] $op [do $r]]
  120.     } elseif {[regexp {(.*)([\*\/])(.*)} $a -> l op r]} {
  121.         return [simple_expr [do $l] $op [do $r]]
  122.     }
  123.  
  124.     error "Couldn't parse expression: $a"
  125. }
  126.  
  127.