Quaternion type: Difference between revisions

← Older edit Newer edit →

Content deleted Content added

Inline

@@ Line 144: / Line 144: @@
 Quaternion(real=-1.0, i=0.0, j=0.0, k=0.0)
 >>> </lang>
+=={{header|Tcl}}==
+<lang tcl># Support class that provides C++-like RAII lifetimes
+oo::class create RAII-support {
+    constructor {} {
+	upvar 1 { end } end
+	lappend end [self]
+	trace add variable end unset [namespace code {my destroy}]
+    }
+    destructor {
+	catch {
+	    upvar 1 { end } end
+	    trace remove variable end unset [namespace code {my destroy}]
+	}
+    }
+    method return {{level 1}} {
+	incr level
+	upvar 1 { end } end
+	upvar $level { end } parent
+	trace remove variable end unset [namespace code {my destroy}]
+	lappend parent [self]
+	trace add variable parent unset [namespace code {my destroy}]
+	return -level $level [self]
+    }
+}
+# Class of quaternions
+oo::class create Q {
+    superclass RAII-support
+    variable R I J K
+    constructor {{real 0} {i 0} {j 0} {k 0}} {
+	next
+	namespace import ::tcl::mathfunc::* ::tcl::mathop::*
+	variable R [double $real] I [double $i] J [double $j] K [double $k]
+    }
+    self method return args {
+	[my new {*}$args] return 2
+    }
+    method p {} {
+	return "Q($R,$I,$J,$K)"
+    }
+    method values {} {
+	list $R $I $J $K
+    }
+    method Norm {} {
+	+ [* $R $R] [* $I $I] [* $J $J] [* $K $K]
+    }
+    method conjugate {} {
+	Q return $R [- $I] [- $J] [- $K]
+    }
+    method norm {} {
+	sqrt [my Norm]
+    }
+    method unit {} {
+	set n [my norm]
+	Q return [/ $R $n] [/ $I $n] [/ $J $n] [/ $K $n]
+    }
+    method reciprocal {} {
+	set n2 [my Norm]
+	Q return [/ $R $n2] [/ $I $n2] [/ $J $n2] [/ $K $n2]
+    }
+    method - {{q ""}} {
+	if {[llength [info level 0]] == 2} {
+	    Q return [- $R] [- $I] [- $J] [- $K]
+	}
+	[my + [$q -]] return
+    }
+    method + q {
+	if {[info object isa object $q]} {
+	    lassign [$q values] real i j k
+	    Q return [+ $R $real] [+ $I $i] [+ $J $j] [+ $K $k]
+	}
+	Q return [+ $R [double $q]] $I $J $K
+    }
+    method * q {
+	if {[info object isa object $q]} {
+	    lassign [my values] a1 b1 c1 d1
+	    lassign [$q values] a2 b2 c2 d2
+	    Q return [expr {$a1*$a2 - $b1*$b2 - $c1*$c2 - $d1*$d2}] \
+		[expr {$a1*$b2 + $b1*$a2 + $c1*$d2 - $d1*$c2}] \
+		[expr {$a1*$c2 - $b1*$d2 + $c1*$a2 + $d1*$b2}] \
+		[expr {$a1*$d2 + $b1*$c2 - $c1*$b2 + $d1*$a2}]
+	}
+	set f [double $q]
+	Q return [* $R $f] [* $I $f] [* $J $f] [* $K $f]
+    }
+    method == q {
+	expr {
+	    [info object isa object $q]
+	    && [info object isa typeof $q [self class]]
+	    && [my values] eq [$q values]
+	}
+    }
+    export - + * ==
+}</lang>
+Demonstration code:
+<lang tcl>set q [Q new 1 2 3 4]
+set q1 [Q new 2 3 4 5]
+set q2 [Q new 3 4 5 6]
+set r 7
+puts "q = [$q p]"
+puts "q1 = [$q1 p]"
+puts "q2 = [$q2 p]"
+puts "r = $r"
+puts "q norm = [$q norm]"
+puts "q1 norm = [$q1 norm]"
+puts "q2 norm = [$q2 norm]"
+puts "-q = [[$q -] p]"
+puts "q conj = [[$q conjugate] p]"
+puts "q + r = [[$q + $r] p]"
+# Real numbers are not objects, so no extending operations for them
+puts "q1 + q2 = [[$q1 + $q2] p]"
+puts "q2 + q1 = [[$q2 + $q1] p]"
+puts "q * r = [[$q * $r] p]"
+puts "q1 * q2 = [[$q1 * $q2] p]"
+puts "q2 * q1 = [[$q2 * $q1] p]"
+puts "equal(q1*q2, q2*q1) = [[$q1 * $q2] == [$q2 * $q1]]"</lang>
+Output:
+<pre>
+q = Q(1.0,2.0,3.0,4.0)
+q1 = Q(2.0,3.0,4.0,5.0)
+q2 = Q(3.0,4.0,5.0,6.0)
+r = 7
+q norm = 5.477225575051661
+q1 norm = 7.3484692283495345
+q2 norm = 9.273618495495704
+-q = Q(-1.0,-2.0,-3.0,-4.0)
+q conj = Q(1.0,-2.0,-3.0,-4.0)
+q + r = Q(8.0,2.0,3.0,4.0)
+q1 + q2 = Q(5.0,7.0,9.0,11.0)
+q2 + q1 = Q(5.0,7.0,9.0,11.0)
+q * r = Q(7.0,14.0,21.0,28.0)
+q1 * q2 = Q(-56.0,16.0,24.0,26.0)
+q2 * q1 = Q(-56.0,18.0,20.0,28.0)
+equal(q1*q2, q2*q1) = 0
+</pre>