Geometric algebra: Difference between revisions
(→{{header|Perl 6}}: minor simplifications) |
(→{{header|Perl 6}}: simplify by assuming an euclidean metric) |
||
Line 22: | Line 22: | ||
return %!blades{0} // 0; |
return %!blades{0} // 0; |
||
} |
} |
||
# Metric signature |
|||
our @signature = 1 xx *; |
|||
sub e(UInt $n?) returns MultiVector is export { |
sub e(UInt $n?) returns MultiVector is export { |
||
Line 38: | Line 35: | ||
} until $i == 0; |
} until $i == 0; |
||
return $n +& 1 ?? -1 !! 1; |
return $n +& 1 ?? -1 !! 1; |
||
} |
|||
sub metric-product(UInt $i, UInt $j) { |
|||
my $r = order($i, $j); |
|||
my $t = $i +& $j; |
|||
my $k = 0; |
|||
while $t !== 0 { |
|||
if $t +& 1 { |
|||
$r *= @signature[$k]; |
|||
} |
|||
$t +>= 1; |
|||
$k++; |
|||
} |
|||
return $r; |
|||
} |
} |
||
Line 74: | Line 57: | ||
for $B.blades -> $b { |
for $B.blades -> $b { |
||
my $c = $a.key +^ $b.key; |
my $c = $a.key +^ $b.key; |
||
%blades{$c} += $a.value * $b.value * |
%blades{$c} += $a.value * $b.value * order($a.key, $b.key); |
||
%blades{$c} :delete unless %blades{$c}; |
%blades{$c} :delete unless %blades{$c}; |
||
} |
} |
Revision as of 00:20, 14 October 2015
Geometric algebra is an other name for Clifford algebras and it's basically an algebra containing a vector space and obeying the following axioms:
The purpose of this task is to implement such an algebra for a vector space of countable, yet infinite dimension. You'll then pick three random elements of this algebra, along with a random vector, and verify that the axioms are respected.
Perl 6
<lang perl6>unit class MultiVector; has Real %.blades{UInt}; method clean { for %!blades { %!blades{.key} :delete unless .value; } } method narrow {
for %!blades { return self if .key > 0 && .value !== 0; } return %!blades{0} // 0;
}
sub e(UInt $n?) returns MultiVector is export {
$n.defined ?? MultiVector.new(:blades(my Real %{UInt} = (1 +< $n) => 1)) !! MultiVector.new
}
my sub grade(UInt $n) is cached { [+] $n.base(2).comb } my sub order(UInt:D $i is copy, UInt:D $j) is cached {
my $n = 0; repeat {
$i +>= 1; $n += [+] ($i +& $j).base(2).comb;
} until $i == 0; return $n +& 1 ?? -1 !! 1;
}
multi infix:<+>(MultiVector $A, MultiVector $B) returns MultiVector is export {
my Real %blades{UInt} = $A.blades.clone; for $B.blades {
%blades{.key} += .value; %blades{.key} :delete unless %blades{.key};
} return MultiVector.new: :%blades;
} multi infix:<+>(Real $s, MultiVector $A) returns MultiVector is export {
my Real %blades{UInt} = $A.blades.clone; %blades{0} += $s; %blades{0} :delete unless %blades{0}; return MultiVector.new: :%blades;
} multi infix:<+>(MultiVector $A, Real $s) returns MultiVector is export { $s + $A } multi infix:<*>(MultiVector $A, MultiVector $B) returns MultiVector is export {
my Real %blades{UInt}; for $A.blades -> $a {
for $B.blades -> $b { my $c = $a.key +^ $b.key; %blades{$c} += $a.value * $b.value * order($a.key, $b.key); %blades{$c} :delete unless %blades{$c}; }
} return MultiVector.new: :%blades;
} multi infix:<**>(MultiVector $ , 0) returns MultiVector is export { return MultiVector.new } multi infix:<**>(MultiVector $A, 1) returns MultiVector is export { return $A } multi infix:<**>(MultiVector $A, 2) returns MultiVector is export { return $A * $A } multi infix:<**>(MultiVector $A, UInt $n where $n %% 2) returns MultiVector is export {
return ($A ** ($n div 2)) ** 2;
} multi infix:<**>(MultiVector $A, UInt $n) returns MultiVector is export {
return $A * ($A ** ($n div 2)) ** 2;
}
multi infix:<*>(MultiVector $, 0) returns MultiVector is export { MultiVector.new } multi infix:<*>(MultiVector $A, 1) returns MultiVector is export { $A } multi infix:<*>(MultiVector $A, Real $s) returns MultiVector is export {
return MultiVector.new: :blades(my Real %{UInt} = map { .key => $s * .value }, $A.blades);
} multi infix:<*>(Real $s, MultiVector $A) returns MultiVector is export { $A * $s } multi infix:</>(MultiVector $A, Real $s) returns MultiVector is export { $A * (1/$s) } multi prefix:<->(MultiVector $A) returns MultiVector is export { return -1 * $A } multi infix:<->(MultiVector $A, MultiVector $B) returns MultiVector is export { $A + -$B } multi infix:<->(MultiVector $A, Real $s) returns MultiVector is export { $A + -$s } multi infix:<->(Real $s, MultiVector $A) returns MultiVector is export { $s + -$A }
multi infix:<==>(MultiVector $A, MultiVector $B) returns Bool is export { $A - $B == 0 } multi infix:<==>(Real $x, MultiVector $A) returns Bool is export { $A == $x } multi infix:<==>(MultiVector $A, Real $x) returns Bool is export {
my $narrowed = $A.narrow; $narrowed ~~ Real and $narrowed == $x;
}</lang>
The code required to test the axioms is the following:
<lang perl6>use MultiVector; use Test;
plan 4;
sub random {
[+] map { MultiVector.new: :blades(my Real %{UInt} = $_ => rand.round(.01)) }, (^32).pick(5);
}
my ($a, $b, $c) = random() xx 3;
ok ($a*$b)*$c == $a*($b*$c), 'associativity'; ok $a*($b + $c) == $a*$b + $a*$c, 'left distributivity'; ok ($a + $b)*$c == $a*$c + $b*$c, 'right distributivity'; my @coeff = (.5 - rand) xx 4; my $v = [+] @coeff Z* map &e, ^4; ok ($v**2).narrow ~~ Real, 'contraction';</lang>
- Output:
1..4 ok 1 - associativity ok 2 - left distributivity ok 3 - right distributivity ok 4 - contraction