├── .gitattributes ├── .gitignore ├── GeometricAlgebra ├── Documentation │ └── English │ │ ├── Guides │ │ ├── Dualnumbers.nb │ │ ├── GeometricAlgebra.nb │ │ └── MatrixGateway.nb │ │ ├── ReferencePages │ │ └── Symbols │ │ │ ├── ConvertGeometricAlgebra.nb │ │ │ ├── GeometricAlgebra.nb │ │ │ ├── GeometricProduct.nb │ │ │ ├── Grade.nb │ │ │ └── Multivector.nb │ │ └── Tutorials │ │ ├── ConformalGeometry.nb │ │ ├── Dualnumbers.nb │ │ ├── GeometricNumbers.nb │ │ ├── MatrixGateway.nb │ │ ├── OperatorDuality.nb │ │ ├── ProjectiveGeometry.nb │ │ └── Spinors.nb ├── Kernel │ ├── ConformalGeometry.m │ ├── Dual.m │ ├── GeneralRelativity.m │ ├── GeometricAlgebra.m │ ├── GeometricMatrix.m │ ├── Multivector.m │ ├── MultivectorArray.m │ ├── MultivectorBasis.m │ ├── MultivectorTransform.m │ ├── PauliDirac.m │ ├── ProjectiveGeometry.m │ └── Utilities.m ├── PacletInfo.wl └── ResourceDefinition.nb ├── Notebooks └── GeometricAlgebra-Dev.nb ├── README.md └── Tests └── Tests.wlt /.gitattributes: -------------------------------------------------------------------------------- 1 | *.nb filter=lfs diff=lfs merge=lfs -text 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.paclet 3 | 4 | .project 5 | 6 | GeometricAlgebra/build/ 7 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Guides/Dualnumbers.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:422eb281803db634b9d0cd9ee7802c82c79997d896d298e6bd76a265e940e79a 3 | size 13834 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Guides/GeometricAlgebra.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:8b24d383dc532b3d864271bf9096d00a24e5611feaa71ab0b9b9187116dbefba 3 | size 11817 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Guides/MatrixGateway.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:6da35bcf80a777e50b6b6fd0aa2c21cc4f3a3f2d1a53440453c58466cb823f8e 3 | size 12831 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/ReferencePages/Symbols/ConvertGeometricAlgebra.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:29babc4b6dd55def8c55c1df511e731d37a561a0ab086c8ee0a34c43846284c9 3 | size 22479 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/ReferencePages/Symbols/GeometricAlgebra.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:ad2ec0f60c7cf5f1235233cdc86f45e3a67db5c9d3c7e8323556dce7ae6e1ac0 3 | size 78869 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/ReferencePages/Symbols/GeometricProduct.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:c7cd09284ca697b17ecac22f58fbc3d812b88ab51528e8abe75afed206d2d1f2 3 | size 31967 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/ReferencePages/Symbols/Grade.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:d93684401aa440f6bb0c9fe06a064437c5dccb7c99729f853ca0f9de342bf51a 3 | size 30503 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/ReferencePages/Symbols/Multivector.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:3f617e576f2c4adfd891c3be4ba427568c998297387865965550f5ab10d5c88f 3 | size 25940 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/ConformalGeometry.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:1d3be1a501663169d3a6c73249e7787a2d0ec2792e6aade1a49d54d1b210b77d 3 | size 1164418 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/Dualnumbers.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:700d53debdbca21d58107344130b2337480c4e78295431a0ccf8f2898d71dd20 3 | size 24141 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/GeometricNumbers.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:734b9de5427590a10957a9fcb927e7df240e8030c0a763b1f73a4aebc3508eae 3 | size 210452 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/MatrixGateway.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:baf2a6e61251e32ae3c2d4833121e0f5bed34c6b2cb663eba733bb54f8d62a20 3 | size 156013 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/OperatorDuality.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:edbe88e2de945ceb6b555c0b66a4371d00eb70b15432f45a3859248334cc05ce 3 | size 1403847 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/ProjectiveGeometry.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:624e0455f1aae759aa09fbf70c2672b50efbe7a020c6fd3a6ceb846dd9f2f79d 3 | size 4082603 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Documentation/English/Tutorials/Spinors.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:7f587e9ce1b3a55d42fa5b5d52901f37a70b5f64f97f13fa6543dc9e3da4e7b6 3 | size 288843 4 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/ConformalGeometry.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`ProjectiveGeometry`"] 2 | 3 | PackageImport["Wolfram`GeometricAlgebra`"] 4 | 5 | PackageExport[CGA] 6 | PackageExport[$CGA0] 7 | PackageExport[$2DCGA] 8 | PackageExport[$CGA] 9 | PackageExport[CGAQ] 10 | 11 | PackageExport[CGARegions] 12 | PackageExport[CGAFlatPoint] 13 | PackageExport[CGALine] 14 | PackageExport[CGAPlane] 15 | PackageExport[CGARoundPoint] 16 | PackageExport[CGADipole] 17 | PackageExport[CGACircle] 18 | PackageExport[CGASphere] 19 | 20 | PackageExport[CGAMotor] 21 | PackageExport[CGAFlector] 22 | PackageExport[CGADilator] 23 | 24 | PackageScope[CGA3DQ] 25 | PackageScope[ToCGA] 26 | 27 | 28 | 29 | $CGA0 = GeometricAlgebra[4, 1, "Format" -> "CGA0", 30 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {4 -> "-", UnderBar[1] -> "+", Subscript[_, Row[{1, 2, 3, 4, UnderBar[1]}, _]] -> "\[DoubleStruckOne]"}], 31 | "VectorBasis" -> {{1, 0, 0, 0, 0}, {0, 1, 0, 0, 0}, {0, 0, 1, 0, 0}, {0, 0, 0, 0, 1}, {0, 0, 0, 1, 0}} 32 | ] 33 | 34 | CGA[2] = $2DCGA = e2 = GeometricAlgebra[3, 1, "Format" -> Subscript["CGA", "2D"], 35 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {UnderBar[1] -> 4, Subscript[_, Row[{1, 2, 3, UnderBar[1]}, _]] -> "\[DoubleStruckOne]"}], 36 | "VectorBasis" -> BlockDiagonalMatrix[{IdentityMatrix[2], {{- 1, 1 / 2}, {1, 1 / 2}}}], 37 | "Ordering" -> { 38 | {}, {1}, {2}, {3}, {4}, {2, 3}, {3, 1}, {1, 2}, {4, 1}, {4, 2}, {4, 3}, 39 | {3, 2, 1}, {4, 2, 3}, {4, 3, 1}, {4, 1, 2}, {1, 2, 3, 4} 40 | } 41 | ] 42 | 43 | CGA[3] = e = $3DCGA = $CGA = GeometricAlgebra[4, 1, "Format" -> "CGA", 44 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {UnderBar[1] -> 5, Subscript[_, Row[{1, 2, 3, 4, UnderBar[1]}, _]] -> "\[DoubleStruckOne]"}], 45 | "VectorBasis" -> BlockDiagonalMatrix[{IdentityMatrix[3], {{- 1, 1 / 2}, {1, 1 / 2}}}], 46 | "Ordering" -> { 47 | {}, {1}, {2}, {3}, {4}, {-1}, {4, 1}, {4, 2}, {4, 3}, {2, 3}, {3, 1}, {1, 2}, {1, -1}, {2, -1}, {3, -1}, {4, -1}, 48 | {4, 2, 3}, {4, 3, 1}, {4, 1, 2}, {3, 2, 1}, {4, 1, -1}, {4, 2, -1}, {4, 3, -1}, {2, 3, -1}, {3, 1, -1}, {1, 2, -1}, 49 | {1, 2, 3, 4}, {4, 2, 3, -1}, {4, 3, 1, -1}, {4, 1, 2, -1}, {3, 2, 1, -1}, {1, 2, 3, 4, -1} 50 | } 51 | ] 52 | 53 | CGA[n_Integer ? Positive] := GeometricAlgebra[n + 1, 1, "Format" -> Subscript["CGA", n], 54 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {UnderBar[1] -> n + 2, Subscript[_, Row[Append[Range[n + 1], UnderBar[1]], _]] -> "\[DoubleStruckOne]"}], 55 | "VectorBasis" -> BlockDiagonalMatrix[{IdentityMatrix[n], {{- 1, 1 / 2}, {1, 1 / 2}}}] 56 | ] 57 | 58 | 59 | CGAQ[x : _GeometricAlgebra | _Multivector] := MatchQ[x["Signature"], {_, 1, 0}] 60 | 61 | CGA2DQ[x : _GeometricAlgebra | _Multivector] := x["Signature"] === {3, 1, 0} 62 | 63 | CGA2DQ[___] := False 64 | 65 | CGA3DQ[x : _GeometricAlgebra | _Multivector] := x["Signature"] === {4, 1, 0} 66 | 67 | CGA3DQ[___] := False 68 | 69 | 70 | ToCGA[v_Multivector] := With[{g = CGA[v["NonNegativeDimension"] - 1]}, 71 | Which[ 72 | CGAQ[v], v, 73 | PGAQ[v], Wedge[Multivector[v, g], g["Infinity"]], 74 | True, Multivector[v, g] 75 | ] 76 | ] 77 | 78 | ToCGA[r : $CGARegion] := r 79 | 80 | ToCGA[___] := Missing[] 81 | 82 | 83 | (* Representations *) 84 | 85 | CGAFlatPoint[args___] := ToCGA @ PGAPoint[args] 86 | CGAFlatPoint[x_Multivector ? CGAQ] := With[{d = PGADimension[x]}, {p = x[{#, -1} & /@ Range[d]], w = x[d + 1, -1]}, 87 | Switch[w == 0, True, Missing["FlatPoint"], _, Point[p / w]] 88 | ] 89 | 90 | CGALine[args___] := ToCGA @ PGALine[args] 91 | CGALine[x_Multivector ? CGAQ] := With[{d = PGADimension[x]}, 92 | Enclose[InfiniteLine[First @ Confirm @ CGARoundPoint[Support[x]], x[{d + 1, #, -1} & /@ Range[d]]], Missing["Line"] &] 93 | ] 94 | 95 | CGAPlane[args___] := ToCGA @ PGAPlane[args] 96 | CGAPlane[x_Multivector ? CGA3DQ] := With[{n = x[{{4, 2, 3, 5}, {4, 3, 1, 5}, {4, 1, 2, 5}}], w = x[3, 2, 1, 5]}, 97 | Switch[Norm[n] != 0, False, Missing["Plane"], _, Hyperplane[n, - w]] 98 | ] 99 | 100 | CGARoundPoint[p_List, r_ : 0, w_ : 1] := With[{d = Length[p]}, {g = CGA[d]}, p . g[Range[d]] + w g["Origin"] + (p . p + r ^ 2) / 2 g["Infinity"]] 101 | CGARoundPoint[Point[p_], r_ : 0, w_ : 1] := CGARoundPoint[p, r, w] 102 | CGARoundPoint[(Disk | Ball)[p_, r_ : 0], w_ : 1] := CGARoundPoint[p, r, w] 103 | CGARoundPoint[x_Multivector ? CGAQ] := With[{d = PGADimension[x]}, {p = x[Range[d]], w = x[d + 1]}, {r = Abs[Sqrt[2 x[-1] - p . p]]}, 104 | Switch[w == 0, True, Missing["RoundPoint"], _, Ball[p / w, r]] 105 | ] 106 | 107 | CGADipole[p : {_, _, _}, v : {_, _, _}, m : {_, _, _}, pw_ : 1] := PGALine[v, m] + CGAFlatPoint[p, pw] 108 | CGADipole[p : {_, _}, n : {_, _}, r_ : 0, pw_ : 1] := 109 | n . e2[{{2, 3}, {3, 1}}] - Det[{p, n}] (p . e2[{{4, 1}, {4, 2}}] + e2[4, 3]) - p . n e2[1, 2] + (p . p + r ^ 2) / 2 n . e2[{{2, 4}, {4, 1}}] 110 | CGADipole[p : {_, _, _}, n : {_, _, _}, r_ : 0, pw_ : 1] := 111 | n . e[{{4, 1}, {4, 2}, {4, 3}}] + Cross[p, n] . e[{{2, 3}, {3, 1}, {1, 2}}] + p . n CGAFlatPoint[p, pw] - (p . p + r ^ 2) / 2 n . e[{{1, 5}, {2, 5}, {3, 5}}] 112 | CGADipole[p_Point, q_Point] := Wedge[CGARoundPoint[p], CGARoundPoint[q]] 113 | CGADipole[Line[{p1 : {_, _}, p2 : {_, _}}]] := With[{p = (p1 + p2) / 2, n = {-1, 1} Reverse[(p1 - p2) / 2]}, CGADipole[p, n, Norm[n]]] 114 | CGADipole[(Line | Tube)[{p1_List, p2_List}, r_]] := With[{p = (p1 + p2) / 2, n = (p2 - p1) / 2}, CGADipole[p, r * Normalize[n], r]] 115 | CGADipole[(Line | Tube)[{p1_List, p2_List}]] := With[{p = (p1 + p2) / 2, n = (p2 - p1) / 2}, CGADipole[p, n, Norm[n]]] 116 | CGADipole[v_Multivector ? CGA2DQ] := ResourceFunction["CompoundScope"][ 117 | n = v[{{2, 3}, {3, 1}}]; 118 | nn = n . n; 119 | If[nn == 0, Return[Missing["Dipole"]]]; 120 | pn = - v[1, 2]; 121 | x = - v[4, 3]; 122 | p = {{pn, x}, {-x, pn}} . n / nn; 123 | r = Abs @ Sqrt[2 (v[{{2, 4}, {4, 1}}] + x * Reverse[p] {-1, 1}) . n / nn - p . p]; 124 | d = Reverse[n] {-1, 1} / Sqrt[nn] 125 | , 126 | Line[Re[{p - r d, p + r d}]] 127 | ] 128 | CGADipole[v_Multivector ? CGA3DQ] := ResourceFunction["CompoundScope"][ 129 | n = v[{{4, 1}, {4, 2}, {4, 3}}]; 130 | nn = n . n; 131 | If[nn == 0, Return[Missing["Dipole"]]]; 132 | pn = v[4, 5]; 133 | x = v[{{2, 3}, {3, 1}, {1, 2}}]; 134 | p = (Cross[n, x] + pn * n) / nn; 135 | r = Abs @ Sqrt[2 (pn * p - v[{{1, 5}, {2, 5}, {3, 5}}]) . n / nn - p . p]; 136 | , 137 | Tube[{p - r n / Sqrt[nn], p + r n / Sqrt[nn]}] 138 | ] 139 | 140 | CGACircle[n : {_, _, _}, v : {_, _, _}, m : {_, _, _}, w_ : 1] := PGAPlane[n, w] + CGALine[v, m] 141 | CGACircle[p : {_, _}, r_ : 0] := 142 | p . e2[{{4, 2, 3}, {4, 3, 1}}] - e2[3, 2, 1] - (p . p - r ^ 2) / 2 e2[4, 1, 2] 143 | CGACircle[p : {_, _, _}, n : {_, _, _}, r_ : 1] := 144 | n . e[{{4, 2, 3}, {4, 3, 1}, {4, 1, 2}}] + Cross[p, n] . e[{{4, 1, 5}, {4, 2, 5}, {4, 3, 5}}] + p . n (p . e[{{2, 3, 5}, {3, 1, 5}, {1, 2, 5}}] - e[3, 2, 1]) - (p . p - r ^ 2) / 2 n . e[{{2, 3, 5}, {3, 1, 5}, {1, 2, 5}}] 145 | CGACircle[Circle[p : {_, _}, r_ : 1]] := CGACircle[p, r] 146 | CGACircle[Inactive[ResourceFunction["Circle3D"]][p : {_, _, _}, {r_, _}, psi_, zeta_]] := CGACircle[p, {Cos[psi] Cos[zeta], Sin[zeta], -Cos[zeta] Sin[psi]}, r] 147 | CGACircle[v_Multivector ? CGA2DQ] := With[{p = v[{{4, 2, 3}, {4, 3, 1}}], w = - v[3, 2, 1]}, 148 | If[w == 0, Return[Missing["Circle"]]]; Circle[p / w, Abs[Sqrt[2 v[4, 1, 2] w + p . p] / w]] 149 | ] 150 | CGACircle[v_Multivector ? CGA3DQ] := ResourceFunction["CompoundScope"][ 151 | n = v[{{4, 2, 3}, {4, 3, 1}, {4, 1, 2}}]; 152 | nn = n . n; 153 | If[nn == 0, Return[Missing["Circle"]]]; 154 | pn = - v[3, 2, 1]; 155 | x = v[{{4, 1, 5}, {4, 2, 5}, {4, 3, 5}}]; 156 | p = (Cross[n, x] + pn * n) / nn; 157 | r = Abs @ Sqrt[2 (v[{{2, 3, 5}, {3, 1, 5}, {1, 2, 5}}] - pn * p) . n / nn + p . p]; 158 | psi = - ArcTan[n[[1]], n[[3]]]; 159 | zeta = ArcSin[n[[2]] / Sqrt[nn]] 160 | , 161 | Inactive[ResourceFunction["Circle3D"]][p, Abs[{r, r}], psi, zeta] 162 | ] 163 | 164 | CGASphere[n : {_, _, _}, u_, w_] := CGAPlane[n, w] + u e[1, 2, 3, 4] 165 | CGASphere[p : {_, _, _}, r_ : 1] := p . {e[4, 2, 3, 5], e[4, 3, 1, 5], e[4, 1, 2, 5]} - e[1, 2, 3, 4] - (p . p - r ^ 2) / 2 e[3, 2, 1, 5] 166 | CGASphere[Sphere[c : {_, _, _}, r_ : 1]] := CGASphere[c, r] 167 | CGASphere[v_Multivector ? CGA3DQ] := With[{w = v[1, 2, 3, 4]}, 168 | If[ w == 0, 169 | Missing["Sphere"], 170 | With[{c = - v[{{4, 2, 3, 5}, {4, 3, 1, 5}, {4, 1, 2, 5}}] / w}, 171 | Sphere[c, Sqrt[c . c - 2 v[3, 2, 1, 5] / w]] 172 | ] 173 | ] 174 | ] 175 | 176 | 177 | CGAMotor[args___] := ToCGA @ PGAMotor[args] 178 | 179 | CGAFlector[args___] := ToCGA @ PGAFlector[args] 180 | 181 | CGADilator[m : {_, _, _}, s_] := (1 - s) / 2 (m . e[{{2, 3, 5}, {3, 1, 5}, {1, 2, 5}}] - e[3, 2, 1]) + (1 + s) / 2 e[1, 2, 3, 4, 5] 182 | 183 | 184 | (* Region export *) 185 | 186 | CGARegions[v_Multivector ? CGAQ] := <| 187 | "FlatPoint" -> CGAFlatPoint[v], 188 | "RoundPoint" -> CGARoundPoint[v], 189 | "Line" -> CGALine[v], 190 | "Plane" -> CGAPlane[v], 191 | "Sphere" -> CGASphere[v], 192 | Activate["Circle" :> Evaluate[CGACircle[v]]], 193 | "Dipole" -> CGADipole[v] 194 | |> 195 | 196 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/Dual.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | PackageExport["Dual"] 4 | PackageExport["DualCoordinates"] 5 | PackageExport["DualRe"] 6 | PackageExport["DualEps"] 7 | PackageExport["DualDimension"] 8 | PackageExport["DualBasis"] 9 | 10 | PackageScope["dualFunction"] 11 | PackageScope["applyDualFunction"] 12 | PackageScope["multivectorDuals"] 13 | PackageScope["antiProductSigns"] 14 | 15 | 16 | Needs["GeneralUtilities`"] 17 | 18 | 19 | Attributes[Dual] = {Listable}; 20 | 21 | 22 | 23 | Dual /: DualCoordinates[HoldPattern[d : Dual[xs__]], pad_ : False] := 24 | If[TrueQ[pad], PadRight[{xs}, 2 ^ DualDimension[d]], {xs}] 25 | 26 | DualCoordinates[x : Except[_Dual], ___] := {x} 27 | 28 | Attributes[DualCoordinates] = {Listable}; 29 | 30 | 31 | Dual /: DualRe[Dual[x_, __]] := x 32 | 33 | DualRe[x : Except[_Dual]] := x 34 | 35 | Attributes[DualRe] = {Listable, NumericFunction}; 36 | 37 | 38 | Dual /: DualEps[Dual[_, y_]] := y 39 | 40 | Dual /: DualEps[Dual[_, y__]] := {y} 41 | 42 | DualEps[Except[_Dual]] := 0 43 | 44 | Attributes[DualEps] = {Listable, NumericFunction}; 45 | 46 | 47 | DualDimension[HoldPattern[Dual[xs__]]] := Ceiling @ Log2[Length @ {xs}] 48 | 49 | DualDimension[Except[_Dual]] := 1 50 | 51 | 52 | DualBasis[n_Integer] := Table[Dual @@ UnitVector[2 ^ n, i], {i, 2 ^ n}] 53 | 54 | 55 | Dual[x : Except[_Dual]] := Dual[x, 0] 56 | 57 | 58 | Dual[x_, 0 ...] := x 59 | 60 | Dual[] := 0 61 | 62 | 63 | Dual /: Dual[ds : PatternSequence[___, _Dual, ___]] := 64 | Total @ MapIndexed[Function[{x, i}, x ** Dual @@ UnitVector[Length[{ds}], First[i]], HoldAllComplete], {ds}] 65 | 66 | 67 | dualFunction[f_, arity_Integer, n_Integer] := dualFunction[f, arity, n] = With[{ 68 | es = Array[\[FormalE], n], 69 | ps = Array[Times @@ (\[FormalE] @* First /@ Position[Reverse @ IntegerDigits[#, 2, n], 1]) &, 2 ^ n, 0], 70 | coeffs = Array[Function[{i, j}, Slot[i * 2 ^ n + j + 1]], {arity, 2 ^ n}, 0] 71 | }, 72 | Dual @@ Map[ 73 | Function[subset, 74 | D[Apply[f, Total[ps #] & /@ coeffs], Sequence @@ subset] /. Alternatives @@ es -> 0 75 | ], 76 | Subsets[es] 77 | ] // Evaluate // Function 78 | ] 79 | 80 | 81 | applyDualFunction[f_, coeffs_, n_Integer] := With[{ 82 | es = Array[\[FormalE], n], 83 | ps = Array[Times @@ (\[FormalE] @* First /@ Position[Reverse @ IntegerDigits[#, 2, n], 1]) &, 2 ^ n, 0] 84 | }, 85 | Dual @@ Map[ 86 | Function[subset, 87 | D[f[Total[ps coeffs]], Sequence @@ subset] /. Alternatives @@ es -> 0 88 | ], 89 | Subsets[es] 90 | ] 91 | ] 92 | 93 | 94 | (* Dual magic here *) 95 | applyDuals[f_, values_List] := Module[{ 96 | coords = DualCoordinates /@ values, 97 | xs, arity, n 98 | }, 99 | arity = Length[values]; 100 | n = Ceiling @ Log2[Max[Length /@ coords]]; 101 | xs = PadRight[#, 2 ^ n, 0] & /@ coords; 102 | Quiet[dualFunction[f, arity, n] @@ Catenate @ xs, {General::infy, General::indet}] /. Indeterminate -> 0 103 | ] 104 | 105 | 106 | Dual /: expr : f_[___, _Dual, ___] /; MatchQ[f, _Function] || numericFunctionQ[f] || ! hasDefinitionsQ[f] := 107 | applyDuals[f, Dual /@ List @@ Unevaluated[expr]] 108 | 109 | 110 | Dual[vs__Multivector] := With[{g = largestGeometricAlgebra[vs]}, 111 | Multivector[MapThread[Dual, Multivector[#, G]["Coordinates"] & /@ {vs}], g] 112 | ] 113 | 114 | Dual[vs : PatternSequence[___, v_Multivector, ___]] := Apply[Dual, Multivector[#, v["GeometricAlgebra"]] & /@ {vs}] 115 | 116 | 117 | multivectorDuals[v_Multivector] := With[{n = v["CoordinateDimension"]}, 118 | Multivector[#, v["GeometricAlgebra"]] & /@ Transpose[PadRight[#, 2 ^ n] & /@ DualCoordinates /@ v["Coordinates"]] 119 | ] 120 | 121 | multivectorDuals[x : Except[_Multivector]] := multivectorDuals[Multivector[x, 0]] 122 | 123 | 124 | subsetOrders[n_Integer] := Length /@ Subsets[Range[n]] 125 | 126 | antiProductSigns[n_Integer, m_Integer] := With[{ 127 | leftOrders = subsetOrders @ n, 128 | rightOrders = subsetOrders @ m 129 | }, 130 | Partition[(-1) ^ Times @@@ Tuples[{leftOrders, rightOrders}], 2 ^ m] 131 | ] 132 | 133 | 134 | 135 | negativeQ[x_] := NumericQ[x] && Quiet[Check[Negative[x], False]] || MatchQ[x, - _] 136 | 137 | 138 | MakeBoxes[d : HoldPattern[Dual[xs__]], fmt_] := Module[{ 139 | n, zboxes, displayBox 140 | }, 141 | n = Ceiling @ Log2[Length @ {xs}]; 142 | zboxes = Parenthesize[#, fmt, Plus] & /@ {xs}; 143 | displayBox = RowBox @ MapAt[Replace["+" -> Nothing], 1] @ 144 | MapIndexed[Function[{x, i}, With[{k = i[[1]]}, 145 | Splice @ { 146 | If[ x === 0, 147 | Nothing, 148 | Splice @ {If[negativeQ[x], Nothing, "+"], Which[k > 1 && x === 1, Nothing, k > 1 && x === - 1, "-", True, Slot[k]] , 149 | If[ k > 1, 150 | If[ n > 1, 151 | SubscriptBox[ 152 | "\[Epsilon]", 153 | RowBox @ Riffle[First @ Subsets[Range[n], All, {k}], "\[InvisibleSpace]"] 154 | ], 155 | "\[Epsilon]" 156 | ], 157 | Nothing 158 | ], "\[InvisibleSpace]"} 159 | ] 160 | } 161 | ]], 162 | {xs} 163 | ]; 164 | TemplateBox[ 165 | zboxes, 166 | "Dual", 167 | DisplayFunction -> Function[Evaluate[displayBox]], 168 | InterpretationFunction -> Dual, 169 | Tooltip -> SuperscriptBox["\[DoubleStruckCapitalD]", n] 170 | ] 171 | ] 172 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/GeneralRelativity.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`GeneralRelativity`"] 2 | 3 | PackageImport["Wolfram`GeometricAlgebra`"] 4 | 5 | PackageExport[CoordinateFrames] 6 | PackageExport[TetradFrames] 7 | PackageExport[Vierbein] 8 | PackageExport[InverseVierbein] 9 | PackageExport[ToTetrad] 10 | PackageExport[ToInverseTetrad] 11 | 12 | PackageExport[PartialDerivatives] 13 | PackageExport[CoordinateDerivative] 14 | PackageExport[VectorDerivative] 15 | PackageExport[CovariantDerivative] 16 | PackageExport[SpinConnection] 17 | PackageExport[SpinConnectionComponents] 18 | PackageExport[ChristoffelSymbols] 19 | PackageExport[RiemannMap] 20 | PackageExport[RicciMap] 21 | PackageExport[RicciScalar] 22 | PackageExport[WeylMap] 23 | PackageExport[KretschmannScalar] 24 | PackageExport[EinsteinMap] 25 | 26 | 27 | 28 | $DefaultVars = {\[FormalT], \[FormalX], \[FormalY], \[FormalZ]} 29 | 30 | 31 | CanonicalVariableName[v_Symbol ? AtomQ] := With[{w = Unevaluated @@ ResourceFunction["UnformalizeSymbols"][v, "DeferQ" -> True]}, ToString[w]] 32 | 33 | CanonicalVariableName[v_] := v 34 | 35 | $DefaultNames = CanonicalVariableName /@ $DefaultVars 36 | 37 | 38 | PartialDerivatives[vars : {__Symbol ? AtomQ} : $DefaultVars] := (v |-> D[#, v] &) /@ vars 39 | 40 | 41 | Vierbein[g_ ? GeometricAlgebraQ] := g["VectorBasis"] 42 | 43 | InverseVierbein[g_ ? GeometricAlgebraQ] := Inverse[Vierbein[g]] 44 | 45 | 46 | ToTetrad[g_ ? GeometricAlgebraQ] := GeometricAlgebra[g["Signature"]] 47 | 48 | ToTetrad[v_ ? MultivectorQ] := ConvertGeometricAlgebra[v, ToTetrad[GeometricAlgebra[v]]] 49 | 50 | ToInverseTetrad[g_ ? GeometricAlgebraQ] := GeometricAlgebra[g["Signature"], "VectorBasis" -> g["SignatureMetric"]] 51 | 52 | ToInverseTetrad[v_ ? MultivectorQ] := ConvertGeometricAlgebra[v, ToInverseTetrad[GeometricAlgebra[v]]] 53 | 54 | 55 | TetradFrames[vectorNames : {_, _, _, _} : $DefaultNames, name_ : "\[Gamma]", indexName_ : "m"] := With[{ 56 | repl = Append["e" -> name] @ Thread[{1, UnderBar[3], UnderBar[2], UnderBar[1]} -> CanonicalVariableName /@ vectorNames] 57 | }, 58 | { 59 | GeometricAlgebra[1, 3, 60 | "Format" -> Subscript[name, indexName], 61 | "FormatIndex" -> Function[ 62 | $DefaultMultivectorFormatFunction[#] /. repl 63 | ] 64 | ], 65 | GeometricAlgebra[1, 3, 66 | "Format" -> Superscript[name, indexName], 67 | "FormatIndex" -> Function[ 68 | $DefaultMultivectorFormatFunction[#] /. Append[Subscript -> Superscript] @ repl 69 | ], 70 | "VectorBasis" -> DiagonalMatrix[{1, -1, -1, -1}] 71 | ] 72 | } 73 | ] 74 | 75 | 76 | CoordinateFrames[e_ /; SquareMatrixQ[e] && Dimensions[e] == {4, 4}, vectorNames : {_, _, _, _} : $DefaultNames, name_ : "g", indexName_ : "\[Mu]"] := With[{ 77 | repl = Append["e" -> name] @ Thread[{1, UnderBar[3], UnderBar[2], UnderBar[1]} -> CanonicalVariableName /@ vectorNames], 78 | eta = DiagonalMatrix[{1, -1, -1, -1}] 79 | }, 80 | { 81 | GeometricAlgebra[1, 3, 82 | "Format" -> Subscript[name, indexName], 83 | "FormatIndex" -> Function[ 84 | $DefaultMultivectorFormatFunction[#] /. repl 85 | ], 86 | "VectorBasis" -> e 87 | ], 88 | GeometricAlgebra[1, 3, 89 | "Format" -> Superscript[name, indexName], 90 | "FormatIndex" -> Function[ 91 | $DefaultMultivectorFormatFunction[#] /. Append[Subscript -> Superscript] @ repl 92 | ], 93 | "VectorBasis" -> eta . Inverse[e] 94 | ] 95 | } 96 | ] 97 | 98 | 99 | CoordinateDerivative[g_ ? GeometricAlgebraQ, vars : {__Symbol ? AtomQ} : $DefaultVars] /; g["Dimension"] == Length[vars] := With[{ 100 | pd = PartialDerivatives[vars] 101 | }, 102 | Multivector[pd . g["SignatureMetric"] . g["Basis", 1], Right][Identity] 103 | ] 104 | 105 | CoordinateDerivative[vars : {__Symbol ? AtomQ} : $DefaultVars] := CoordinateDerivative[TetradFrames[CanonicalVariableName /@ vars][[2]], vars] 106 | 107 | 108 | SpinConnection[g_ ? GeometricAlgebraQ, vars : {__Symbol ? AtomQ} : $DefaultVars] := With[{ 109 | cd = CoordinateDerivative[g, vars], 110 | pd = PartialDerivatives[vars], 111 | e = Vierbein[g], 112 | gmu = g["SignatureMetric"] . g["Basis", 1] 113 | }, 114 | ConvertGeometricAlgebra[ 115 | 1 / 2 Total @ MapThread[ 116 | Wedge[#1, Flatten[GeometricProduct[cd, Multivector[#2, g]]]] &, 117 | {gmu, #} 118 | ], 119 | g 120 | ] & /@ g["Metric"] + (Inner[Wedge, g["Basis", 1], ToInverseTetrad[g]["Basis", 1] . #[e]] & /@ pd) 121 | ] 122 | 123 | SpinConnectionComponents[omega : {Repeated[_ ? MultivectorQ, {4}]}] := With[{eta = omega[[1]]["SignatureMetric"]}, 124 | eta . # & /@ Transpose[ 125 | ArrayReshape[Comap[ToInverseTetrad /@ omega, Tuples[{1, -3, -2, -1}, 2]], {4, 4, 4}], 126 | {3, 2, 1} 127 | ] 128 | ] 129 | 130 | ChristoffelSymbols[g_ ? GeometricAlgebraQ, vars : {__Symbol ? AtomQ} : $DefaultVars] := With[{ 131 | omega = SpinConnectionComponents[SpinConnection[g, vars]], 132 | pd = PartialDerivatives[vars], 133 | e = Vierbein[g], 134 | einv = InverseVierbein[g] 135 | }, 136 | Transpose[einv] . Transpose[#[e] & /@ pd, {3, 1, 2}] + einv . Transpose[e . omega] 137 | ] 138 | 139 | 140 | VectorDerivative[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] /; g["Dimension"] == Length[vars] := With[{ 141 | cd = CoordinateDerivative[g, vars], 142 | omega = SpinConnection[g, vars] 143 | }, 144 | Multivector[Grade[(w |-> 1 / 2 Commutator[w, #] &) /@ omega, 1, g], Right] 145 | ] 146 | 147 | 148 | RiemannMap[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := With[{ 149 | omega = ToTetrad /@ SpinConnection[g, vars], 150 | pd = PartialDerivatives[vars], 151 | e = InverseVierbein[g] 152 | }, 153 | Map[ConvertGeometricAlgebra[#, g] &, Transpose[e] . (Outer[#2[#1] &, pd, omega] - Outer[#1[#2] &, omega, pd] + 1 / 2 Outer[Commutator, omega, omega]) . e, {2}] 154 | ] 155 | 156 | RicciMap[riemann_ ? SquareMatrixQ] := With[{g = GeometricAlgebra[riemann[[1, 1]]]}, 157 | ConvertGeometricAlgebra[#, g] & /@ Inner[Dot, ToInverseTetrad[g]["Basis", 1], riemann] 158 | ] 159 | 160 | RicciMap[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := RicciMap[RiemannMap[g, vars]] 161 | 162 | RicciScalar[ricci_ ? VectorQ] := Inner[Dot, ToInverseTetrad[GeometricAlgebra[ricci[[1]]]]["Basis", 1], ricci] 163 | 164 | RicciScalar[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := RicciScalar[RicciMap[g, vars]] 165 | 166 | WeylMap[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := With[{gamma = ToTetrad[g]["Basis", 1], riemann = RiemannMap[g, vars]}, {ricci = RicciMap[riemann]}, {r = RicciScalar[ricci]}, 167 | riemann - 1 / 2 (Outer[Wedge, ricci, gamma] + Outer[Wedge, gamma, ricci]) + 1 / 6 GeometricProduct[r, Outer[Wedge, gamma, gamma]] 168 | ] 169 | 170 | EinsteinMap[ricci_ ? VectorQ] := With[{g = GeometricAlgebra[ricci[[1]]]}, {gamma = ToTetrad[g]["Basis", 1], r = RicciScalar[ricci]}, 171 | MapThread[ConvertGeometricAlgebra[#2 - 1 / 2 GeometricProduct[#1, r], g] &, {gamma, ricci}] 172 | ] 173 | 174 | EinsteinMap[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := EinsteinMap[RicciMap[g, vars]] 175 | 176 | KretschmannScalar[g_ ? GeometricAlgebraQ, vars_ : $DefaultVars] := With[{r = Map[ToInverseTetrad, RiemannMap[g, vars], {2}], eta = g["SignatureMetric"]}, 177 | ConvertGeometricAlgebra[Tr @ Tr[r . eta . r . eta], g] 178 | ] 179 | 180 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/GeometricAlgebra.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | 4 | PackageExport["GeometricAlgebra"] 5 | PackageExport["GeometricAlgebraQ"] 6 | 7 | PackageScope["$GeometricAlgebraProperties"] 8 | PackageScope["lowerGeometricAlgebra"] 9 | PackageScope["higherGeometricAlgebra"] 10 | 11 | 12 | GeometricAlgebra::usage = "GeometricAlgebra[p, q] gives an underlying algebra object for use with Multivector"; 13 | 14 | 15 | Options[GeometricAlgebra] = {"Signature" -> {3, 0, 0}, "VectorBasis" -> Automatic, "Format" -> Automatic, "FormatIndex" -> Automatic, "Ordering" -> Automatic} 16 | 17 | 18 | $GeometricAlgebraProperties = { 19 | "Format", 20 | "FormatIndex", 21 | 22 | "Signature", 23 | "ComplexSignature", 24 | "DualSignature", 25 | 26 | "Dimension", 27 | "DualDimension", 28 | "ComplexDimension", 29 | "NegativeDimension", 30 | "NonNegativeDimension", 31 | 32 | "Order", 33 | "ComplexOrder", 34 | "DualOrder", 35 | 36 | "Ordering", 37 | 38 | "VectorBasis", 39 | "SignatureMetric", 40 | "Metric", 41 | "MetricSignature", 42 | "Indices", 43 | "DualIndices", 44 | "OrderedIndices", 45 | "ReIndices", 46 | "ImIndexSigns", 47 | 48 | "Basis", 49 | "PseudoBasis", 50 | "OrderedBasis", 51 | 52 | "MultiplicationMatrix", 53 | "MultiplicationTable", 54 | "ExomorphismMatrix", 55 | "AntiExomorphismMatrix", 56 | 57 | "PseudoscalarIndex", 58 | "PseudoscalarSquare", 59 | 60 | "BalancedAlgebra", 61 | "ComplexAlgebra", 62 | 63 | "Zero", 64 | "Identity", 65 | "Origin", 66 | "Infinity" 67 | }; 68 | 69 | 70 | geometricAlgebraQ[HoldPattern[GeometricAlgebra[data_Association ? AssociationQ]]] := 71 | MatchQ[data, KeyValuePattern["Signature" -> {Repeated[_Integer ? NonNegative, {3}]}]]; 72 | 73 | geometricAlgebraQ[___] := False 74 | 75 | 76 | GeometricAlgebraQ[g_GeometricAlgebra] := System`Private`HoldValidQ[g] || geometricAlgebraQ[Unevaluated[g]] 77 | 78 | GeometricAlgebraQ[___] := False 79 | 80 | 81 | GeometricAlgebra[p_Integer, q_Integer: 0, r_Integer: 0, opts: OptionsPattern[]] := 82 | GeometricAlgebra["Signature" -> {p, q, r}, opts] 83 | 84 | GeometricAlgebra[{p_Integer, q___Integer}, opts: OptionsPattern[]] := GeometricAlgebra[p, q, opts] 85 | 86 | GeometricAlgebra[g_GeometricAlgebra, opts: OptionsPattern[]] := 87 | GeometricAlgebra[Merge[Join[FilterRules[{opts}, Options[GeometricAlgebra]], Options[g]], First]] 88 | 89 | GeometricAlgebra[] := OptionValue[Multivector, "GeometricAlgebra"] (* current default GeometricAlgebra *) 90 | 91 | GeometricAlgebra[opts : OptionsPattern[]] := GeometricAlgebra[Association[opts]] 92 | 93 | GeometricAlgebra /: HoldPattern[Options[GeometricAlgebra[data_] ? GeometricAlgebraQ]] := Normal[data] 94 | 95 | GeometricAlgebra /: HoldPattern[Options[GeometricAlgebra[data_] ? GeometricAlgebraQ, filter_]] := FilterRules[Normal[data], filter] 96 | 97 | g_GeometricAlgebra[opt_String] /; KeyExistsQ[Options[GeometricAlgebra], opt] := With[{value = OptionValue[{Options[g], Options[GeometricAlgebra]}, opt]}, 98 | Switch[opt, 99 | "VectorBasis", 100 | Replace[value, Automatic :> If[g["Dimension"] == 0, {{}}, IdentityMatrix[g["Dimension"]]]], 101 | _, 102 | value 103 | ] 104 | ] 105 | 106 | g_GeometricAlgebra["Metric"] := Replace[g["VectorBasis"], { 107 | Automatic :> If[g["Dimension"] == 0, {{}}, DiagonalMatrix[g["MetricSignature"]]], 108 | b_ ? SquareMatrixQ :> Transpose[b] . DiagonalMatrix[g["MetricSignature"]] . b, 109 | b_ ? VectorQ :> g["MetricSignature"] * b ^ 2 110 | }] 111 | 112 | g_GeometricAlgebra["ComplexSignature"] := g["Signature"][[;; 2]] 113 | 114 | g_GeometricAlgebra["DualSignature" | "DualDimension"] := g["Signature"][[3]] 115 | 116 | g_GeometricAlgebra["Dimension"] := Total @ g["Signature"] 117 | 118 | g_GeometricAlgebra["NegativeDimension"] := g["Signature"][[2]] 119 | 120 | g_GeometricAlgebra["NonNegativeDimension"] := Total @ g["Signature"][[{1, 3}]] 121 | 122 | g_GeometricAlgebra["ComplexDimension"] := Total @ g["ComplexSignature"] 123 | 124 | g_GeometricAlgebra["Order"] := 2 ^ g["Dimension"] 125 | 126 | g_GeometricAlgebra["ComplexOrder"] := 2 ^ g["ComplexDimension"] 127 | 128 | g_GeometricAlgebra["DualOrder"] := 2 ^ g["DualDimension"] 129 | 130 | g_GeometricAlgebra["MetricSignature"] := 131 | Module[{p, q, r}, 132 | {p, q, r} = g["Signature"]; 133 | Join[ConstantArray[1, p], ConstantArray[0, r], ConstantArray[-1, q]] 134 | ] 135 | 136 | g_GeometricAlgebra["SignatureMetric"] := DiagonalMatrix[g["MetricSignature"]] 137 | 138 | g_GeometricAlgebra["Indices"] := g["Indices"] = Block[{ 139 | p, q, r 140 | }, 141 | {p, q, r} = g["Signature"]; 142 | Subsets[Join[Range[p], p + Range[r], Range[- q, -1]]] 143 | ] 144 | 145 | g_GeometricAlgebra["OrderedIndices"] := g["OrderedIndices"] = 146 | With[{s = g["Signature"]}, Replace[g["Ordering"], {Automatic :> g["Indices"], xs : {{___Integer} ...} :> Map[normalIndex[#, s] &, xs, {2}]}]] 147 | 148 | g_GeometricAlgebra["DualIndices"] := With[{i = Last @ g["Indices"]}, 149 | Map[DeleteElements[i, #] &, g["Indices"]] 150 | ] 151 | 152 | g_GeometricAlgebra["PseudoscalarIndex"] := g["PseudoscalarIndex"] = With[{i = Last[g["Indices"]]}, 153 | If[g["Ordering"] === Automatic, i, SelectFirst[g["OrderedIndices"], Sort[#] == i &, i]] 154 | ] 155 | 156 | g_GeometricAlgebra["PseudoscalarSquare"] := Block[{p, q, r}, 157 | {p, q, r} = g["Signature"]; 158 | If[r == 0, (- 1) ^ ((p - q) * (p - q - 1) / 2), 0] 159 | ] 160 | 161 | 162 | g_GeometricAlgebra["BalancedAlgebra"] := With[{n = Floor[g["ComplexDimension"] / 2], r = g["DualDimension"]}, 163 | If[ OddQ[g["ComplexDimension"]], 164 | If[ g["PseudoscalarSquare"] == 1, 165 | GeometricAlgebra[n + 1 + r, n + r], 166 | GeometricAlgebra[n + r, n + 1 + r] 167 | ], 168 | GeometricAlgebra[n + r, n + r] 169 | ] 170 | ] 171 | 172 | g_GeometricAlgebra["ComplexAlgebra"] := Block[{p, q, r}, 173 | {p, q, r} = g["Signature"]; 174 | If[ r > 0, 175 | GeometricAlgebra[p + r, q + r], 176 | g 177 | ] 178 | ] 179 | 180 | 181 | middleIndex[g_GeometricAlgebra] := Module[{p, q}, 182 | {p, q} = g["ComplexSignature"]; 183 | Join[Range[p], Range[-q, -1]][[Ceiling[(p + q) / 2]]] 184 | ] 185 | 186 | g_GeometricAlgebra["ReIndices"] := Cases[g["Indices"], _List ? (FreeQ[#, middleIndex[g]] &)] 187 | 188 | g_GeometricAlgebra["ImIndexSigns"] := With[{i = Last @ g["Indices"]}, Rule @@ KeyMap[Reverse] @ multiplyIndices[i, #, g["Metric"]] & /@ g["ReIndices"]] 189 | 190 | 191 | GeometricAlgebra /: Equal[gs__GeometricAlgebra]:= Equal @@ Through[{gs}["Signature"]] && Equal @@ Through[{gs}["VectorBasis"]] 192 | 193 | 194 | g_GeometricAlgebra /; System`Private`HoldNotValidQ[g] && geometricAlgebraQ[Unevaluated[g]] := System`Private`SetNoEntry[System`Private`HoldSetValid[g]] 195 | 196 | 197 | (* Boxes *) 198 | 199 | 200 | GeometricAlgebra /: MakeBoxes[g_GeometricAlgebra /; GeometricAlgebraQ[Unevaluated[g]], form___] := With[{ 201 | box = ToBoxes[Replace[g["Format"], Automatic :> Subscript["\[DoubleStruckCapitalG]", Row @ Riffle[ToString /@ Replace[MapAt[Replace[0 -> Nothing], g["Signature"], {3}], {p_, 0} :> {p}], ","]]], form], 202 | tooltip = RowBox[{"Geometric Algebra", ToBoxes[g["Signature"], form]}] 203 | }, 204 | InterpretationBox[box, g, Tooltip -> tooltip] 205 | ] 206 | 207 | 208 | (* Utility functions *) 209 | 210 | lowerGeometricAlgebra[g_GeometricAlgebra] := Module[{ 211 | p, q, r 212 | }, 213 | {p, q, r} = g["Signature"]; 214 | GeometricAlgebra @ If[p >= q, {Max[p - 1, 0], q, r}, {p, q - 1, r}] 215 | ] 216 | 217 | higherGeometricAlgebra[g_GeometricAlgebra] := Module[{ 218 | p, q, r 219 | }, 220 | {p, q, r} = g["Signature"]; 221 | GeometricAlgebra @ If[p > q, {p, q + 1, r}, {p + 1, q, r}] 222 | ] 223 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/GeometricMatrix.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | 4 | PackageExport["MultivectorFunction"] 5 | PackageExport["MultivectorPower"] 6 | PackageExport["MultivectorExp"] 7 | PackageExport["MultivectorLog"] 8 | PackageExport["CanonicalGeometricAlgebra"] 9 | PackageExport["CanonicalGeometricIndices"] 10 | PackageExport["ConvertGeometricAlgebra"] 11 | PackageExport["CanonicalMultivector"] 12 | PackageExport["MultivectorMatrix"] 13 | PackageExport["MatrixMultivector"] 14 | PackageExport["MultivectorBlock"] 15 | PackageExport["LeftKroneckerProduct"] 16 | PackageExport["RightKroneckerProduct"] 17 | PackageExport["DualComplexMultivector"] 18 | PackageExport["ComplexDualMultivector"] 19 | 20 | PackageScope["nilpotentBasis"] 21 | PackageScope["nilpotentMatrix"] 22 | PackageScope["multivectorBasisMatrix"] 23 | 24 | 25 | Options[kroneckerProduct] = {"Direction" -> Left, "Flatten" -> True}; 26 | 27 | kroneckerProduct[va_MultivectorArray, wa_MultivectorArray, OptionsPattern[]] := With[{ 28 | a = GeometricProduct[va, wa], 29 | r = va["Rank"], 30 | s1 = va["Shape"], 31 | s2 = wa["Shape"], 32 | dir = OptionValue["Direction"] 33 | }, 34 | If[ OptionValue["Flatten"], 35 | MultivectorArray[ 36 | Flatten[If[dir === Left, Transpose[#, r <-> r + 1] &, Identity][a["Components"]], {{r, r + 1}}], 37 | Join[s1[[;; -2]], {If[dir === Left, Sign[s1[[-1]]], Sign[s2[[1]]]] Abs[s1[[-1]] s2[[1]]]}, s1[[2 ;;]]] 38 | ], 39 | MultivectorArray[ 40 | If[dir === Left, Transpose[#, r <-> r + 1] &, Identity][a["Components"]], 41 | Join[s1, s2] 42 | ] 43 | ] 44 | ] 45 | 46 | kroneckerProduct[va_MultivectorArray, OptionsPattern[]] := va 47 | 48 | kroneckerProduct[vas__MultivectorArray, opts : OptionsPattern[]] := Fold[kroneckerProduct[##, opts] &, {vas}] 49 | 50 | kroneckerProduct[OptionsPattern[]] := MultivectorArray[{Multivector[{1}, {0, 0}]}, {If[OptionValue["Direction"] === Left, - 1, 1]}] 51 | 52 | 53 | LeftKroneckerProduct[vas___MultivectorArray] := kroneckerProduct[vas, "Direction" -> Left] 54 | 55 | RightKroneckerProduct[vas___MultivectorArray] := kroneckerProduct[vas, "Direction" -> Right] 56 | 57 | 58 | CanonicalGeometricAlgebra[g_GeometricAlgebra] := Block[{ 59 | p, q, r, n, n1, n2, indexConversion, newIndex 60 | }, 61 | {p, q, r} = g["Signature"]; 62 | n = p + q; 63 | n1 = Floor[n / 2]; 64 | n2 = Ceiling[n / 2]; 65 | indexConversion = CanonicalGeometricIndices[g]; 66 | newIndex = Map[ 67 | With[{c = indexConversion[#][[1]], index = geometricIndexFormat[g, #]}, 68 | indexConversion[#][[2]] -> Switch[c, 69 | -1 | -I, Row[{"(", c, ")", index}], 70 | I, Row[{"\[ImaginaryI]", index}], 71 | _, index 72 | ] 73 | ] &, 74 | g["Indices"] 75 | ]; 76 | GeometricAlgebra[{n1, n2, r}, "FormatIndex" -> newIndex] 77 | ] 78 | 79 | 80 | CanonicalGeometricIndices[g_GeometricAlgebra] := Block[{ 81 | n1, n2, p, q, r, n, complexIndices, newIndex 82 | }, 83 | {p, q, r} = g["Signature"]; 84 | n = p + q; 85 | n1 = Floor[n / 2]; 86 | n2 = Ceiling[n / 2]; 87 | If[ p > q, 88 | complexIndices = Range[n1 + 1, p]; 89 | newIndex = AssociationMap[index |-> ( 90 | { 91 | #2 * (I ^ Count[index, _ ? (MemberQ[complexIndices, #] &)]), 92 | #1 93 | } & @@ orderIndexWithSign[Map[Which[# > p, # - (p - n1), MemberQ[complexIndices, #], # - n - 1, True, #] &, index], n + r]) 94 | , 95 | g["Indices"] 96 | ], 97 | complexIndices = Range[-n2 - 1, -q, -1]; 98 | newIndex = AssociationMap[index |-> ( 99 | { 100 | #2 * (I ^ Count[index, _ ? (MemberQ[complexIndices, #] &)]), 101 | #1 102 | } & @@ orderIndexWithSign[Map[Which[# > p, # - (p - n1), MemberQ[complexIndices, #], # + n + 1, True, #] &, index], n + r]) 103 | , 104 | g["Indices"] 105 | ] 106 | ]; 107 | newIndex 108 | ] 109 | 110 | 111 | Options[ConvertGeometricAlgebra] = {"Pseudoscalar" -> I}; 112 | 113 | ConvertGeometricAlgebra[ 114 | v_Multivector, 115 | g_GeometricAlgebra, 116 | opts: OptionsPattern[ConvertGeometricAlgebra]] := Block[{ 117 | h = GeometricAlgebra[v], toCanonicConversion, fromCanonicConversion, canonicCoordinates, i, w 118 | }, 119 | If[ h == g, Return[Multivector[v["Coordinates"], g]]]; 120 | If[ v["ComplexDimension"] + 2 v["DualDimension"] != g["ComplexDimension"] + 2 g["DualDimension"], 121 | Return[Multivector[v, g]] 122 | ]; 123 | If[ g["DualDimension"] > v["DualDimension"], 124 | Return[ConvertGeometricAlgebra[ComplexDualMultivector[v, g["DualDimension"] - v["DualDimension"]], g, opts]] 125 | ]; 126 | If[ g["DualDimension"] < v["DualDimension"], 127 | Return[ConvertGeometricAlgebra[ComplexDualMultivector[DualComplexMultivector[v], g["DualDimension"]], g, opts]] 128 | ]; 129 | toCanonicConversion = CanonicalGeometricIndices[v["GeometricAlgebra"]]; 130 | fromCanonicConversion = CanonicalGeometricIndices[g]; 131 | canonicCoordinates = Association @ MapThread[Function[{x, y}, y[[2]] -> x y[[1]]], 132 | {h["InverseBasisMatrix"] . v["Coordinates"], Values[toCanonicConversion]} 133 | ]; 134 | i = OptionValue["Pseudoscalar"]; 135 | 136 | w = Total @ KeyValueMap[ 137 | With[{c = canonicCoordinates[#2[[2]]] Conjugate[#2[[1]]]}, 138 | Multivector[<|#1 -> If[i != I, Re[c] + Im[c] i, c]|>, g] 139 | ] &, 140 | fromCanonicConversion 141 | ]; 142 | 143 | Multivector[g["BasisMatrix"] . w["Coordinates"], g][Identity] 144 | ] 145 | 146 | ConvertGeometricAlgebra[v_Multivector, args: Except[OptionsPattern[]], opts: OptionsPattern[]] := 147 | ConvertGeometricAlgebra[v, GeometricAlgebra[args, FilterRules[{opts}, Options[GeometricAlgebra]]], opts] 148 | 149 | 150 | CanonicalMultivector[v_Multivector, opts : OptionsPattern[]] := 151 | ConvertGeometricAlgebra[ 152 | v, 153 | GeometricAlgebra[CanonicalGeometricAlgebra[GeometricAlgebra[v]]["Signature"]], 154 | opts 155 | ] 156 | 157 | 158 | fromRealCanonicalMultivector[v_Multivector, g_GeometricAlgebra] /; 159 | CanonicalGeometricAlgebra[v["GeometricAlgebra"]]["Signature"] == v["Signature"] := 160 | Block[{ 161 | assoc, G, is, j 162 | }, 163 | G = v["GeometricAlgebra"]; 164 | assoc = v["Association"]; 165 | is = Association[ 166 | # -> multiplyIndices[#, Last @ G["Indices"], G["Metric"]] & /@ 167 | Cases[CanonicalGeometricIndices[g], HoldPattern[_ -> {c_, i_} /; MatchQ[c, I | -I]] :> i] 168 | ]; 169 | j = With[{keys = Complement[v["Indices"], Keys[is]]}, AssociationThread[keys, Lookup[assoc, Key /@ keys, 0]]]; 170 | Multivector[ 171 | Association[I Values[#] . Lookup[assoc, Keys[#], 0] & /@ is, j], 172 | G 173 | ] 174 | ] 175 | 176 | 177 | Options[MultivectorMatrix] = {"Basis" -> Automatic}; 178 | 179 | MultivectorMatrix[v_Multivector, opts: OptionsPattern[]] := Block[{ 180 | w, p, q, n, X, M, mat 181 | }, 182 | w = DualComplexMultivector[v]; 183 | {p, q} = w["ComplexSignature"]; 184 | 185 | n = Floor[(p + q) / 2]; 186 | 187 | M = MatrixInverse @ If[ 188 | OptionValue["Basis"] === Automatic, 189 | nilpotentMatrix[n], 190 | 191 | multivectorBasisMatrix[OptionValue["Basis"]] 192 | ]; 193 | X = MultivectorNumber /@ ConvertGeometricAlgebra[w, w["BalancedAlgebra"]]["ComplexCoordinates"]; 194 | mat = MultivectorArray[Partition[M . X, 2 ^ n]]; 195 | 196 | mat 197 | ] 198 | 199 | 200 | Options[MultivectorBlock] = {} 201 | 202 | MultivectorBlock[v_Multivector, opts: OptionsPattern[]] := Block[{ 203 | w, G, n, p, q, X, F, B 204 | }, 205 | w = DualComplexMultivector[v]; 206 | {p, q} = w["ComplexSignature"]; 207 | 208 | n = Floor[(p + q) / 2]; 209 | If[ n > 0, 210 | G = GeometricAlgebra @ MapThread[Max, {w["BalancedAlgebra"]["Signature"] - {1, 1, 0}, {0, 0, 0}}]; 211 | X = MultivectorNumber[#, G["BalancedAlgebra"]] & /@ ConvertGeometricAlgebra[w, w["BalancedAlgebra"]]["ComplexCoordinates"]; 212 | F = MatrixInverse @ nilpotentMatrix[n]; 213 | B = nilpotentMatrix[n - 1]; 214 | BlockMap[ 215 | Multivector[AssociationThread[G[If[OddQ[p + q], "ReIndices", "Indices"]], (B . Flatten[#, 1]) . X], G]["Flatten"] &, 216 | Partition[F, 2 ^ n], 217 | {2 ^ (n - 1), 2 ^ (n - 1)} 218 | ], 219 | 220 | {{w}} 221 | ] // MultivectorArray 222 | ] 223 | 224 | MultivectorBlock[v_Multivector, n_Integer /; n > 0, opts : OptionsPattern[MultivectorMatrix]] := 225 | With[{ 226 | blocks = MultivectorBlock[v, opts] 227 | }, 228 | If[ n > 1, 229 | MultivectorArray @ Flatten[Map[MultivectorBlock[#, n - 1, opts]["Components"] &, blocks["Components"], {2}], {{1, 3}, {2, 4}}], 230 | blocks 231 | ] 232 | ] 233 | 234 | MultivectorBlock[v_Multivector, 0, ___] := MultivectorArray[{{v}}] 235 | 236 | 237 | Options[MatrixMultivector] = {"Basis" -> Automatic, Method -> "Matrix"}; 238 | 239 | MatrixMultivector::unknownMethod = "Method should be one of {\"Basis\", \"Matrix\"}"; 240 | MatrixMultivector::nonsq = "Not a square matrix"; 241 | MatrixMultivector::non2pow = "Matrix dimension `1` is not a power of 2"; 242 | MatrixMultivector::invalidBasis = "Specified basis is not a multivector of right dimensions"; 243 | 244 | MatrixMultivector[mat_MultivectorArray, opts: OptionsPattern[]] := Block[{ 245 | dim, n, g, G, m, basis, M, X 246 | }, 247 | dim = Dimensions[mat]; 248 | If[ Length[dim] != 2 || Not[Equal @@ dim], 249 | Message[MatrixMultivector::nonsq]; 250 | Return[$Failed] 251 | ]; 252 | n = Log2[First @ dim]; 253 | If[ Not[IntegerQ[n]], 254 | Message[MatrixMultivector::non2pow, dim]; 255 | Return[$Failed] 256 | ]; 257 | 258 | g = mat["GeometricAlgebra"]; 259 | If[ g["ComplexDimension"] > 1, 260 | m = Floor[g["ComplexDimension"] / 2]; 261 | Return @ MatrixMultivector[ 262 | MultivectorArray[ 263 | Flatten[ 264 | Map[ 265 | MultivectorMatrix[#, Sequence @@ FilterRules[{opts}, Options[MultivectorMatrix]]]["Components"] &, 266 | mat["Components"], 267 | {mat["Rank"]} 268 | ], 269 | {{1, 3}, {2, 4}} 270 | ], 271 | {2 ^ (n + m), - 2 ^ (n + m)} 272 | ], 273 | opts 274 | ] 275 | ]; 276 | 277 | Switch[ 278 | OptionValue[Method], 279 | 280 | "Basis", 281 | 282 | If[ 283 | OptionValue["Basis"] === Automatic, 284 | 285 | (* Construct nilpotent basis *) 286 | basis = nilpotentBasis[n], 287 | 288 | (* Explicit basis *) 289 | If[ 290 | Not[MatchQ[OptionValue["Basis"], _MultivectorArray] && Dimensions[OptionValue["Basis"]] == Dimensions[mat]], 291 | 292 | Message[MatrixMultivector::invalidBasis]; 293 | Return[$Failed], 294 | 295 | basis = OptionValue["Basis"][CanonicalMultivector] 296 | ] 297 | 298 | ]; 299 | M = mat[MultivectorNumber]["Components"]; 300 | Total[MapThread[#2[Map[Curry[Times][#1]]] &, {M, basis["Components"]}, 2], 2], 301 | 302 | "Matrix", 303 | G = GeometricAlgebra[{n, n}]; 304 | X = Catenate @ mat[MultivectorNumber]["Components"]; 305 | M = If[ 306 | OptionValue["Basis"] === Automatic, 307 | 308 | nilpotentMatrix[n], 309 | 310 | If[ 311 | Not[MatchQ[OptionValue["Basis"], _MultivectorArray] && Dimensions[OptionValue["Basis"]] == Dimensions[mat]], 312 | 313 | Message[MatrixMultivector::invalidBasis]; 314 | Return[$Failed], 315 | 316 | multivectorBasisMatrix[OptionValue["Basis"]] 317 | 318 | ] 319 | ]; 320 | Multivector[ 321 | M . X, 322 | G 323 | ], 324 | 325 | _, 326 | Message[MatrixMultivector::unknownMethod]; 327 | $Failed 328 | ] 329 | ] 330 | 331 | MatrixMultivector[mat_MultivectorArray, g_GeometricAlgebra, opts : OptionsPattern[]] := Block[{cg = g["ComplexAlgebra"], bg = g["BalancedAlgebra"]}, 332 | ConvertGeometricAlgebra[ 333 | ComplexDualMultivector[ 334 | ConvertGeometricAlgebra[MatrixMultivector[mat, opts][Map[NumberMultivector[#, bg] &]]["Flatten"], cg], 335 | g["DualDimension"] 336 | ], 337 | g 338 | ] 339 | ] 340 | 341 | MatrixMultivector[mat_MultivectorArray, g_, opts : OptionsPattern[]] := MatrixMultivector[mat, GeometricAlgebra[g], opts] 342 | 343 | 344 | MultivectorFunction[f_ /; MatchQ[f, _Function] || numericFunctionQ[f], mat_ /; SquareMatrixQ[mat] && MatrixQ[mat, MultivectorQ], opts: OptionsPattern[]] := Enclose @ Block[{ 345 | re, im, g, d, a, b, result 346 | }, 347 | g = mat[[1, 1]]["GeometricAlgebra"]; 348 | d = g["Dimension"]; 349 | If[ d == 0, 350 | With[{duals = DualCoordinates[Map[#["Scalar"] &, mat, {2}]]}, 351 | With[{n = Ceiling @ Log2[Max[Map[Length, duals, {2}]]]}, 352 | result = applyDualFunction[ConfirmBy[MatrixFunction[f, #], MatrixQ] &, Transpose[Map[PadRight[#, 2 ^ n] &, duals, {2}], {2, 3, 1}], n] 353 | ] 354 | ] 355 | , 356 | re = Map[#["Scalar"] &, mat, {2}]; 357 | im = Map[#["Pseudoscalar"] &, mat, {2}]; 358 | Switch[g["PseudoscalarSquare"], 359 | 1, 360 | (* hyperbolic (split-complex) case *) 361 | With[{ 362 | aDuals = DualCoordinates[re + im], 363 | bDuals = DualCoordinates[re - im] 364 | }, 365 | With[{n = Ceiling @ Log2[Max[Map[Length, Join[aDuals, bDuals, 3], {2}]]]}, 366 | a = applyDualFunction[ConfirmBy[MatrixFunction[f, #], MatrixQ] &, Transpose[Map[PadRight[#, 2 ^ n] &, aDuals, {2}], {2, 3, 1}], n]; 367 | b = applyDualFunction[ConfirmBy[MatrixFunction[f, #], MatrixQ] &, Transpose[Map[PadRight[#, 2 ^ n] &, bDuals, {2}], {2, 3, 1}], n]; 368 | ] 369 | ]; 370 | result = MapThread[Function[{x, y}, Multivector[{x, y}, GeometricAlgebra[1, 0]], HoldAllComplete], {a + b, a - b} / 2, 2], 371 | 372 | -1, 373 | (* complex case *) 374 | With[{ 375 | aDuals = DualCoordinates[re + I im], 376 | bDuals = DualCoordinates[re - I im] 377 | }, 378 | With[{n = Ceiling @ Log2[Max[Map[Length, Join[aDuals, bDuals, 3], {2}]]]}, 379 | a = applyDualFunction[ConfirmBy[MatrixFunction[f, #], MatrixQ] &, Transpose[Map[PadRight[#, 2 ^ n] &, aDuals, {2}], {2, 3, 1}], n]; 380 | b = applyDualFunction[ConfirmBy[MatrixFunction[f, #], MatrixQ] &, Transpose[Map[PadRight[#, 2 ^ n] &, bDuals, {2}], {2, 3, 1}], n]; 381 | ] 382 | ]; 383 | result = MapThread[Function[{x, y}, Multivector[{x, - I y}, GeometricAlgebra[0, 1]], HoldAllComplete], {a + b, a - b} / 2, 2], 384 | 385 | _, 386 | Return[$Failed] 387 | ] 388 | ]; 389 | MultivectorArray[result] 390 | ] 391 | 392 | MultivectorFunction[f_ /; MatchQ[f, _Function] || numericFunctionQ[f], va_MultivectorArray ? MultivectorArrayQ, opts: OptionsPattern[]] := 393 | MultivectorFunction[f, Normal[va], opts] 394 | 395 | MultivectorFunction[f_ /; MatchQ[f, _Function] || numericFunctionQ[f], v_Multivector ? MultivectorQ, opts: OptionsPattern[]] := Enclose @ Block[{ 396 | w, x, y 397 | }, 398 | w = DualComplexMultivector[v]; 399 | x = Confirm @ MultivectorMatrix[w, FilterRules[{opts}, Options[MultivectorMatrix]]]; 400 | 401 | y = Confirm @ MultivectorFunction[f, x, opts]; 402 | 403 | ConvertGeometricAlgebra[ 404 | ConvertGeometricAlgebra[MatrixMultivector[y, w["BalancedAlgebra"], FilterRules[{opts}, Options[MatrixMultivector]]], w["GeometricAlgebra"]], 405 | v["GeometricAlgebra"] 406 | ] 407 | ] 408 | 409 | 410 | v_Multivector["Matrix"] := MultivectorMatrix[v] 411 | 412 | MultivectorPower[v_Multivector, n_] := MultivectorFunction[# ^ n &, v] 413 | 414 | MultivectorExp[v_Multivector, opts: OptionsPattern[]] := MultivectorFunction[Exp, v, opts] 415 | 416 | MultivectorLog[v_Multivector, opts: OptionsPattern[]] := MultivectorFunction[Log, v, opts] 417 | 418 | Multivector /: (f : Eigenvalues | Eigenvectors | Eigensystem)[v_Multivector, opts: OptionsPattern[]] := f[MultivectorMatrix[v, opts]["Numeric"]] 419 | 420 | 421 | DualComplexMultivector[v_Multivector] := Block[{ 422 | p, q, r, G 423 | }, 424 | {p, q, r} = v["Signature"]; 425 | If[r == 0, Return[v]]; 426 | G = GeometricAlgebra[p + r, q + r]; 427 | Multivector[ 428 | Association @ KeyValueMap[ 429 | Function[{k, x}, If[AnyTrue[k, GreaterThan[p]], With[{l = Replace[k, i_ :> If[i > p, p - q - i, i], 1]}, <|k -> x, l -> x|> / 2], k -> x]], 430 | v["Association"] 431 | ], 432 | G 433 | ] 434 | ] 435 | 436 | 437 | ComplexDualMultivector[v_Multivector, r_Integer : 1] := Block[{ 438 | p, q, G 439 | }, 440 | If[r == 0, Return[v]]; 441 | {p, q} = v["ComplexSignature"]; 442 | G = GeometricAlgebra[p - r, q - r, r]; 443 | Multivector[ 444 | Merge[KeyValueMap[Replace[#1, i_ :> If[i < - q + r, p - q - i, i], 1] -> #2 &, v["Association"]], Total], 445 | G 446 | ] 447 | ] 448 | 449 | (* Utility functions *) 450 | 451 | 452 | nilpotentBasis[0] := MultivectorArray[{{1}}] 453 | 454 | nilpotentBasis[n_Integer] := Block[{A, u, Bt, G}, 455 | G = GeometricAlgebra[n, n + 1]; 456 | A = Apply[LeftKroneckerProduct, 457 | Table[ 458 | MultivectorArray[{Multivector[1, G], G["Nilpotent", i]}], 459 | {i, 1, n} 460 | ] 461 | ]; 462 | u = Apply[GeometricProduct, Table[G["Idempotent", i], {i, 1, n}]]; 463 | Bt = Apply[RightKroneckerProduct, 464 | Reverse @ Table[ 465 | MultivectorArray[{Multivector[1, G], G["Nilpotent", -i]}, {-2}], 466 | {i, 1, n} 467 | ] 468 | ]; 469 | GeometricProduct[A, u, Bt] 470 | ] 471 | 472 | 473 | multivectorBasisMatrix[arr_MultivectorArray] := multivectorBasisMatrix[arr] = Block[{ 474 | n, m, sa, s 475 | }, 476 | n = Log2[arr["Dimension"]] / 2; 477 | m = 2 ^ n; 478 | If[Not @ arr["DoubleSquareQ"], Return[$Failed]]; 479 | sa = Array[s[##] &, {m, m}]; 480 | 481 | 482 | Coefficient[#["Scalar"], Flatten @ sa] & /@ 483 | MatrixMultivector[MultivectorArray[sa], Method -> "Basis", "Basis" -> arr[CanonicalMultivector]]["ComplexCoordinates"] 484 | ] 485 | 486 | 487 | nilpotentMatrix[n_Integer] := nilpotentMatrix[n] = multivectorBasisMatrix[nilpotentBasis[n]] 488 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/Multivector.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | 4 | PackageExport["Multivector"] 5 | Multivector::usage = "Multivector[coords, ga] gives a multivector in GeometricAlgebra ga"; 6 | 7 | PackageExport["MultivectorQ"] 8 | 9 | PackageExport["NumberMultivector"] 10 | NumberMultivector::usage = "NumberMultivector[x, ga] gives a multivector corresponding to a complex number x in geometric algebra ga"; 11 | 12 | PackageExport["MultivectorNumber"] 13 | MultivectorNumber::usage = "MultivectorNumber[v] gives a complex number based on scalar and pseudoscalar parts of multivector"; 14 | 15 | PackageExport["BalancedMultivector"] 16 | 17 | PackageExport["GeometricProduct"] 18 | GeometricProduct::usage = "GeometricProduct[vs__] computes geometric product of multivectors"; 19 | 20 | PackageExport["AntiGeometricProduct"] 21 | AntiGeometricProduct::usage = "AntiGeometricProduct[v, w] gives an anti geometric product of multivectors v and w"; 22 | 23 | PackageExport["Grade"] 24 | Grade::usage = "Grade[v, n] gives a nth grade of a Multivector v or converts a list to a multivector"; 25 | 26 | PackageExport["AntiGrade"] 27 | AntiGrade::usage = "AntiGrade[v, n] gives a nth anti grade of a Multivector v or converts a list to a multivector"; 28 | 29 | PackageExport["GradeList"] 30 | GradeList::usage = "GradeList[v] gives a list of all grades of multivector"; 31 | 32 | PackageExport["WedgeProduct"] 33 | WedgeProduct::usage = "WedgeProduct[v, w] gives a wedge product of multivectors v and w"; 34 | 35 | PackageExport["AntiWedgeProduct"] 36 | AntiWedgeProduct::usage = "AntiWedgeProduct[v, w] gives an anti wedge product of multivectors v and w"; 37 | 38 | PackageExport["DotProduct"] 39 | DotProduct::usage = "DotProduct[v, w] gives a dot product of multivectors v and w"; 40 | 41 | PackageExport["AntiDotProduct"] 42 | AntiDotProduct::usage = "AntiDotProduct[v, w] gives an anti dot product of multivectors v and w"; 43 | 44 | PackageExport["LeftContraction"] 45 | LeftContraction::usage = "LeftContraction[v, w] gives a left contraction of multivectors v and w"; 46 | 47 | PackageExport["RightContraction"] 48 | RightContraction::usage = "RightContraction[v, w] gives a right contraction of multivectors v and w"; 49 | 50 | PackageExport["ScalarProduct"] 51 | ScalarProduct::usage = "ScalarProduct[v, w] gives a scalar product of multivectors v and w"; 52 | 53 | PackageExport["CrossProduct"] 54 | CrossProduct::usage = "CrossProduct[v, w] gives a cross product of multivectors v and w"; 55 | 56 | PackageExport["InnerProduct"] 57 | InnerProduct::usage = "InnerProduct[v, w] gives an inner product of multivectors v and w"; 58 | 59 | PackageExport["AntiInnerProduct"] 60 | AntiInnerProduct::usage = "AntiInnerProduct[v, w] gives an anti inner product of multivectors v and w"; 61 | 62 | PackageExport["RightInteriorProduct"] 63 | RightInteriorProduct::usage = "RightInteriorProduct[v, w] gives a right interior product of multivectors v and w"; 64 | 65 | PackageExport["LeftInteriorProduct"] 66 | LeftInteriorProduct::usage = "LeftInteriorProduct[v, w] gives a left interior product of multivectors v and w"; 67 | 68 | PackageExport["RightInteriorAntiProduct"] 69 | RightInteriorAntiProduct::usage = "RightInteriorAntiProduct[v, w] gives a right interior anti product of multivectors v and w"; 70 | 71 | PackageExport["LeftInteriorAntiProduct"] 72 | LeftInteriorAntiProduct::usage = "LeftInteriorAntiProduct[v, w] gives a left interior anti product of multivectors v and w"; 73 | 74 | PackageExport["BulkExpansion"] 75 | BulkExpansion::usage = "BulkExpansion[v] gives a bulk expansion of multivector v"; 76 | 77 | PackageExport["WeightExpansion"] 78 | WeightExpansion::usage = "WeightExpansion[v] gives a weight expansion of multivector v"; 79 | 80 | PackageExport["BulkContraction"] 81 | BulkContraction::usage = "BulkContraction[v, w] gives a bulk contraction of multivectors v and w"; 82 | 83 | PackageExport["WeightContraction"] 84 | WeightContraction::usage = "WeightContraction[v, w] gives a weight contraction of multivectors v and w"; 85 | 86 | PackageExport["LeftComplement"] 87 | LeftComplement::usage = "LeftComplement[v] gives a left complement of multivector v"; 88 | 89 | PackageExport["RightComplement"] 90 | RightComplement::usage = "RightComplement[v] gives a right complement of multivector v"; 91 | 92 | PackageExport["LeftDual"] 93 | LeftDual::usage = "LeftDual[v] gives a left dual of multivector v"; 94 | 95 | PackageExport["RightDual"] 96 | RightDual::usage = "RightDual[v] gives a right dual of multivector v"; 97 | 98 | PackageExport["Bulk"] 99 | Bulk::usage = "Bulk[v] gives a bulk of multivector v"; 100 | 101 | PackageExport["Weight"] 102 | Weight::usage = "Weight[v] gives a weight of multivector v"; 103 | 104 | PackageExport["RightBulkDual"] 105 | PackageExport["BulkDual"] 106 | RightBulkDual::usage = "RightBulkDual[v] gives a right bulk dual of multivector v"; 107 | 108 | PackageExport["RightWeightDual"] 109 | PackageExport["WeightDual"] 110 | RightWeightDual::usage = "RightWeightDual[v] gives a right weight dual of multivector v"; 111 | 112 | PackageExport["LeftBulkDual"] 113 | LeftBulkDual::usage = "LeftBulkDual[v] gives a left bulk dual of multivector v"; 114 | 115 | PackageExport["LeftWeightDual"] 116 | LeftWeightDual::usage = "LeftWeightDual[v] gives a left weight dual of multivector v"; 117 | 118 | PackageExport["FlatPart"] 119 | FlatPart::usage = "FlatPart[v] gives a flat part of multivector v"; 120 | 121 | PackageExport["RoundPart"] 122 | RoundPart::usage = "RoundPart[v] gives a round part of multivector v"; 123 | 124 | PackageExport["RoundBulk"] 125 | RoundBulk::usage = "RoundBulk[v] gives a round bulk of multivector v"; 126 | 127 | PackageExport["FlatBulk"] 128 | FlatBulk::usage = "FlatBulk[v] gives a flat bulk of multivector v"; 129 | 130 | PackageExport["RoundWeight"] 131 | RoundWeight::usage = "RoundWeight[v] gives a round weight of multivector v"; 132 | 133 | PackageExport["FlatWeight"] 134 | FlatWeight::usage = "FlatWeight[v] gives a flat weight of multivector v"; 135 | 136 | PackageExport["Carrier"] 137 | Carrier::usage = "Carrier[v] gives a carrier of multivector v"; 138 | 139 | PackageExport["Cocarrier"] 140 | Cocarrier::usage = "Cocarrier[v] gives a cocarrier of multivector v"; 141 | 142 | PackageExport["Container"] 143 | Container::usage = "Container[v] gives a container of multivector v"; 144 | 145 | PackageExport["Partner"] 146 | Partner::usage = "Partner[v] gives a partner of multivector v"; 147 | 148 | PackageExport["BulkNorm"] 149 | BulkNorm::usage = "BulkNorm[v] gives a bulk norm of multivector v"; 150 | 151 | PackageExport["WeightNorm"] 152 | WeightNorm::usage = "WeightNorm[v] gives a weight norm of multivector v"; 153 | 154 | PackageExport["GeometricNorm"] 155 | GeometricNorm::usage = "GeometricNorm[v] gives a geometric norm of multivector v"; 156 | 157 | PackageExport["WeightUnitize"] 158 | WeightUnitize::usage = "WeightUnitize[v] gives a multivector v unitized by its weight"; 159 | 160 | PackageExport["MultivectorCosAngle"] 161 | MultivectorCosAngle::usage = "MultivectorCosAngle[v, w] gives a cosine of angle between multivectors v and w"; 162 | 163 | PackageExport["Involute"] 164 | Involute::usage = "Involute[v] gives a multivector with its odd grades multiplied by -1"; 165 | 166 | PackageExport["Rejection"] 167 | Rejection::usage = "Rejection[v, w] gives a rejection of multivector v on w"; 168 | 169 | PackageExport["OrthoProjection"] 170 | OrthoProjection::usage = "OrthoProjection[v, w] gives an orthogonal projection of multivector v on w"; 171 | 172 | PackageExport["CentralProjection"] 173 | CentralProjection::usage = "CentralProjection[v, w] gives a central projection of multivector v on w"; 174 | 175 | PackageExport["CentralAntiprojection"] 176 | CentralAntiprojection::usage = "CentralAntiprojection[v, w] gives a central antiprojection of multivector v on w"; 177 | 178 | PackageExport["OrthoAntiprojection"] 179 | OrthoAntiprojection::usage = "OrthoAntiprojection[v, w] gives an orthogonal antiprojection of multivector v on w"; 180 | 181 | PackageExport["Sandwich"] 182 | Sandwich::usage = "Sandwich[v, w] gives a sandwich product of multivectors v and w"; 183 | 184 | PackageExport["AntiSandwich"] 185 | AntiSandwich::usage = "AntiSandwich[v, w] gives an anti sandwich product of multivectors v and w"; 186 | 187 | PackageExport["AntiCommutator"] 188 | AntiCommutator::usage = "AntiCommutator[v, w] gives an anti commutator of multivectors v ** w + w ** v"; 189 | 190 | PackageExport["AntiReverse"] 191 | AntiReverse::usage = "AntiReverse[v] gives a multivector with its even grades multiplied by -1"; 192 | 193 | PackageExport["Attitude"] 194 | Attitude::usage = "Attitude[v] gives an attitude of multivector v"; 195 | 196 | PackageExport["Support"] 197 | Support::usage = "Support[v] gives a support of multivector v"; 198 | 199 | PackageExport["AntiSupport"] 200 | AntiSupport::usage = "AntiSupport[v] gives an anti support of multivector v"; 201 | 202 | PackageExport["$DefaultMultivectorFormatFunction"] 203 | $DefaultMultivectorFormatFunction::usage = "$DefaultMultivectorFormatFunction is a default function for formatting multivectors"; 204 | 205 | PackageExport["RandomMultivector"] 206 | RandomMultivector::usage = "RandomMultivector[g] gives a random multivector in geometric algebra g"; 207 | 208 | 209 | PackageScope["zeroMultivector"] 210 | PackageScope["identityMultivector"] 211 | PackageScope["geometricIndexFormat"] 212 | PackageScope["multiplyIndices"] 213 | PackageScope["orderAndContract"] 214 | 215 | PackageScope["switchDualSide"] 216 | 217 | 218 | Options[Multivector] = { 219 | "GeometricAlgebra" -> GeometricAlgebra[3], 220 | "Orientation" -> Left 221 | } 222 | 223 | 224 | multivectorQ[HoldPattern[Multivector[coords_ /; MatchQ[coords, _SparseArray ? SparseArrayQ] || VectorQ[Unevaluated[coords]], g_ ? GeometricAlgebraQ, orientation : Left | Right : Left]]] := Length[coords] == g["Order"] 225 | 226 | multivectorQ[___] := False 227 | 228 | 229 | MultivectorQ[v_Multivector] := System`Private`HoldValidQ[v] || multivectorQ[Unevaluated[v]] 230 | 231 | MultivectorQ[___] := False 232 | 233 | 234 | $MultivectorProperties = { 235 | "GeometricAlgebra", 236 | "Coordinates", 237 | 238 | "Coordinate", 239 | "Association", 240 | "Span", 241 | "Grade", 242 | "Flatten", 243 | "Scalar", 244 | "Pseudoscalar", 245 | "Real", 246 | "ComplexCoordinates", 247 | 248 | "Reverse", 249 | "Involute", 250 | "Conjugate", 251 | "LeftComplement", 252 | "RightComplement", 253 | "DoubleComplement", 254 | "Squared", 255 | "Norm", 256 | "Normalized", 257 | 258 | "Inverse", 259 | 260 | "LeftDual", 261 | "RightDual", 262 | "Tr", 263 | "Det" 264 | } 265 | 266 | 267 | Multivector::truncCoord = "Coordinates are incompatible with `1`. Number of coordinates should be less than `2`. Truncating excessive coordinates."; 268 | 269 | 270 | Multivector[coords_ ? VectorQ, g_ ? GeometricAlgebraQ, opts___] := With[{len = Length[coords], n = g["Order"]}, ( 271 | If[len > n, Message[Multivector::truncCoord, g, n]]; 272 | Multivector[SparseArray[coords, n], g, opts] 273 | ) /; len != n 274 | ] 275 | 276 | 277 | Multivector[assoc_Association, g_ ? GeometricAlgebraQ, opts___] := 278 | Multivector[Lookup[KeyValueMap[{index, x} |-> #1 -> x * #2 & @@ orderAndContract[normalIndex[index, g["Signature"]], g["Metric"]], assoc], g["Indices"], 0], g, opts] 279 | 280 | Multivector[x_ ? NumericQ, g_ ? GeometricAlgebraQ, opts___] := NumberMultivector[x, g, opts] 281 | 282 | Multivector[x : Except[_ ? VectorQ | _Multivector], g_ ? GeometricAlgebraQ, opts___] := Multivector[{x}, g, opts] 283 | 284 | Multivector[x_, opts : OptionsPattern[]] := Multivector[x, OptionValue["GeometricAlgebra"]] 285 | 286 | Multivector[x_, args : Except[_GeometricAlgebra | Left | Right] .., orientation : Left | Right : Left] := Multivector[x, GeometricAlgebra[args], orientation] 287 | 288 | Multivector[x, p_Integer, q_Integer: 0, r_Integer: 0, opts___] := Multivector[x, GeometricAlgebra[p, q, r], opts] 289 | 290 | Multivector[x_, {p_Integer, q_Integer: 0, r_Integer: 0}, opts___] := Multivector[x, p, q, r, opts] 291 | 292 | Multivector[] := Multivector[{}] 293 | 294 | 295 | NumberMultivector[x_, g_GeometricAlgebra, opts___] := 296 | Multivector[SparseArray[{1 -> Re[x], -1 -> If[g["PseudoscalarSquare"] == 1, I, 1] Im[x]}, g["ComplexOrder"]], g, opts] 297 | 298 | NumberMultivector[v_Multivector, g_GeometricAlgebra, opts___] := 299 | Multivector[SparseArray[{1 -> v["Scalar"], -1 -> If[v["PseudoscalarSquare"] != g["PseudoscalarSquare"], I, 1] v["Pseudoscalar"]}, g["ComplexOrder"]], g, opts] 300 | 301 | NumberMultivector[x_, args__, position : Left | Right : Left] := NumberMultivector[x, GeometricAlgebra[args], position] 302 | 303 | NumberMultivector[x_] := NumberMultivector[x, GeometricAlgebra[0, 1]] 304 | 305 | 306 | MultivectorNumber[v_Multivector, g_GeometricAlgebra] := 307 | Multivector[SparseArray[{1 -> v["Scalar"], -1 -> v["Pseudoscalar"]}, g["ComplexOrder"]], g] 308 | 309 | MultivectorNumber[v_Multivector] := MultivectorNumber[v, If[v["PseudoscalarSquare"] == 1, {1, 0}, {0, 1}]] 310 | 311 | MultivectorNumber[x_, args__] := MultivectorNumber[x, GeometricAlgebra[args]] 312 | 313 | MultivectorNumber[x_, ___] := x 314 | 315 | 316 | BalancedMultivector[v_Multivector] := BalancedMultivector[v, GeometricAlgebra[v]] 317 | 318 | BalancedMultivector[v_Multivector, g_GeometricAlgebra] := ConvertGeometricAlgebra[MultivectorNumber[v, g["BalancedAlgebra"]], g] 319 | 320 | 321 | v_Multivector[key___Integer] := #2 Lookup[v["Association"], Key[#1], 0] & @@ orderIndexWithSign[normalIndex[DeleteCases[{key}, 0], v["Signature"]], v["Dimension"]] 322 | 323 | v_Multivector[key : {___Integer}] := v /@ key 324 | 325 | v_Multivector[keys : {{___Integer} ..}] := v @@@ keys 326 | 327 | 328 | 329 | (HoldPattern[Multivector[coords_, _, ___]] ? MultivectorQ)["Coordinates"] := coords 330 | 331 | Multivector /: Normal[v_Multivector] := Normal @ v["Coordinates"] 332 | 333 | 334 | (HoldPattern[Multivector[_, g_, ___]] ? MultivectorQ)["GeometricAlgebra"] := g 335 | 336 | GeometricAlgebra[v_Multivector] := v["GeometricAlgebra"] 337 | 338 | (HoldPattern[Multivector[_, _, orientation : Left | Right : Left, ___]] ? MultivectorQ)["Orientation"] := orientation 339 | 340 | (v_Multivector ? MultivectorQ)[prop_String /; MemberQ[$GeometricAlgebraProperties, prop], args___] := GeometricAlgebra[v][prop, args] 341 | 342 | 343 | v_Multivector[f_] := mapCoordinates[f, v] 344 | 345 | 346 | _Multivector["Properties"] := $MultivectorProperties 347 | 348 | v_Multivector["Coordinates", n_Integer] := v["Coordinates"][[indexSpan[v, n]]] 349 | 350 | v_Multivector["Coordinates", {ns__Integer}] := Join @@ (v["Coordinates", #] & /@ {ns}) 351 | 352 | 353 | v_Multivector["Coordinate", n_Integer] := v["Coordinates"][[n]] 354 | 355 | v_Multivector["Coordinate", {ns__Integer}] := v["Coordinates"][[{ns}]] 356 | 357 | Multivector /: Part[v_Multivector, keys___] := v["Coordinate", keys] 358 | 359 | 360 | v_Multivector["CoordinateDimension"] := Max[DualDimension /@ v["Coordinates"]] 361 | 362 | 363 | v_Multivector["Association"] := Association @ Map[Apply[Function[{x, y}, v["Indices"][[First[x]]] -> y, HoldAllComplete]], Most @ ArrayRules[v["Coordinates"]]] 364 | 365 | 366 | v_Multivector["Span"] := MapThread[GeometricProduct, {v["Coordinates"], v["Basis"]}] 367 | 368 | v_Multivector["Span", n_Integer] := MapThread[GeometricProduct, {v["Coordinates"][[indexSpan[v, n]]], v["Basis", n]}] 369 | 370 | v_Multivector["Span", {ns__Integer}] := Catenate[v["Span", #] & /@ {ns}] 371 | 372 | 373 | v_Multivector["Flatten", n_Integer : 1] := 374 | Nest[If[v["Orientation"] === Left, Inner[GeometricProduct, #["Coordinates"], #["Basis"]] &, Inner[GeometricProduct, #["Basis"], #["Coordinates"]] &], v, n] 375 | 376 | Multivector /: Flatten[v_Multivector, n_Integer : 1] := v["Flatten", n] 377 | 378 | v_Multivector["Real"] := v[Re] + GeometricProduct[GeometricAlgebra[v]["Pseudoscalar"], v[Im]] 379 | 380 | 381 | v_Multivector["Numeric"] := If[v["ComplexDimension"] > 0 && v["PseudoscalarSquare"] == 1, 382 | v["Scalar"] IdentityMatrix[2] + v["Pseudoscalar"] Reverse @ IdentityMatrix[2], 383 | v["Scalar"] + I v["Pseudoscalar"] 384 | ] 385 | 386 | 387 | v_Multivector["ComplexCoordinates"] := Block[{ 388 | g, re, im 389 | }, 390 | g = GeometricAlgebra[v]; 391 | 392 | If[ OddQ[g["Dimension"]], 393 | re = Lookup[v["Association"], g["ReIndices"], 0]; 394 | im = Lookup[GeometricProduct[v, g["Pseudoscalar"]]["Association"], g["ReIndices"], 0]; 395 | 396 | re + GeometricProduct[g["PseudoscalarSquare"] im, g["Pseudoscalar"]] 397 | , 398 | (* Even dimension *) 399 | v["Coordinates"] 400 | ] 401 | ] 402 | 403 | 404 | v_Multivector /; System`Private`HoldNotValidQ[v] && multivectorQ[Unevaluated[v]] := System`Private`SetNoEntry[System`Private`HoldSetValid[v]] 405 | 406 | 407 | (* Coersion *) 408 | 409 | Multivector[v_Multivector] := v 410 | 411 | Multivector[v_Multivector, g_GeometricAlgebra] /; GeometricAlgebra[v] === g := v 412 | 413 | Multivector[v_Multivector, g_GeometricAlgebra] := Multivector[v["Association"], g] 414 | 415 | Multivector[v_Multivector, orientation : Left | Right] := Multivector[v["Association"], v["GeometricAlgebra"], orientation] 416 | 417 | 418 | (* Addition *) 419 | 420 | zeroMultivector[g_GeometricAlgebra] := Multivector[{}, g] 421 | 422 | zeroMultivector[v_Multivector] := zeroMultivector[GeometricAlgebra[v]] 423 | 424 | 425 | Multivector /: Plus[vs__Multivector] /; Length[{vs}] > 1 := Block[{ 426 | g = largestGeometricAlgebra[vs], 427 | ws 428 | }, 429 | ws = ConvertGeometricAlgebra[#, g] & /@ {vs}; 430 | Multivector[ 431 | Total[#["Coordinates"] & /@ ws], 432 | g, 433 | First[{vs}]["Orientation"] 434 | ][Identity] 435 | ] 436 | 437 | Multivector /: Plus[x : Except[_Multivector], v_Multivector]:= x * identityMultivector[v] + v 438 | 439 | 440 | g_GeometricAlgebra["Zero"] := zeroMultivector[g] 441 | 442 | 443 | (* Scalar multiplication *) 444 | 445 | identityMultivector[g_GeometricAlgebra] := Multivector[{1}, g] 446 | 447 | identityMultivector[v_Multivector] := identityMultivector[GeometricAlgebra[v]] 448 | 449 | 450 | Multivector /: Times[x : Except[_Multivector], v_Multivector] := mapCoordinates[x * # &, v] 451 | 452 | 453 | v_Multivector["Scalar"] := v["Coordinate", 1] 454 | 455 | 456 | v_Multivector["Pseudoscalar"] := If[v["Dimension"] > 0, v @@ v["PseudoscalarIndex"], 0] 457 | 458 | 459 | g_GeometricAlgebra["Identity"] := identityMultivector[g] 460 | 461 | 462 | (* Geometric Product *) 463 | 464 | g_GeometricAlgebra["BasisMatrix"] := g["BasisMatrix"] = ExteriorMatrix[g["VectorBasis"]] 465 | 466 | g_GeometricAlgebra["InverseBasisMatrix"] := g["InverseBasisMatrix"] = ExteriorMatrix[MatrixInverse[g["VectorBasis"]]] 467 | 468 | g_GeometricAlgebra["MultiplicationTensor"] := g["MultiplicationTensor"] = With[{indices = g["Indices"], metric = g["MetricSignature"]}, {index = PositionIndex[indices]}, 469 | SparseArray[Outer[SparseArray[Normal @ KeyMap[Lookup[index, Key[#]] &, multiplyIndices[#1, #2, metric]], Length[indices]] &, indices, indices, 1]] 470 | ] 471 | 472 | g_GeometricAlgebra["MetricMultiplicationTensor"] := g["MetricMultiplicationTensor"] = With[{a = Transpose @ g["BasisMatrix"], b = Transpose @ g["InverseBasisMatrix"]}, 473 | SparseArray[Transpose[b . Transpose[b . g["MultiplicationTensor"]]] . a] 474 | ] 475 | 476 | g_GeometricAlgebra["ExomorphismMatrix"] := g["ExomorphismMatrix"] = 477 | SparseArray @ With[{metric = g["Metric"]}, Wedge[##]["Coordinates"] & @@@ Replace[Map[Grade[metric[[All, #]], 1, g] &, g["Indices"], {2}], {} -> {g[]}, 1]] 478 | 479 | g_GeometricAlgebra["AntiExomorphismMatrix"] := g["AntiExomorphismMatrix"] = Transpose @ SparseArray[UnderBar[Bulk[OverBar[#]]]["Coordinates"] & /@ g["Basis"]] 480 | 481 | 482 | Bulk[v_Multivector] := With[{g = GeometricAlgebra[v]}, Multivector[g["ExomorphismMatrix"] . v["Coordinates"], g]] 483 | 484 | v_Multivector["Bulk"] := Bulk[v] 485 | 486 | Weight[v_Multivector] := With[{g = GeometricAlgebra[v]}, Multivector[g["AntiExomorphismMatrix"] . v["Coordinates"], g]] 487 | 488 | v_Multivector["Weight"] := Weight[v] 489 | 490 | v_Multivector["BulkDual" | "RightBulkDual"] := RightBulkDual[v] 491 | 492 | v_Multivector["LeftBulkDual"] := LeftBulkDual[v] 493 | 494 | v_Multivector["WeightDual" | "RightWeightDual"] := RightWeightDual[v] 495 | 496 | v_Multivector["LeftWeightDual"] := LeftWeightDual[v] 497 | 498 | RightBulkDual[v_] := OverBar[Bulk[v]] 499 | 500 | RightWeightDual[v_] := OverBar[Weight[v]] 501 | 502 | LeftBulkDual[v_] := UnderBar[Bulk[v]] 503 | 504 | LeftWeightDual[v_] := UnderBar[Weight[v]] 505 | 506 | BulkDual = RightBulkDual 507 | 508 | WeightDual = RightWeightDual 509 | 510 | 511 | FlatPart[v_Multivector] := Multivector[KeySelect[v["Association"], Not @* FreeQ[- v["NegativeDimension"]]], GeometricAlgebra[v]] 512 | 513 | RoundPart[v_Multivector] := Multivector[KeySelect[v["Association"], FreeQ[- v["NegativeDimension"]]], GeometricAlgebra[v]] 514 | 515 | RoundBulk[v_Multivector] := Multivector[KeySelect[v["Association"], FreeQ[v["NonNegativeDimension"] | - v["NegativeDimension"]]], GeometricAlgebra[v]] 516 | 517 | RoundWeight[v_Multivector] := Multivector[KeySelect[v["Association"], ! FreeQ[#, v["NonNegativeDimension"]] && FreeQ[#, - v["NegativeDimension"]] &], GeometricAlgebra[v]] 518 | 519 | FlatBulk[v_Multivector] := Multivector[KeySelect[v["Association"], FreeQ[#, v["NonNegativeDimension"]] && ! FreeQ[#, - v["NegativeDimension"]] &], GeometricAlgebra[v]] 520 | 521 | FlatWeight[v_Multivector] := Multivector[KeySelect[v["Association"], ! FreeQ[#, v["NonNegativeDimension"]] && ! FreeQ[#, - v["NegativeDimension"]] &], GeometricAlgebra[v]] 522 | 523 | 524 | Carrier[v_Multivector] := Wedge[v, GeometricAlgebra[v]["Infinity"]] 525 | 526 | Cocarrier[v_Multivector] := Wedge[WeightDual[v], GeometricAlgebra[v]["Infinity"]] 527 | 528 | Container[v_Multivector] := Wedge[v, WeightDual[Carrier[v]]] 529 | 530 | Partner[v_Multivector] := Vee[WeightDual[v]["Container"], v["Carrier"]] 531 | 532 | v_Multivector["FlatPart"] := FlatPart[v] 533 | 534 | v_Multivector["RoundPart"] := RoundPart[v] 535 | 536 | v_Multivector["RoundBulk"] := Bulk[v] 537 | 538 | v_Multivector["FlatBulk"] := FlatBulk[v] 539 | 540 | v_Multivector["RoundWeight"] := Weight[v] 541 | 542 | v_Multivector["FlatWeight"] := FlatWeight[v] 543 | 544 | v_Multivector["Carrier"] := Carrier[v] 545 | 546 | v_Multivector["Cocarrier"] := Cocarrier[v] 547 | 548 | v_Multivector["Center"] := Vee[Cocarrier[v], v] 549 | 550 | v_Multivector["Container"] := Container[v] 551 | 552 | v_Multivector["Partner"] := Partner[v] 553 | 554 | 555 | switchDualSide[v_Multivector] := 556 | Multivector[ 557 | MapThread[Function[{signs, x}, With[{coords = DualCoordinates[x]}, Dual @@ (Take[signs, Length[coords]] coords)], HoldAllComplete], {antiProductSigns[v["Dimension"], v["CoordinateDimension"]], Normal @ v["Coordinates"]}], 558 | v["GeometricAlgebra"] 559 | ] 560 | 561 | g_GeometricAlgebra["MultiplicationTable"] := ResourceFunction["GridTableForm"][ 562 | Map[Multivector[#, g] &, g["MultiplicationTensor"], {2}], 563 | TableHeadings -> {g["Basis"], g["Basis"]} 564 | ] 565 | 566 | g_GeometricAlgebra["MetricMultiplicationTable"] := ResourceFunction["GridTableForm"][ 567 | Map[Multivector[#, g] &, g["MetricMultiplicationTensor"], {2}], 568 | TableHeadings -> {g["Basis"], g["Basis"]} 569 | ] 570 | 571 | 572 | GeometricProduct[v_Multivector, w_Multivector] := Block[{ 573 | g = largestGeometricAlgebra[v, w], x, y, m 574 | }, 575 | x = ConvertGeometricAlgebra[v, g]; 576 | y = ConvertGeometricAlgebra[w, g]; 577 | m = Flatten[g["MetricMultiplicationTensor"], 1]; 578 | Switch[{v["Orientation"], w["Orientation"]}, 579 | {Left, Left}, 580 | Multivector[Transpose[m] . Flatten[Outer[coordinateTimes, x["Coordinates"], y["Coordinates"], 1], 1], g], 581 | _, 582 | Multivector[coordinateTimes[#, y] & /@ x["Coordinates"], g, Right] 583 | ][Identity] 584 | ] 585 | 586 | GeometricProduct[v_List, w_] := GeometricProduct[#, w] & /@ v 587 | 588 | GeometricProduct[v_, w_List] := GeometricProduct[v, #] & /@ w 589 | 590 | GeometricProduct[v_Multivector, w : Except[_Multivector]] := GeometricProduct[v, Grade[w, 0, GeometricAlgebra[v]]] 591 | 592 | GeometricProduct[v : Except[_Multivector], w_Multivector] := GeometricProduct[Grade[v, 0, GeometricAlgebra[w]], w] 593 | 594 | GeometricProduct[x_, y_] := x * y 595 | 596 | GeometricProduct[left___, v_Multivector, right___] := Fold[GeometricProduct, {left, v, right}] 597 | 598 | 599 | GeometricProduct[] := Multivector[{1}, {0, 0}] 600 | 601 | 602 | Multivector /: Times[vs__Multivector] := GeometricProduct[vs] 603 | 604 | 605 | Multivector /: Power[v_Multivector, n_Integer] := If[n < 0, Power[Inverse[v], -n], Nest[GeometricProduct[#, v] &, identityMultivector[v], n]] 606 | 607 | 608 | Multivector /: Equal[left___, v_Multivector, right___] := With[{g = GeometricAlgebra[v]}, And @@ MapThread[Equal, Normal /@ Map[ConvertGeometricAlgebra[Multivector[#], g] &, {left, v, right}]]] 609 | 610 | Multivector /: Unequal[left___, v_Multivector, right___] := ! Equal[left, v, right] 611 | 612 | 613 | Multivector /: (f_Symbol ? elementwiseFunctionQ)[v_Multivector, args___] := v[Map[f[#, args] &]] 614 | 615 | 616 | Multivector /: N[v_Multivector ? MultivectorQ, args___] := With[{coords = N[v["Coordinates"], args]}, Multivector[coords, v["GeometricAlgebra"]] /; coords =!= v["Coordinates"]] 617 | 618 | SetAttributes[Multivector, NHoldAll] 619 | 620 | 621 | (* Tensor product *) 622 | 623 | Multivector /: TensorProduct[v_Multivector, w_Multivector] := Block[{ 624 | p, q, r 625 | }, 626 | {p, q, r} = v["Signature"]; 627 | GeometricProduct[v, 628 | Multivector[ 629 | KeyMap[# /. {i_ ? Positive :> i + p, i_ ? Negative :> i - q} &, w["Association"]], 630 | GeometricAlgebra[{p, q} + w["Signature"]] 631 | ] 632 | ] 633 | ] 634 | 635 | 636 | (* infix notation *) 637 | 638 | Multivector /: NonCommutativeMultiply[left___, v_Multivector, right___] := GeometricProduct[left, v, right] 639 | 640 | 641 | (* Products and contractions *) 642 | 643 | AntiGeometricProduct[vs__] := OverBar[GeometricProduct @@ UnderBar /@ {vs}] 644 | 645 | 646 | gradeProduct[v_Multivector, w_Multivector] := Outer[GeometricProduct, GradeList[v], GradeList[w]] 647 | 648 | gradeFunctionContraction[f_, vs__Multivector] := Fold[Total[MapIndexed[Grade[#1, f[#2 - 1]] &, gradeProduct[##], {2}], 2] &, {vs}] 649 | 650 | gradeFunctionContraction[f_, left___, v_Multivector, right___] := gradeFunctionContraction[f, ##] & @@ (If[MultivectorQ[#], #, Grade[#, 0, GeometricAlgebra[v]]] & /@ {left, v, right}) 651 | 652 | LeftContraction[vs__] := gradeFunctionContraction[Apply[Subtract] @* Reverse, vs] 653 | 654 | RightContraction[vs__] := gradeFunctionContraction[Apply[Subtract], vs] 655 | 656 | DotProduct[vs__] := gradeFunctionContraction[Abs @* Apply[Subtract], vs] 657 | 658 | Multivector /: Dot[left___, v_Multivector, right___] := DotProduct[left, v, right] 659 | 660 | WedgeProduct[vs__] := gradeFunctionContraction[Apply[Plus], vs] 661 | 662 | Multivector /: Wedge[left___, v_Multivector, right___] := WedgeProduct[left, v, right] 663 | 664 | AntiWedgeProduct[vs__] := OverBar[Wedge @@ UnderBar /@ {vs}] 665 | 666 | Multivector /: Vee[left___, v_Multivector, right___] := AntiWedgeProduct[left, v, right] 667 | 668 | CrossProduct[vs__] := UnderBar[Wedge[vs]] 669 | 670 | Multivector /: Cross[left___, v_Multivector, right___] := CrossProduct[left, v, right] 671 | 672 | ScalarProduct[vs__] := Grade[GeometricProduct[vs], 0] 673 | 674 | AntiDotProduct[vs__] := OverBar[Dot @@ UnderBar /@ {vs}] 675 | 676 | InnerProduct[v_Multivector, w_Multivector] := With[{g = largestGeometricAlgebra[v, w]}, 677 | Multivector[Multivector[w, g]["Coordinates"] . g["ExomorphismMatrix"] . Multivector[v, g]["Coordinates"], g][Identity] 678 | ] 679 | 680 | AntiInnerProduct[v_Multivector, w_Multivector] := With[{g = largestGeometricAlgebra[v, w]}, 681 | Grade[{Multivector[w, g]["Coordinates"] . g["AntiExomorphismMatrix"] . Multivector[v, g]["Coordinates"]}, -1, g][Identity] 682 | ] 683 | 684 | (* AntiInnerProduct[v_Multivector, w_Multivector] := OverBar[InnerProduct[UnderBar[v], UnderBar[w]]] *) 685 | 686 | RightInteriorProduct[a_Multivector, b_Multivector] := Vee[a, OverBar[b]] 687 | 688 | LeftInteriorProduct[a_Multivector, b_Multivector] := Vee[UnderBar[a], b] 689 | 690 | RightInteriorAntiProduct[a_Multivector, b_Multivector] := Wedge[a, OverBar[b]] 691 | 692 | LeftInteriorAntiProduct[a_Multivector, b_Multivector] := Wedge[UnderBar[a], b] 693 | 694 | 695 | BulkExpansion[v_Multivector, w_Multivector] := Wedge[v, RightBulkDual[w]] 696 | 697 | WeightExpansion[v_Multivector, w_Multivector] := Wedge[v, RightWeightDual[w]] 698 | 699 | BulkContraction[v_Multivector, w_Multivector] := Vee[v, RightBulkDual[w]] 700 | 701 | WeightContraction[v_Multivector, w_Multivector] := Vee[v, RightWeightDual[w]] 702 | 703 | MultivectorDistance[v_Multivector, w_Multivector] := Vee[v, w] + WeightNorm[Wedge[v, Attitude[w]]] 704 | 705 | MultivectorCosAngle[v_Multivector, w_Multivector] := BulkNorm[WeightContraction[v, w]] + Vee[WeightNorm[v], WeightNorm[w]] 706 | 707 | 708 | (* Inversions *) 709 | 710 | reverseIndexCoordinate[g_GeometricAlgebra, indexPos_, x_] := Block[{newIndex, sign}, 711 | {newIndex, sign} = orderIndexWithSign[Reverse[Extract[g["Indices"], indexPos]], g["Dimension"]]; 712 | newIndex -> sign x 713 | ] 714 | 715 | v_Multivector["Reverse"] := With[{g = GeometricAlgebra[v]}, 716 | Multivector[ 717 | Association[reverseIndexCoordinate[g, #1, #2] & @@@ Most @ ArrayRules @ v["Coordinates"]], 718 | g 719 | ] 720 | ] 721 | 722 | OverTilde[v_Multivector] ^:= v["Reverse"] 723 | 724 | Multivector /: Reverse[v_Multivector] := v["Reverse"] 725 | 726 | AntiReverse[v_Multivector] := v["Reverse"]["DoubleComplement"] 727 | 728 | v_Multivector["AntiReverse"] := AntiReverse[v] 729 | 730 | 731 | Involute[v_Multivector] := mapCoordinates[((-1) ^ # & @* Length /@ v["Indices"]) # &, v] 732 | 733 | v_Multivector["Involute"] = Involute[v] 734 | 735 | 736 | v_Multivector["Conjugate"] = v["Involute"]["Reverse"] 737 | 738 | (SuperStar | Conjugate)[v_Multivector] ^:= v["Conjugate"] 739 | 740 | 741 | LeftComplement[v_Multivector] := With[{i = v["PseudoscalarIndex"]}, 742 | Multivector[ 743 | Association @ KeyValueMap[ 744 | Function[{j, x}, With[{k = DeleteElements[i, j]}, k -> permutationSignature[i, Join[k, j]] x]], 745 | v["Association"] 746 | ], 747 | GeometricAlgebra[v] 748 | ] 749 | ] 750 | 751 | v_Multivector["LeftComplement"] := LeftComplement[v] 752 | 753 | RightComplement[v_Multivector] := With[{i = v["PseudoscalarIndex"]}, 754 | Multivector[ 755 | Association @ KeyValueMap[ 756 | Function[{j, x}, With[{k = DeleteElements[i, j]}, k -> permutationSignature[i, Join[j, k]] x]], 757 | v["Association"] 758 | ], 759 | GeometricAlgebra[v] 760 | ] 761 | ] 762 | 763 | v_Multivector["RightComplement"] := RightComplement[v] 764 | 765 | 766 | Multivector /: UnderBar[v_Multivector] := v["LeftComplement"] 767 | 768 | Multivector /: OverBar[v_Multivector] := v["RightComplement"] 769 | 770 | 771 | v_Multivector["DoubleComplement"] := v["RightComplement"]["RightComplement"] 772 | 773 | v_Multivector["Squared"] = GeometricProduct[v, v["Involute"]] 774 | 775 | 776 | Sandwich[v_Multivector, w_Multivector] := - GeometricProduct[w, v, Inverse[w]] 777 | 778 | AntiSandwich[v_Multivector, w_Multivector] := - AntiGeometricProduct[w, v, UnderBar[Inverse[OverBar[w]]]] 779 | 780 | Multivector /: Commutator[v_Multivector, w_Multivector] := GeometricProduct[v, w] - GeometricProduct[w, v] 781 | 782 | AntiCommutator[v_Multivector, w_Multivector] := GeometricProduct[v, w] + GeometricProduct[w, v] 783 | 784 | 785 | (* Projections *) 786 | 787 | Multivector /: Projection[v_Multivector, w_Multivector] := GeometricProduct[w, v . w] 788 | 789 | 790 | Rejection[v_Multivector, w_Multivector] := GeometricProduct[Wedge[v, w], w] 791 | 792 | 793 | OrthoProjection[v_Multivector, w_Multivector] := Vee[w, WeightExpansion[v, w]] 794 | 795 | OrthoAntiprojection[v_Multivector, w_Multivector] := Wedge[w, WeightContraction[v, w]] 796 | 797 | CentralProjection[v_Multivector, w_Multivector] := Vee[w, BulkExpansion[v, w]] 798 | 799 | CentralAntiprojection[v_Multivector, w_Multivector] := Wedge[w, BulkContraction[v, w]] 800 | 801 | 802 | (* Inverse *) 803 | 804 | Multivector /: Inverse[v_Multivector] := MultivectorFunction[# ^ -1 &, v] 805 | 806 | v_Multivector["Inverse"] = Inverse[v] 807 | 808 | Multivector /: Divide[v_, w_Multivector] := GeometricProduct[Multivector[v, w["GeometricAlgebra"]], Inverse[w]] 809 | 810 | 811 | (* Root and Power *) 812 | 813 | Multivector /: Sqrt[v_Multivector] := v ^ (1 / 2) 814 | 815 | Multivector /: Root[v_Multivector, n_Integer] := MultivectorFunction[Power[#, 1 / n] &, v] 816 | 817 | Multivector /: Power[v_Multivector, p_Rational] := With[{n = Numerator[p], d = Denominator[p]}, Root[v ^ n, d]] 818 | 819 | Multivector /: Power[v_Multivector, x_] := MultivectorPower[v, x] 820 | 821 | 822 | (* D *) 823 | 824 | Multivector /: D[v_Multivector, x_] := v[Map[D[#, x] &]] 825 | 826 | 827 | (* Grade *) 828 | 829 | Grade[v_Multivector, n_Integer] /; n < 0 || n > v["Dimension"] := zeroMultivector[v] 830 | 831 | Grade[v_Multivector, n_Integer] := With[{vector = gradeVector[v["GeometricAlgebra"], n]}, mapCoordinates[# * vector &, v]] 832 | 833 | Grade[v_Multivector] := With[{grades = Length /@ Extract[v["Indices"], SparseArray[v["Coordinates"]]["ExplicitPositions"]]}, 834 | If[Equal @@ grades, First[grades], Indeterminate] 835 | ] 836 | 837 | GradeList[v_Multivector] := Grade[v, #] & /@ Range[0, v["Dimension"]] 838 | 839 | Grade[coords_List, n_Integer, args___] := Block[{ 840 | G = GeometricAlgebra[args], d, 841 | skipDimension, bladeDimension 842 | }, 843 | d = G["Dimension"]; 844 | k = Mod[n, d + 1]; 845 | skipDimension = binomialSum[d, k - 1]; 846 | bladeDimension = Binomial[d, k]; 847 | Multivector[SparseArray[MapIndexed[Function[{x, i}, skipDimension + i -> x, HoldAllComplete], Take[coords, UpTo[bladeDimension]]], G["Order"]], G] 848 | ] 849 | 850 | Grade[x_, n_Integer, args___] := Grade[{x}, n, args] 851 | 852 | Grade[v_Multivector, grades : {__Integer}] := Total[Grade[v, #] & /@ grades] 853 | 854 | Grade[v_Multivector, "Even"] := Total[Grade[v, #] & /@ Range[0, v["Dimension"], 2]] 855 | 856 | Grade[v_Multivector, "Odd"] := Total[Grade[v, #] & /@ Range[1, v["Dimension"], 2]] 857 | 858 | 859 | AntiGrade[v_Multivector] := v["Dimension"] - Grade[v] 860 | 861 | AntiGrade[args___] := Grade[args]["Dual"] 862 | 863 | 864 | v_Multivector["Grade", arg_] := Grade[v, arg] 865 | 866 | 867 | (* Special multivectors *) 868 | 869 | g_GeometricAlgebra["Scalar"] := Multivector[1, g] 870 | 871 | 872 | pseudoscalar[g_GeometricAlgebra] := Multivector[<|g["PseudoscalarIndex"] -> 1|>, g] 873 | 874 | pseudoscalar[v_Multivector] := pseudoscalar[GeometricAlgebra[v]] 875 | 876 | pseudoscalar[] := pseudoscalar[GeometricAlgebra[]] 877 | 878 | g_GeometricAlgebra["Pseudoscalar"] := pseudoscalar[g] 879 | 880 | 881 | g_GeometricAlgebra["Nilpotent", n_Integer] := With[{ 882 | i = Abs[n] 883 | }, 884 | ConvertGeometricAlgebra[Multivector[<|{i} -> 1 / 2, {-i} -> Sign[n] 1 / 2|>, g["BalancedAlgebra"]], g] 885 | ] 886 | 887 | 888 | g_GeometricAlgebra["Idempotent", n_Integer] := GeometricProduct[g["Nilpotent", - n], g["Nilpotent", n]] 889 | 890 | 891 | g_GeometricAlgebra["Origin"] := g[g["NonNegativeDimension"]] 892 | 893 | g_GeometricAlgebra["Horizon"] := OverBar[g["Origin"]] 894 | 895 | g_GeometricAlgebra["Infinity"] := g[- g["NegativeDimension"]] 896 | 897 | Attitude[v_Multivector] := Vee[v, v["Horizon"]] 898 | 899 | Support[v_Multivector] := OrthoProjection[v["Origin"], v] 900 | 901 | Antisupport[v_Multivector] := CentralAntiprojection[v["Horizon"], v] 902 | 903 | 904 | (* Duals *) 905 | 906 | LeftDual[v_Multivector] := LeftContraction[v, pseudoscalar[v]["Reverse"]] 907 | 908 | v_Multivector["LeftDual"] := LeftDual[v] 909 | 910 | 911 | RightDual[v_Multivector] := RightContraction[pseudoscalar[v], v] 912 | 913 | v_Multivector["RightDual"] := RightDual[v] 914 | 915 | 916 | v_Multivector["Dual"] := LeftDual[v] 917 | 918 | 919 | Multivector /: SuperDagger[v_Multivector] := v["Dual"] 920 | 921 | 922 | (* Norms *) 923 | 924 | v_Multivector["BulkNorm"] := BulkNorm[v] 925 | 926 | BulkNorm[v_Multivector] := InnerProduct[v, v][Sqrt] 927 | 928 | v_Multivector["WeightNorm" | "RadiusNorm"] := WeightNorm[v] 929 | 930 | WeightNorm[v_Multivector] := AntiInnerProduct[v, v][Sqrt] 931 | 932 | GeometricNorm[v_Multivector] := BulkNorm[v] + WeightNorm[v] 933 | 934 | v_Multivector["Norm" | "GeometricNorm"] := GeometricNorm[v] 935 | 936 | Multivector /: Norm[v_Multivector] := GeometricNorm[v] 937 | 938 | \[LeftDoubleBracketingBar] v_Multivector \[RightDoubleBracketingBar] := GeometricNorm[v] 939 | 940 | v_Multivector["Radius"] := v["RadiusNorm"] / WeightNorm[RoundPart[v]] 941 | 942 | v_Multivector["CenterNorm"] := Sqrt[BulkNorm[RoundPart[v]] ^ 2 + WeightNorm[FlatPart[v]] ^ 2] 943 | 944 | v_Multivector["CoordinateNorm"] := Norm[v["Coordinates"]] 945 | 946 | v_Multivector["Normalize"] := v / v["Norm"] 947 | 948 | Multivector /: Normalize[v_Multivector] := v["Normalize"] 949 | 950 | WeightUnitize[v_Multivector] := v / WeightNorm[v]["Pseudoscalar"] 951 | 952 | v_Multivector["Unitize" | "WeightUnitize"] := WeightUnitize[v] 953 | 954 | Multivector /: (Unitize | OverHat)[v_Multivector] := WeightUnitize[v] 955 | 956 | v_Multivector["Tr"] := v + v["Conjugate"] 957 | 958 | Multivector /: Tr[v_Multivector] := v["Tr"] 959 | 960 | 961 | v_Multivector["Det"] := GeometricProduct[v, v["Conjugate"]] 962 | 963 | Multivector /: Det[v_Multivector] := v["Det"] 964 | 965 | \[LeftBracketingBar] v_Multivector \[RightBracketingBar] := v["Det"] 966 | 967 | 968 | (* *) 969 | 970 | RandomMultivector[arg_, g_GeometricAlgebra] := Multivector[RandomReal[arg, g["Order"]], g] 971 | 972 | RandomMultivector[g_GeometricAlgebra] := RandomMultivector[{-1, 1}, g] 973 | 974 | RandomMultivector[arg_, n_Integer, g_GeometricAlgebra] := Table[RandomMultivector[arg, g], n] 975 | 976 | RandomMultivector[arg_, args___] := RandomMultivector[arg, GeometricAlgebra[args]] 977 | 978 | RandomMultivector[args___, n_Integer] := Table[RandomMultivector[args], n] 979 | 980 | RandomMultivector[args___] := RandomMultivector[GeometricAlgebra[args]] 981 | 982 | 983 | (* Formatting *) 984 | 985 | $DefaultMultivectorFormatFunction = Function[index, 986 | If[ index === {}, 987 | "", (* don't display zero coefficient terms *) 988 | Subscript["e", Row[If[# > 0, #, UnderBar[Abs[#]]] & /@ index, "\[InvisibleComma]"]] 989 | ] 990 | ] 991 | 992 | 993 | geometricIndexFormat[g_GeometricAlgebra, index_] := With[{format = g["FormatIndex"]}, 994 | Switch[format, 995 | Automatic, 996 | $DefaultMultivectorFormatFunction[index] 997 | , 998 | "Positive", 999 | $DefaultMultivectorFormatFunction[positiveIndex[index, g["Signature"]] - 1] 1000 | , 1001 | _Function, 1002 | format[index] 1003 | , 1004 | _, 1005 | index /. Append[_ -> $DefaultMultivectorFormatFunction[index]] @ DeleteCases[Except[_Rule]] @ Developer`ToList[format] 1006 | ] 1007 | ] 1008 | 1009 | geometricIndexFormat[g_GeometricAlgebra, {indices__List}] := geometricIndexFormat[g, #] & /@ {indices} 1010 | 1011 | geometricIndexFormat[g_GeometricAlgebra] := geometricIndexFormat[g, g["Indices"]] 1012 | 1013 | geometricIndexFormat[index_] := geometricIndexFormat[Lookup[Options[Multivector], "GeometricAlgebra"], index] 1014 | 1015 | geometricIndexFormat[] := geometricIndexFormat[Lookup[Options[Multivector], "GeometricAlgebra"]] 1016 | 1017 | 1018 | holdSparseArray[HoldPattern[a : SparseArray[{}, ___]]] := a 1019 | holdSparseArray[HoldPattern[SparseArray[{xs__}, opts___]]] := SparseArray[List @@ MapAt[Hold, Hold[xs], {All, 2}], opts] 1020 | 1021 | Multivector /: MakeBoxes[v : Multivector[coords_, __] /; MultivectorQ[Unevaluated[v]], form_] := Block[{ 1022 | g = v["GeometricAlgebra"], 1023 | orientation = v["Orientation"], 1024 | holdCoords, 1025 | rules, 1026 | nonZeroPositions, 1027 | d, n, 1028 | indices, metric, 1029 | display, interpret, 1030 | gBox, boxes 1031 | }, 1032 | gBox = ToBoxes[g, form]; 1033 | d = g["Dimension"]; 1034 | indices = g["OrderedIndices"]; 1035 | metric = g["Metric"]; 1036 | holdCoords = Which[ 1037 | SparseArrayQ[Unevaluated[coords]], (* don't hold elements of a SparseArray object *) 1038 | Map[Hold, coords] 1039 | , 1040 | MatchQ[Unevaluated[coords], _SparseArray], (* hold each element of a SparseArray constructor *) 1041 | holdSparseArray[Unevaluated[coords]] 1042 | , 1043 | True, 1044 | Map[Hold, Unevaluated[coords]] (* hold elements of a List *) 1045 | ]; 1046 | holdCoords = Extract[holdCoords, Lookup[PositionIndex[g["Indices"]], SortBy[#, Mod[#, d + 1] &] & /@ indices, Nothing]]; 1047 | rules = Cases[ArrayRules[holdCoords], ({i_Integer} -> c_) /; If[c != Hold[0], True, False, ! MatchQ[c, Hold[w_Multivector] /; w == 0]] :> {i, c}]; 1048 | nonZeroPositions = rules[[All, 1]]; 1049 | n = Length @ nonZeroPositions; 1050 | boxes = ReleaseHold @ Map[ 1051 | Apply[ 1052 | Function[{i, holdCoord}, If[ i > 1, 1053 | Function[x, With[{coord = x * orderAndContract[indices[[i]], metric][[2]]}, Switch[coord, 1054 | 1, InterpretationBox["\[InvisibleSpace]", coord], 1055 | -1, InterpretationBox["-", coord], 1056 | _, If[MatchQ[coord, _Multivector | _Dual], RowBox[{"(", ToBoxes[coord, form], ")"}], Parenthesize[coord, form, Times]] 1057 | ]], HoldAllComplete] @@ holdCoord, 1058 | Function[x, MakeBoxes[x, form], HoldAllComplete] @@ holdCoord 1059 | ], HoldRest] 1060 | ], 1061 | rules 1062 | ]; 1063 | display = RowBox @ If[ n > 0, 1064 | Riffle[ 1065 | MapThread[ 1066 | RowBox[If[orientation === Right, Reverse, Identity] @ { 1067 | #1, 1068 | StyleBox[ToBoxes[geometricIndexFormat[g, #2], form], "ShowStringCharacters" -> False] 1069 | }] &, 1070 | { Slot /@ Range[n], indices[[nonZeroPositions]]} 1071 | ], 1072 | "+" 1073 | ], 1074 | {0} (* all zeros displayed as just zero *) 1075 | ]; 1076 | interpret = RowBox[{"Multivector", "[", 1077 | "SparseArray", "[", "{", 1078 | Sequence @@ If[n > 0, 1079 | Riffle[MapThread[RowBox[{ToBoxes[#1, form], "->", #2}] &, {nonZeroPositions, Slot /@ Range[n]}], ","], 1080 | {} 1081 | ], 1082 | "}", ",", ToBoxes[g["Order"], form], 1083 | "]", 1084 | ",", 1085 | gBox, "]" 1086 | }]; 1087 | TemplateBox[ 1088 | boxes, 1089 | "Multivector", 1090 | DisplayFunction -> (Evaluate @ display &), 1091 | InterpretationFunction -> (Evaluate @ interpret &), 1092 | Tooltip -> RowBox[{"Multivector", " ", gBox}], 1093 | Editable -> True 1094 | ] 1095 | ] 1096 | 1097 | 1098 | (* Frontend *) 1099 | 1100 | binaryOperationBox[f_String, infix_String] := TemplateBox[ 1101 | {"\[Placeholder]", "\[Placeholder]"}, 1102 | f, 1103 | InterpretationFunction -> (RowBox[{f, "[", #1, ",", #2, "]"}] &), 1104 | DisplayFunction -> (RowBox[{#1, infix, #2}] &) 1105 | ] 1106 | 1107 | UsingFrontEnd[ 1108 | SetOptions[EvaluationNotebook[], 1109 | InputAliases -> { 1110 | "gp" -> binaryOperationBox["GeometricProduct", "⟑"], 1111 | "agp" -> binaryOperationBox["AntiGeometricProduct", "⟇"], 1112 | "wedge" -> binaryOperationBox["WedgeProduct", "\[Wedge]"], 1113 | "awedge" -> binaryOperationBox["AntiWedgeProduct", "\[Vee]"], 1114 | "dot" -> binaryOperationBox["InnerProduct", "\[FilledSmallCircle]"], 1115 | "adot" -> binaryOperationBox["AntiInnerProduct", "\[SmallCircle]"] 1116 | } 1117 | ] 1118 | ] 1119 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/MultivectorArray.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | 4 | PackageExport["MultivectorArray"] 5 | MultivectorArray::usage = "MultivectorArray[vs, shape] gives a multi dimensional array of multivectors with specified shape"; 6 | 7 | PackageExport["MultivectorArrayQ"] 8 | 9 | PackageExport["ShapeContract"] 10 | ShapeContract::usage = "Contract MultivectorArray indices"; 11 | 12 | 13 | PackageScope["mapComponents"] 14 | 15 | 16 | Options[MultivectorArray] = {} 17 | 18 | 19 | multivectorArrayQ[HoldPattern[MultivectorArray[vs_, shape : {___Integer}]]] := 20 | DeleteCases[Dimensions[Unevaluated[vs]], 1] == DeleteCases[Abs[shape], 1] && (shape === {} || ArrayQ[Unevaluated[vs], _, MultivectorQ]) 21 | 22 | multivectorArrayQ[___] := False 23 | 24 | 25 | MultivectorArrayQ[va_MultivectorArray] := System`Private`HoldValidQ[va] || multivectorArrayQ[Unevaluated[va]] 26 | 27 | MultivectorArrayQ[___] := False 28 | 29 | 30 | $MultivectorArrayProperties = { 31 | "Components", 32 | "Shape", 33 | 34 | "Rank", 35 | "GeometricAlgebra", 36 | 37 | "Numeric" 38 | } 39 | 40 | 41 | MultivectorArray[vs_, shape : {___Integer}] /; vs =!= {} && ArrayQ[vs, _, MatchQ[_MultivectorArray]] := 42 | MultivectorArray[ 43 | Map[#["Components"] &, vs, {ArrayDepth[vs]}], 44 | Join[shape, largestGeometricAlgebra[Flatten[vs]]] 45 | ] 46 | 47 | MultivectorArray[vs_, shape_] /; vs =!= {} && ArrayQ[vs] && ! ArrayQ[vs, _, MultivectorQ] := 48 | MultivectorArray[Map[If[MultivectorQ[#], #, Multivector[{#}, 0]] &, vs, {ArrayDepth[vs]}], Developer`ToList[shape]] 49 | 50 | MultivectorArray[vs_] /; ArrayQ[vs] := With[{dim = Dimensions[vs]}, MultivectorArray[vs, dim * (-1) ^ Range[0, Length[dim] - 1]]] 51 | 52 | MultivectorArray[x_] := MultivectorArray[x, {}] 53 | 54 | 55 | (HoldPattern[MultivectorArray[vs_, _]] ? MultivectorArrayQ)["Components"] := vs 56 | 57 | (HoldPattern[MultivectorArray[_, shape_]] ? MultivectorArrayQ)["Shape"] := shape 58 | 59 | 60 | va_MultivectorArray["Dimension"] := Times @@ Abs @ va["Shape"] 61 | 62 | 63 | va_MultivectorArray["Rank"] := With[{shape = va["Shape"]}, If[shape === {}, 1, Length[shape]]] 64 | 65 | 66 | va_MultivectorArray["SquareQ"] := Equal @@ Dimensions[va] 67 | 68 | 69 | va_MultivectorArray["DoubleSquareQ"] := va["SquareQ"] && IntegerQ[Log2[va["Dimension"]] / 2] 70 | 71 | 72 | va_MultivectorArray[f_] := mapComponents[f, va] 73 | 74 | 75 | MultivectorArray /: Dimensions[va_MultivectorArray] := Abs @ va["Shape"] 76 | 77 | 78 | va_MultivectorArray["GeometricAlgebra"] := With[{r = va["Rank"]}, 79 | GeometricAlgebra[MapThread[Max, Flatten[Map[#["Signature"] &, va["Components"], {r}], r - 1]]] 80 | ] 81 | 82 | MultivectorArray /: va_MultivectorArray[opt: Alternatives @@ $GeometricAlgebraProperties] := va["GeometricAlgebra"][opt] 83 | 84 | 85 | MultivectorArray /: f_[v_Multivector, va_MultivectorArray] := mapComponents[f[v, #] &, va] 86 | 87 | MultivectorArray /: f_[va_MultivectorArray, v_Multivector] := mapComponents[f[#, v] &, va] 88 | 89 | MultivectorArray /: f_[x_ ? NumericQ, va_MultivectorArray] := mapComponents[f[x, #] &, va] 90 | 91 | MultivectorArray /: f_[va_MultivectorArray, y_ ? NumericQ] := mapComponents[f[#, y] &, va] 92 | 93 | 94 | va_MultivectorArray["Numeric"] := Map[#["Numeric"] &, va["Components"], {2}] 95 | 96 | 97 | va_MultivectorArray["Real"] := va[#["Real"] &] 98 | 99 | 100 | MultivectorArray /: GeometricProduct[va_MultivectorArray, vb_MultivectorArray] /; va["Rank"] > 0 && vb["Rank"] > 0 := With[{ 101 | outer = Outer[GeometricProduct, va["Components"], vb["Components"]], 102 | shape = Join[va["Shape"], vb["Shape"]], 103 | shapeContraction = {va["Rank"], va["Rank"] + 1} 104 | }, 105 | If[ MatchQ[{Last @ va["Shape"], First @ vb["Shape"]}, {x_ ? Negative, y_ ? Positive} /; x == -y], 106 | MultivectorArray[TensorContract[outer, shapeContraction], Delete[shape, List /@ shapeContraction]], 107 | MultivectorArray[outer, shape] 108 | ] 109 | ] 110 | 111 | GeometricProduct[va_MultivectorArray, vb_MultivectorArray] := GeometricProduct[expandDims[va, -1, 1], expandDims[vb, 1, 1]] 112 | 113 | GeometricProduct[x : Except[_Multivector], va_MultivectorArray] := x * va 114 | 115 | GeometricProduct[va_MultivectorArray, x : Except[_Multivector]] := x * va 116 | 117 | 118 | GeometricProduct[left___, va_MultivectorArray, right___] := Fold[GeometricProduct, {left, va, right}] 119 | 120 | 121 | MultivectorArray /: f_Symbol[va_MultivectorArray ? MultivectorArrayQ, vb_MultivectorArray ? MultivectorArrayQ] /; MemberQ[Attributes[f], NumericFunction] && va["Shape"] == vb["Shape"] := 122 | MultivectorArray[f[va["Components"], vb["Components"]], va["Shape"]] 123 | 124 | 125 | MultivectorArray /: Plus[vas__MultivectorArray] := Fold[Plus, {vas}] 126 | 127 | 128 | MultivectorArray /: NonCommutativeMultiply[left___, v_MultivectorArray, right___] := GeometricProduct[left, v, right] 129 | 130 | 131 | MultivectorArray /: Equal[vas__MultivectorArray ? MultivectorArrayQ] := With[{shapes = Through[{vas}["Shape"]]}, 132 | Equal @@ shapes && Apply[And, MapThread[Equal, Normal /@ {vas}, Length[First[shapes]]], All] 133 | ] 134 | 135 | MultivectorArray /: Normal[va_MultivectorArray ? MultivectorArrayQ] := va["Components"] 136 | 137 | MultivectorArray /: (f_Symbol ? elementwiseFunctionQ)[va_MultivectorArray, args___] := va[f[#, args] &] 138 | 139 | MultivectorArray /: N[va_MultivectorArray ? MultivectorArrayQ, args___] := With[{components = N[va["Components"], args]}, 140 | MultivectorArray[components, va["Shape"]] /; components =!= va["Components"] 141 | ] 142 | 143 | SetAttributes[MultivectorArray, NHoldAll] 144 | 145 | va_MultivectorArray /; System`Private`HoldNotValidQ[va] && multivectorArrayQ[Unevaluated[va]] := System`Private`SetNoEntry[System`Private`HoldSetValid[va]] 146 | 147 | 148 | (* Transpose *) 149 | 150 | transposeShape[shape_] := - shape 151 | 152 | transposeShape[shape_, n_Integer] := MapAt[Minus, shape, {n}] 153 | 154 | transposeShape[shape_List] /; Length[shape] > 1 := transposeShape[shape, 1 <-> 2] 155 | 156 | transposeShape[shape_List, levels_List] /; Length[shape] == Length[levels] := - shape[[levels]] 157 | 158 | transposeShape[shape_List, m_Integer <-> n_Integer] /; Length[shape] > 1 := MapAt[Minus, Permute[shape, Cycles[{{m, n}}]], {{m}, {n}}] 159 | 160 | 161 | MultivectorArray /: Transpose[va_MultivectorArray, args___] := 162 | If[ va["Rank"] > 1, 163 | MultivectorArray[Transpose[va["Components"], args], transposeShape[va["Shape"], args]], 164 | MultivectorArray[va["Components"], transposeShape[va["Shape"]]] 165 | ] 166 | 167 | 168 | (* Contraction *) 169 | 170 | shapeContract[va_MultivectorArray] := With[{ 171 | shapeContractions = SequencePosition[va["Shape"], {x_ ? Negative, y_ ? Positive} /; x == -y] 172 | }, 173 | If[Length[shapeContractions] > 0, 174 | MultivectorArray[TensorContract[va["Components"], shapeContractions], Delete[va["Shape"], List /@ Flatten @ shapeContractions]], 175 | va 176 | ] 177 | ] 178 | 179 | ShapeContract[va_MultivectorArray] := FixedPoint[shapeContract, va] 180 | 181 | 182 | (* Boxes *) 183 | 184 | shapeGridBoxes[array_, shape_] := If[shape === {}, 185 | Slot[array], 186 | If[ First[shape] > 0, 187 | RowBox[{"(", GridBox[{shapeGridBoxes[#, Rest[shape]]} & /@ array], ")"}], 188 | RowBox[{"[", GridBox[{shapeGridBoxes[#, Rest[shape]] & /@ array}], "]"}] 189 | ] 190 | ] 191 | 192 | MultivectorArray /: MakeBoxes[va_MultivectorArray /; MultivectorArrayQ[Unevaluated[va]], form_] := Module[{ 193 | shape = va["Shape"], 194 | components = va["Components"], 195 | dims, size, 196 | boxes, 197 | display, 198 | interpret 199 | }, 200 | dims = Abs @ shape; 201 | size = Times @@ dims; 202 | boxes = ToBoxes[#, form] & /@ Flatten[{components}]; 203 | display = Which[size == 0, RowBox[{"(", ")"}], shape === {}, Slot[1], True, shapeGridBoxes[ArrayReshape[Range[size], dims], shape]]; 204 | interpret = RowBox[{"MultivectorArray", "[", 205 | If[va["Rank"] > 0, ToBoxes[ArrayReshape[Slot /@ Range[size], dims]], Slot[1]] 206 | /. slot_String /; StringMatchQ[slot, "#" ~~ DigitCharacter ..] :> ToExpression[slot], 207 | ",", 208 | ToBoxes[shape, form], 209 | "]"}]; 210 | TemplateBox[boxes, 211 | "MultivectorArray", 212 | DisplayFunction -> (Evaluate[display] &), 213 | InterpretationFunction -> (Evaluate[interpret] &), 214 | Tooltip -> RowBox[{"MultivectorArray ", ToBoxes @ shape}], 215 | Editable -> True 216 | ] 217 | ] 218 | 219 | 220 | (* Utility functions *) 221 | 222 | mapComponents[f_, va_MultivectorArray] := MultivectorArray[ 223 | If[va["Rank"] == 0, f[va["Components"]], Map[f, va["Components"], {va["Rank"]}]], 224 | va["Shape"] 225 | ] 226 | 227 | expandDims[va_MultivectorArray, sign_Integer: 1, dim_Integer: -1] /; sign != 0 := With[{ 228 | shape = Insert[va["Shape"], Sign[sign], dim] 229 | }, 230 | MultivectorArray[If[va["Rank"] == 0, {va["Components"]}, ArrayReshape[va["Components"], Abs[shape]]], shape] 231 | ] 232 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/MultivectorBasis.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | 4 | PackageExport["MultivectorBasis"] 5 | 6 | 7 | 8 | 9 | 10 | MultivectorBasis::usage = "MultivectorBasis[A, g] gives a list of multivectors from canonical basis of geometric algebra A with grade g"; 11 | 12 | 13 | MultivectorBasis[g_GeometricAlgebra, n_Integer ? Positive | All] := With[{ 14 | from = If[n === All, 1, binomialSum[g["Dimension"], n - 1] + 1], 15 | to = If[n === All, g["Order"], binomialSum[g["Dimension"], n]] 16 | }, 17 | Table[Multivector[SparseArray[{k -> 1}, g["Order"]], "GeometricAlgebra" -> g], {k, from, to}] 18 | ] 19 | 20 | MultivectorBasis[g_GeometricAlgebra, n_Integer ? Negative] := MultivectorBasis[g, g["Dimension"] + n + 1] 21 | 22 | MultivectorBasis[g_GeometricAlgebra, 0] := {Multivector[1, g]} 23 | 24 | MultivectorBasis[g_GeometricAlgebra, "Even"] := Catenate[MultivectorBasis[g, #] & /@ Range[0, g["Dimension"], 2]] 25 | 26 | MultivectorBasis[g_GeometricAlgebra, "Odd"] := Catenate[MultivectorBasis[g, #] & /@ Range[1, g["Dimension"], 2]] 27 | 28 | MultivectorBasis[g_GeometricAlgebra] := MultivectorBasis[g, All] 29 | 30 | MultivectorBasis[g_GeometricAlgebra, {args___}] := Catenate[MultivectorBasis[g, #] & /@ {args}] 31 | 32 | MultivectorBasis[v_Multivector, args___] := MultivectorBasis[v["GeometricAlgebra"], args] 33 | 34 | MultivectorBasis[args__] := MultivectorBasis[GeometricAlgebra[], args] 35 | 36 | MultivectorBasis[] := MultivectorBasis[All] 37 | 38 | 39 | (* Basis indexing *) 40 | 41 | g_GeometricAlgebra[] := Multivector[1, g] 42 | 43 | g_GeometricAlgebra[indices__Integer] := Multivector[<|{indices} -> 1|>, g] 44 | 45 | g_GeometricAlgebra[indices : {___Integer}] := g /@ indices 46 | 47 | g_GeometricAlgebra[indices : {{___Integer} ...}] := g @@@ indices 48 | 49 | g_GeometricAlgebra["Basis", args___] := MultivectorBasis[g, args] 50 | 51 | g_GeometricAlgebra["PseudoBasis", args___] := GeometricProduct[g["Pseudoscalar"], #] & /@ MultivectorBasis[g, args] 52 | 53 | g_GeometricAlgebra["OrderedBasis"] := g[g["OrderedIndices"]] 54 | 55 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/MultivectorTransform.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | PackageExport["MultivectorTransform"] 4 | MultivectorTransform::usage = "MultivectorTransform[v, t] applies transformation t to multivector v"; 5 | 6 | 7 | MultivectorTransform[v_Multivector, "Conformal"] := Module[{p, q, r, A, e1, e2, o, n, w}, 8 | {p, q, r} = v["GeometricAlgebra"]["Signature"]; 9 | A = GeometricAlgebra[{p + 1, q + 1, r}]; 10 | 11 | Internal`InheritedBlock[{Multivector}, 12 | SetOptions[Multivector, "GeometricAlgebra" -> A]; 13 | e1 = Multivector[<|{p + 1} -> 1|>]; 14 | e2 = Multivector[<|{- q - 1} -> 1|>]; 15 | o = (e2 - e1) / 2; 16 | n = e1 + e2; 17 | w = Multivector[v, A]; 18 | o + w + 1 / 2 w ^ 2 ** n 19 | ] 20 | ] 21 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/PauliDirac.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`PauliDirac`"] 2 | 3 | PackageImport["Wolfram`GeometricAlgebra`"] 4 | 5 | PackageExport[$PauliAlgebra] 6 | PackageExport[$PauliBasis] 7 | PackageExport[$PauliSpectralBasis] 8 | PackageExport[$PauliSpinorBasis] 9 | PackageExport[$DiracAlgebra] 10 | PackageExport[$DiracSpectralBasis] 11 | PackageExport[$DiracCovariantSpectralBasis] 12 | PackageExport[$DiracSpinorBasis] 13 | 14 | PackageExport[DiracMatrix] 15 | 16 | PackageExport[SpinorMultivector] 17 | PackageExport[PauliSpinor] 18 | PackageExport[DiracSpinor] 19 | 20 | PackageExport[$STA] 21 | PackageExport[SpacetimeSplit] 22 | PackageExport[Reversion] 23 | 24 | 25 | 26 | $PauliAlgebra = GeometricAlgebra[3, 27 | "Format" -> "\[DoubleStruckCapitalP]", 28 | "FormatIndex" -> Function[Switch[#, {}, "", {1, 2, 3}, "\[ScriptCapitalI]", _, Subscript["\[Sigma]", Row @ Riffle[#, "\[InvisibleComma]"]]]] 29 | ] 30 | 31 | {s1, s2, s3, is1, is2, is3} = $PauliAlgebra["Basis", {1, 2}] 32 | 33 | 34 | $PauliBasis = $PauliAlgebra["Basis", 1] 35 | 36 | $PauliSpectralBasis = MultivectorArray[{1, s1}] ** ((1 / 2) * (1 + s3)) ** MultivectorArray[{1, s1}, -2] 37 | 38 | $PauliSpinorBasis = Prepend[$PauliAlgebra["Scalar"]] @ $PauliAlgebra["PseudoBasis", 1] 39 | 40 | 41 | $DiracAlgebra = $STA = GeometricAlgebra[1, 3, 42 | "Format" -> "\[DoubleStruckCapitalD]", 43 | "FormatIndex" -> Function[Switch[#, {}, "", {1, -3, -2, -1}, Subscript["\[Gamma]", 5], _, Subscript["\[Gamma]", Row @ Riffle[# /. {1 -> 0, -1 -> 3, -2 -> 2, -3 -> 1}, "\[InvisibleComma]"]]]] 44 | ] 45 | 46 | {g0, g1, g2, g3, g01, g02, g03, g12, g13, g23} = $DiracAlgebra["Basis", {1, 2}] 47 | 48 | $DiracSpectralBasis = LeftKroneckerProduct[MultivectorArray[{1, - g13}], MultivectorArray[{1, g03}]] ** ((1 / 4) (g0 - 1) ** (1 + I g12)) ** RightKroneckerProduct[MultivectorArray[{1, g03}, -2], MultivectorArray[{1, g13}, -2]] 49 | 50 | $DiracCovariantSpectralBasis = LeftKroneckerProduct[MultivectorArray[{1, - g13}], MultivectorArray[{1, - g03}]] ** ((1 / 4) (g0 - 1) ** (1 + I g12)) ** RightKroneckerProduct[MultivectorArray[{1, - g03}, -2], MultivectorArray[{1, g13}, -2]] 51 | 52 | $DiracSpinorBasis = $DiracSpectralBasis["Components"][[All, 1]] 53 | 54 | 55 | DiracMatrix[0] := KroneckerProduct[PauliMatrix[3], PauliMatrix[0]] 56 | 57 | DiracMatrix[i_Integer] /; 1 <= i <= 3 := I KroneckerProduct[PauliMatrix[2], PauliMatrix[i]] 58 | 59 | DiracMatrix[4 | 5] := KroneckerProduct[PauliMatrix[1], PauliMatrix[1]] 60 | 61 | 62 | PauliSpinor[v_Multivector] /; v["GeometricAlgebra"] == $PauliAlgebra := Block[{a0, a1, a2, a3}, 63 | a0 = v["Scalar"]; 64 | {a1, a2, a3} = v["Coordinates", 2]; 65 | { 66 | {a0 + a1 I}, 67 | {a2 + a3 I} 68 | } 69 | ] 70 | 71 | 72 | DiracSpinor[v_Multivector] /; v["GeometricAlgebra"] == $DiracAlgebra := ({#1["Scalar"]} &) /@ MultivectorMatrix[v, "Basis" -> $DiracSpectralBasis]["Components"][[All, 1]] 73 | 74 | 75 | SpinorMultivector[a_ ? VectorQ /; Dimensions[a] == {4}] := a . $PauliSpinorBasis 76 | 77 | SpinorMultivector[a_ ? MatrixQ /; Dimensions[a] == {2, 1}] := ComplexExpand[Flatten @ Map[ReIm, a, {2}]] . $PauliAlgebra["Basis", "Even"] 78 | 79 | SpinorMultivector[a_ ? MatrixQ /; Dimensions[a] == {4, 1}] := Flatten[a] . $DiracSpinorBasis 80 | 81 | 82 | SpacetimeSplit[v_Multivector] /; GeometricAlgebra[v] == $STA := GeometricProduct[v, $STA[1]] 83 | 84 | Reversion[v_Multivector] /; GeometricAlgebra[v] == $STA := GeometricProduct[$STA[1], v, $STA[1]] 85 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/ProjectiveGeometry.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`ProjectiveGeometry`"] 2 | 3 | PackageImport["Wolfram`GeometricAlgebra`"] 4 | 5 | PackageExport[PGA] 6 | PackageExport[PGAQ] 7 | PackageExport[$PGA] 8 | PackageExport[$2DPGA] 9 | PackageExport[PGADimension] 10 | PackageExport[PGAOrigin] 11 | PackageExport[RegionPGA] 12 | PackageExport[PGARegions] 13 | 14 | PackageExport[PGAVector] 15 | PackageExport[PGAMagnitude] 16 | PackageExport[PGAPoint] 17 | PackageExport[PGALine] 18 | PackageExport[PGAPlane] 19 | 20 | PackageExport[PGATranslator] 21 | PackageExport[PGAReflector] 22 | PackageExport[PGARotor] 23 | PackageExport[PGAMotor] 24 | PackageExport[PGAFlector] 25 | 26 | PackageExport[PGAExpansion] 27 | PackageExport[PGAContraction] 28 | 29 | PackageExport[PGAProjection] 30 | PackageExport[PGARejection] 31 | 32 | PackageExport[PGADistance] 33 | 34 | PackageExport[PGATransform] 35 | 36 | 37 | 38 | PGA[3] = $PGA = $3DPGA = e = e3 = GeometricAlgebra[3, 0, 1, "Format" -> "PGA", 39 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {Subscript[_, Row[{1, 2, 3, 4}, _]] -> "\[DoubleStruckOne]"}], 40 | "Ordering" -> {{}, {1}, {2}, {3}, {4}, {4, 1}, {4, 2}, {4, 3}, {2, 3}, {3, 1}, {1, 2}, {4, 2, 3}, {4, 3, 1}, {4, 1, 2}, {3, 2, 1}, {1, 2, 3, 4}} 41 | ] 42 | 43 | PGA[2] = $2DPGA = e2 = GeometricAlgebra[2, 0, 1, "Format" -> Subscript["PGA", "2D"], 44 | "FormatIndex" -> Function[$DefaultMultivectorFormatFunction[#] /. {Subscript[_, Row[{3, 2, 1}, _]] -> "\[DoubleStruckOne]"}], 45 | "Ordering" -> {{}, {1}, {2}, {3}, {2, 3}, {3, 1}, {1, 2}, {3, 2, 1}} 46 | ] 47 | 48 | PGA[n_Integer ? Positive] := GeometricAlgebra[n, 0, 1, "Format" -> Subscript["PGA", n], 49 | "FormatIndex" -> With[{i = Range[n + 1]}, Function[$DefaultMultivectorFormatFunction[#] /. {Subscript[_, Row[i, _]] -> "\[DoubleStruckOne]"}]] 50 | ] 51 | 52 | i = e[1, 2, 3, 4] 53 | i2 = e2[1, 2, 3] 54 | 55 | moment = e[{{2, 3}, {3, 1}, {1, 2}}] 56 | 57 | 58 | PGAQ[x : _GeometricAlgebra | _Multivector] := MatchQ[x["Signature"], {_, 0, 1}] 59 | 60 | PGA2DQ[x : _GeometricAlgebra | _Multivector] := x["Signature"] === {2, 0, 1} 61 | 62 | PGA2DQ[___] := False 63 | 64 | PGA3DQ[x : _GeometricAlgebra | _Multivector] := x["Signature"] === {3, 0, 1} 65 | 66 | PGA3DQ[___] := False 67 | 68 | 69 | PGADimension[x : _GeometricAlgebra | _Multivector] := Which[CGAQ[x], x["Dimension"] - 2, PGAQ[x], x["Dimension"] - 1, True, x["Dimension"]] 70 | 71 | 72 | (* Constructors *) 73 | 74 | PGAVector[v_Multivector ? PGA2DQ] := v[{{1}, {2}}] 75 | PGAVector[v_Multivector ? PGA3DQ] := v[{{1}, {2}, {3}}] 76 | PGAVector[v : {_, _}] := Grade[v, 1, $2DPGA] 77 | PGAVector[v : {_, _, _}] := Grade[v, 1, $PGA] 78 | 79 | PGAMagnitude[x_ : 1, y_ : 1] := x + y i 80 | 81 | PGAPoint[Point[p_], w_ : 1] := PGAPoint[p, w] 82 | PGAPoint[x_Multivector ? PGA2DQ] := With[{p = x[{{1}, {2}}], w = x[3]}, 83 | Switch[w == 0, True, Missing["Point"], _, Point[p / w]] 84 | ] 85 | PGAPoint[x_Multivector ? PGA3DQ] := With[{p = x[{{1}, {2}, {3}}], w = x[4]}, 86 | Switch[w == 0, True, Missing["Point"], _, Point[p / w]] 87 | ] 88 | PGAPoint[p_List, w_ : 1] := Grade[Append[p, w], 1, PGA[Length[p]]] 89 | 90 | PGALine[InfiniteLine[{p_, q_}]] := Wedge[PGAPoint[p], PGAPoint[q]] 91 | PGALine[InfiniteLine[p : {_, _, _}, v : {_, _, _}]] := PGALine[v, Cross[p, v]] 92 | PGALine[InfiniteLine[p : {_, _}, {x_, y_}]] := PGALine[{y, -x}, Norm[p]] 93 | PGALine[x_Multivector ? PGA2DQ] := Enclose[InfiniteLine[First @ Confirm @ PGAPoint[Support[x]], x[{{3, 1}, {3, 2}}]], Missing["Line"] &] 94 | PGALine[x_Multivector ? PGA3DQ] := Enclose[InfiniteLine[First @ Confirm @ PGAPoint[Support[x]], x[{{4, 1}, {4, 2}, {4, 3}}]], Missing["Line"] &] 95 | PGALine[n : {_, _}, d_ : 0] := n . e2[{{2, 3}, {3, 1}}] + d e2[1, 2] 96 | PGALine[v : {_, _, _}, m : {_, _, _}] := GeometricProduct[e[4], PGAVector[v]] + m . moment 97 | 98 | PGAPlane[InfinitePlane[p : {_, _, _}, {u : {_, _, _}, v : {_, _, _}}]] := Wedge[PGAPoint[p], PGAPoint[p + u], PGAPoint[p + v]] 99 | PGAPlane[(Triangle | InfinitePlane)[{p1 : {_, _, _}, p2 : {_, _, _}, p3 : {_, _, _}}]] := Wedge[PGAPoint[p1], PGAPoint[p2], PGAPoint[p3]] 100 | PGAPlane[Hyperplane[n : {_, _, _}, p : {_, _, _}]] := PGAPlane[n, - n . p / Norm[n]] 101 | PGAPlane[Hyperplane[n : {_, _, _}, d_]] := PGAPlane[n, - d] 102 | PGAPlane[x_Multivector ? PGA3DQ] := With[{n = x[{{4, 2, 3}, {4, 3, 1}, {4, 1, 2}}], w = x[3, 2, 1]}, 103 | Switch[Norm[n] != 0, False, Missing["Plane"], _, Hyperplane[n, - w]] 104 | ] 105 | PGAPlane[n : {_, _, _}, w_ : 1] := n . e[{{4, 2, 3}, {4, 3, 1}, {4, 1, 2}}] + w e[3, 2, 1] 106 | 107 | QuaternionToRotationMatrix[r_, x_, y_, z_] := With[{aim = Norm[{x, y, z}]}, 108 | If[aim == 0, Return[IdentityMatrix[3]]]; 109 | First @ LinearAlgebra`Private`MatrixPolynomial[ 110 | {Prepend[2 aim {r, aim} / (r ^ 2 + aim ^ 2), 1]}, 111 | - HodgeDual[{x, y, z} / aim] 112 | ] 113 | ] 114 | 115 | PGATranslator[t : {_, _}] := ({1, -1} t) . e2[{2, 1}] + i2 116 | PGATranslator[t : {_, _, _}] := t . moment + i 117 | PGATranslator[t_Multivector] := TranslationTransform[2 t[{{2, 3}, {3, 1}, {1, 2}}]] 118 | PGATranslator[t_TransformationFunction] := PGATranslator[t["AffineVector"] / 2] 119 | 120 | PGAReflector[n : {_, _, _}, w_ : 1] := PGAPlane[n, w] 121 | PGAReflector[g : _Triangle | _InfinitePlane | _Hyperplane] := PGAPlane[g] 122 | PGAReflector[r_Multivector ? PGA3DQ] := With[{n = r[{{4, 2, 3}, {4, 3, 1}, {4, 1, 2}}], w = r[3, 2, 1]}, 123 | ReflectionTransform[n, - w * n / n . n] 124 | ] 125 | 126 | PGARotor[l_Multivector, phi_] := WeightUnitize[l] * Sin[phi / 2] + GeometricAlgebra[l]["Pseudoscalar"] * Cos[phi / 2] 127 | PGARotor[line : InfiniteLine[{{_, _, _}, {_, _, _}}], phi_] := PGARotor[PGALine[line], phi] 128 | PGARotor[point : Point[{_, _}], phi_] := PGARotor[PGAPoint[point], phi] 129 | PGARotor[r_Multivector] := 130 | Which[ 131 | PGA3DQ[r], 132 | AffineTransform[QuaternionToRotationMatrix @@ r[{{1, 2, 3, 4}, {4, 1}, {4, 2}, {4, 3}}]], 133 | 134 | PGA2DQ[r], 135 | RotationTransform[ArcTan[r[1, 2, 3, 4], r[3]], r[{1, 2}]] 136 | ] 137 | 138 | PGAMotor[v : {_, _, _}, m : {_, _, _}, vw_ : 1, mw_ : 1] := mw + v . e[{{4, 1}, {4, 2}, {4, 3}}] + m . e[{{2, 3}, {3, 1}, {1, 2}}] + vw i 139 | PGAMotor[r : Point[{_, _}] | _InfiniteLine | _Multivector, t : {_, _, _}, phi_ : 0] := PGAMotor[r, PGATranslator[t], phi] 140 | PGAMotor[r : Point[{_, _}] | _InfiniteLine | _Multivector, t_Multivector, phi_ : 0] := AntiGeometricProduct[t, PGARotor[r, phi]] 141 | PGAMotor[m_Multivector] := PGATranslator[AntiGeometricProduct[m, AntiReverse[Weight[m]]]] @* PGARotor[m] 142 | 143 | PGAFlector[p : {_, _, _}, g : {_, _, _}, pw_ : 1, gw_ : 1] := PGAVector[Append[p, pw]] + GeometricProduct[e[4], g . moment] + gw e[3, 2, 1] 144 | PGAFlector[r : InfiniteLine[{{_, _, _}, {_, _, _}}], g : _Triangle | _InfinitePlane | _Hyperplane, phi_ : 0] := AntiGeometricProduct[PGARotor[r, phi], g] 145 | PGAFlector[r : Point[{_, _}], l : _InfiniteLine, phi_ : 0] := AntiGeometricProduct[PGARotor[r, phi], l] 146 | PGAFlector[p : Point[{_, _, _}] | _Multivector, g : _Triangle | _InfinitePlane | _Hyperplane, phi_ : 0] := PGAFlector[PGALine[PGAExpansion[p, g]], g, phi] 147 | PGAFlector[f_Multivector] := PGAReflector[f] @* PGARotor[AntiGeometricProduct[f, AntiReverse[PGAPlane[f]]]] 148 | 149 | 150 | (* Unary operations *) 151 | 152 | 153 | 154 | (* Binary operations *) 155 | 156 | PGAProjection[a_Multivector, b_Multivector] := LeftInteriorProduct[RightInteriorProduct[Weight[b], a], b] 157 | 158 | PGARejection[a_Multivector, b_Multivector] := LeftInteriorAntiProduct[RightInteriorAntiProduct[Weight[b], a], b] 159 | 160 | 161 | PGAExpansion = WeightExpansion 162 | 163 | PGAContraction = WeightContraction 164 | 165 | 166 | PGADistance[a_Multivector, b_Multivector] := BulkNorm[Attitude[Wedge[a, b]]] + WeightNorm[Wedge[a, Attitude[b]]] 167 | 168 | 169 | (* Transforms *) 170 | 171 | PGATransform[x_, qs__] := AntiGeometricProduct[Sequence @@ Reverse[{qs}], x, Sequence @@ AntiReverse /@ {qs}] 172 | 173 | 174 | (* Region constructions *) 175 | 176 | Attributes[RegionPGA] = {Listable} 177 | 178 | RegionPGA[point : _Point] := PGAPoint[point] 179 | 180 | RegionPGA[line : _InfiniteLine] := PGALine[line] 181 | 182 | RegionPGA[plane : _Triangle | _InfinitePlane | _Hyperplane] := PGAPlane[plane] 183 | 184 | RegionPGA[b : _Disk | _Ball] := CGARoundPoint[b] 185 | 186 | RegionPGA[s_Sphere] := CGASphere[s] 187 | 188 | RegionPGA[d_Line | d_Tube] := CGADipole[d] 189 | 190 | RegionPGA[c : _Circle | Inactive[ResourceFunction["Circle3D"]][__]] := CGACircle[c] 191 | 192 | 193 | (* Region export *) 194 | 195 | PGARegions[v_Multivector] /; PGA2DQ[v] := <|"Vector" -> Arrow[{{0, 0}, PGAVector[v]}], "Point" -> PGAPoint[v] , "Line" -> PGALine[v]|> 196 | 197 | PGARegions[v_Multivector] /; PGA3DQ[v] := <|"Vector" -> Arrow[{{0, 0, 0}, PGAVector[v]}], "Point" -> PGAPoint[v] ,"Line" -> PGALine[v] ,"Plane" -> PGAPlane[v]|> 198 | 199 | 200 | 201 | (* Overwrite mulitivector functions for regions *) 202 | 203 | $RGARegion = _Point | _InfiniteLine | _Triangle | _InfinitePlane | _Hyperplane 204 | 205 | $CGARegion = _Disk | _Ball | _Line | _Tube | _Circle | Inactive[ResourceFunction["Circle3D"]][__] | _Sphere 206 | 207 | $PGARegion = $RGARegion | $CGARegion 208 | 209 | 210 | Scan[ 211 | Function[f, 212 | Scan[ 213 | rule |-> If[! MemberQ[DownValues[f], Verbatim[rule]], PrependTo[DownValues[f], rule]], 214 | { 215 | HoldPattern[f[left___, x_ ? (MatchQ[$PGARegion]), right___]] :> f[left, RegionPGA[x], right], 216 | HoldPattern[f[left___, vs__Multivector, right___] /; AnyTrue[{vs}, PGAQ] && AnyTrue[{vs}, CGAQ]] :> 217 | With[{g = largestGeometricAlgebra[vs]}, 218 | f[left, ##, right] & @@ ToCGA /@ {vs} 219 | ] 220 | } 221 | ] 222 | ], 223 | { 224 | AntiReverse, 225 | Grade, AntiGrade, 226 | GeometricProduct, AntiGeometricProduct, 227 | WedgeProduct, AntiWedgeProduct, 228 | DotProduct, AntiDotProduct, 229 | ScalarProduct, CrossProduct, 230 | InnerProduct, AntiInnerProduct, 231 | LeftInteriorProduct, RightInteriorProduct, LeftInteriorAntiProduct, RightInteriorAntiProduct, 232 | BulkExpansion, BulkContraction, 233 | WeightExpansion, WeightContraction, 234 | Bulk, Weight, 235 | BulkNorm, WeightNorm, 236 | WeightUnitize, 237 | LeftComplement, RightComplement, 238 | Sandwich, AntiSandwich, 239 | Rejection, 240 | OrthoProjection, CentralProjection, 241 | OrthoAntiprojection, CentralAntiprojection, 242 | 243 | FlatPart, RoundPart, 244 | RoundBulk, FlatBulk, 245 | RoundWeight, FlatWeight, 246 | Carrier, Cocarrier, Container, 247 | Partner, 248 | 249 | PGAProjection, PGARejection 250 | } 251 | ] 252 | 253 | -------------------------------------------------------------------------------- /GeometricAlgebra/Kernel/Utilities.m: -------------------------------------------------------------------------------- 1 | Package["Wolfram`GeometricAlgebra`"] 2 | 3 | PackageExport[ExteriorMatrix] 4 | 5 | PackageScope[identityMatrix] 6 | PackageScope[MatrixInverse] 7 | PackageScope[elementwiseFunctionQ] 8 | PackageScope[numericFunctionQ] 9 | PackageScope[hasDefinitionsQ] 10 | PackageScope[permutationSignature] 11 | PackageScope[mergeOptions] 12 | PackageScope[mergeGeometricAlgebra] 13 | PackageScope[largestGeometricAlgebra] 14 | PackageScope[constantFunction] 15 | PackageScope[functionBody] 16 | PackageScope[reduceFunctions] 17 | PackageScope[mapCoordinates] 18 | PackageScope[coordinateTimes] 19 | PackageScope[solveCoordinates] 20 | PackageScope[dotIndices] 21 | PackageScope[orderIndexWithSign] 22 | PackageScope[contractBlade] 23 | PackageScope[orderAndContract] 24 | PackageScope[multiplyIndices] 25 | PackageScope[binomialSum] 26 | PackageScope[gradeVector] 27 | PackageScope[indexSpan] 28 | PackageScope[normalIndex] 29 | PackageScope[positiveIndex] 30 | 31 | 32 | elementwiseFunctionQ = MatchQ[Simplify | FullSimplify | Expand | ComplexExpand | TrigExpand | FunctionExpand | Together | ExpToTrig | TrigToExp | Chop] 33 | 34 | numericFunctionQ[f_] := MatchQ[f, _Symbol] && MemberQ[Attributes[f], NumericFunction] 35 | 36 | 37 | hasDefinitionsQ[f_Symbol] := GeneralUtilities`HasDefinitionsQ[f] || Length[Attributes[f]] > 0 38 | 39 | hasDefinitionsQ[f_] := GeneralUtilities`HasDefinitionsQ[f] 40 | 41 | 42 | permutationSignature[x_List, y_List] := permutationSignature[FindPermutation[x, y]] 43 | 44 | permutationSignature[perm_ ? PermutationCyclesQ] := Apply[Times, (-1) ^ (Length /@ First[perm] - 1)] 45 | 46 | 47 | identityMatrix[0] := {{}} 48 | 49 | identityMatrix[n_Integer] := IdentityMatrix[n] 50 | 51 | 52 | ExteriorMatrix[{{}}] := {{1}} 53 | 54 | ExteriorMatrix[matrix_ ? SquareMatrixQ] := With[{n = Length[matrix]}, 55 | BlockDiagonalMatrix @ Table[ 56 | With[{subsets = Subsets[Range[n], {k}]}, 57 | SparseArray @ Map[columns |-> 58 | Total[Signature[#] * Times @@ MapThread[Part, {columns, #}] & /@ Permutations[#]] & /@ subsets, 59 | Map[matrix[[All, #]] &, subsets, {2}] 60 | ] 61 | ], 62 | {k, 0, n} 63 | ] 64 | ] 65 | 66 | MatrixInverse[{{}}] := {{}} 67 | 68 | MatrixInverse[matrix_ ? SquareMatrixQ] := PseudoInverse[matrix] 69 | 70 | 71 | mergeOptions[opts_, drop_: False] := Sequence @@ Normal @ Merge[If[drop, DeleteCases[Join @@ opts, _ -> Automatic], Join @@ opts], First] 72 | 73 | 74 | mergeGeometricAlgebra[vs__Multivector] := GeometricAlgebra[ 75 | MapThread[Max, #["GeometricAlgebra"]["Signature"] & /@ {vs}], 76 | mergeOptions[Normal @ KeyDrop[Options[#["GeometricAlgebra"]], {"Signature", If[Equal @@ Through[{vs}["Dimension"]], Nothing, "VectorBasis"]}] & /@ {vs}, True] 77 | ] 78 | 79 | largestGeometricAlgebra[vs__Multivector] := largestGeometricAlgebra[{vs}] 80 | 81 | largestGeometricAlgebra[vs : {__Multivector}] := First @ MaximalBy[GeometricAlgebra /@ vs, #["Dimension"] &] 82 | 83 | 84 | constantFunction[f_Function] := f 85 | constantFunction[x_] := Function[x] 86 | 87 | 88 | functionBody[Function[body_]] := body 89 | functionBody[x_] := x 90 | 91 | 92 | reduceFunctions[expr_] := Activate @ FixedPoint[Function[x, ReplaceRepeated[x, { 93 | HoldPattern[(f: Function[x_])[y_]] :> With[{e = Inactivate[f[y], D]}, Function[e] /; True], 94 | f: HoldPattern[Function[x_]] /; FreeQ[Hold[x], _Slot, {0, \[Infinity]}] :> x, 95 | (* f: HoldPattern[Function[{xs__}, x_]] /; FreeQ[x, Alternatives[xs], {0, \[Infinity]}]:> x,*) 96 | (* HoldPattern[Function[x_]] :> With[{e = Inactivate[x, D]}, Function[e] /; True],*) 97 | HoldPattern[Function[Function[x_]]] :> With[{e = Simplify @ Inactivate[x, D]}, Function[e] /; True], 98 | HoldPattern[Plus[xs___, f_Function, ys___]] :> With[{e = Plus @@ (functionBody /@ Inactivate[{xs, f, ys}, D])}, Function[e] /; True], 99 | HoldPattern[Times[___, 0, ___]] :> 0, 100 | HoldPattern[Times[left___, 1, right___]] :> Times[left, right], 101 | HoldPattern[Times[xs___, f_Function, ys___]] /; FreeQ[{xs, ys}, _Function, {0, \[Infinity]}] :> With[{e = Times @@ (functionBody /@ Inactivate[{xs, f, ys}, D])}, Function[e] /; True] 102 | }], HoldAllComplete], expr] 103 | 104 | 105 | mapCoordinates[f_, v_Multivector] := Multivector[reduceFunctions[f[v["Coordinates"]]], v["GeometricAlgebra"], v["Orientation"]] 106 | 107 | 108 | coordinateTimes[f: Function[x_], Function[y_]] := reduceFunctions[Function[f[y]]] 109 | 110 | coordinateTimes[f_Function, y_] := f[y] 111 | 112 | coordinateTimes[x_, Function[y_]] := reduceFunctions[Function[x y]] 113 | 114 | coordinateTimes[x_ ? MultivectorQ, y : Except[_Multivector]] := Multivector[coordinateTimes[#, y] & /@ x["Coordinates"], GeometricAlgebra[x], x["Orientation"]] 115 | 116 | coordinateTimes[x : Except[_Multivector], y_ ? MultivectorQ] := Multivector[coordinateTimes[x, #] & /@ y["Coordinates"], GeometricAlgebra[y], y["Orientation"]] 117 | 118 | coordinateTimes[v_, w_] := GeometricProduct[v, w] 119 | 120 | 121 | solveCoordinates[f_Function, A_GeometricAlgebra] := Module[{w, sol}, 122 | Block[{x}, 123 | w = Array[Subscript[x, #] &, A["Order"]]; 124 | sol = Solve[Thread[Normal[f[Multivector[w, A]]] == Normal[A["Zero"]]], w]; 125 | If[ Length[sol] == 0 || Not[FreeQ[sol, ComplexInfinity | Indeterminate, Infinity]], 126 | $Failed, 127 | w /. First[sol] /. Thread[w -> 0] 128 | ] 129 | ] 130 | ] 131 | 132 | 133 | dotIndices[{}, __] := 1 134 | dotIndices[_, {}, _] := 1 135 | dotIndices[u_, v_, g_] := Det[Outer[g[[##]] &, u, v]] 136 | 137 | orderIndexWithSign[index_List, n_Integer] := With[{order = OrderingBy[index, Mod[#, n + 1] &]}, {index[[order]], Signature @ order}]; 138 | 139 | contractBlade[index_, g_] := Block[{newIndex, squares}, 140 | squares = First[Reap[newIndex = SequenceReplace[index, {x_, x_} :> (Sow[x]; Nothing)]][[2]], {}]; 141 | {newIndex, Times @@ If[VectorQ[g], g[[squares]], g[[#, #]] & /@ squares]} 142 | ] 143 | 144 | orderAndContract[index_, g_] := ({j, x} |-> {#1, x * #2} & @@ contractBlade[j, g]) @@ orderIndexWithSign[index, Length[g]] 145 | 146 | orderAndContractBlades[g_][indices_] := Merge[Total] @ KeyValueMap[{k, x} |-> #1 -> x * #2 & @@ orderAndContract[k, g], indices] 147 | 148 | multiplyIndices[uu : {___Integer}, vv : {___Integer}, g_ ? SquareMatrixQ] := Block[{ 149 | n = Length[g], x, y, u, v, j, k, sigma, tau 150 | }, 151 | {u, x} = orderAndContract[uu, g]; 152 | {v, y} = orderAndContract[vv, g]; 153 | j = Length[u]; 154 | k = Length[v]; 155 | sigma = Permutations[v]; 156 | tau = Permutations[u]; 157 | x * y * DeleteCases[0] @ orderAndContractBlades[g] @ Association @ Table[ 158 | Join[#2[[;; j - i]], #1[[i + 1 ;; k]]] -> 159 | Signature[Mod[#1, n + 1]] * Signature[Mod[#2, n + 1]] * dotIndices[Reverse[#2[[j - i + 1 ;; j]]], #1[[;; i]], g] & @@@ 160 | Tuples[{ 161 | Select[sigma, Less @@ #[[;; i]] && Less @@ #[[i + 1 ;; k]] &], 162 | Select[tau, Less @@ #[[;; j - i]] && Less @@ #[[j - i + 1 ;; j]] &] 163 | }], 164 | {i, 0, Min[j, k]} 165 | ] 166 | ] 167 | 168 | multiplyIndices[u : {___Integer}, v : {___Integer}, g_ ? VectorQ] := <|#1 -> #2|> & @@ orderAndContract[Join[u, v], g] 169 | 170 | 171 | binomialSum[n_Integer, k_Integer] := binomialSum[n, k] = Sum[Binomial[n, i], {i, 0, k}] 172 | 173 | 174 | gradeVector[A_GeometricAlgebra, k_Integer] := gradeVector[A["Dimension"], A["Order"], k] 175 | 176 | gradeVector[n_, d_, k_] := gradeVector[n, d, k] = SparseArray[ 177 | Thread[Range[binomialSum[n, k - 1] + 1, binomialSum[n, k]] -> 1], 178 | d 179 | ] 180 | 181 | 182 | indexSpan[v_Multivector, n_Integer] := 183 | binomialSum[v["GeometricAlgebra"]["Dimension"], n - 1] + 1 ;; binomialSum[v["GeometricAlgebra"]["Dimension"], n] 184 | 185 | indexSpan[_Multivector, All] := All 186 | 187 | 188 | positiveIndex[index_Integer, {p_, q_, _}] := 1 + If[index >= 0, index, Min[- index, q] + p] 189 | 190 | positiveIndex[indices : {___Integer}, signature_] := positiveIndex[#, signature] & /@ indices 191 | 192 | 193 | normalIndex[index_Integer, {p_, q_, r_}] := If[index < 0, Max[index, - q], If[index > p + r, Max[p + r - index, - q], Min[index, p + r]]] 194 | 195 | normalIndex[indices : {___Integer}, signature_] := normalIndex[#, signature] & /@ indices 196 | 197 | -------------------------------------------------------------------------------- /GeometricAlgebra/PacletInfo.wl: -------------------------------------------------------------------------------- 1 | (* ::Package:: *) 2 | 3 | PacletObject[ 4 | <| 5 | "Name" -> "Wolfram/GeometricAlgebra", 6 | "Description" -> "Computational tools for Geometric Algebras", 7 | "Creator" -> "Nikolay Murzin", 8 | "URL" -> "https://github.com/sw1sh/GeometricAlgebra", 9 | "License" -> "MIT", 10 | "PublisherID" -> "Wolfram", 11 | "Version" -> "1.4", 12 | "WolframVersion" -> "14.2+", 13 | "PrimaryContext" -> "Wolfram`GeometricAlgebra`", 14 | "Extensions" -> { 15 | { 16 | "Kernel", 17 | "Root" -> "Kernel", 18 | "Context" -> {"Wolfram`GeometricAlgebra`"}, 19 | "Symbols" -> { 20 | "Wolfram`GeometricAlgebra`ConvertGeometricAlgebra", 21 | "Wolfram`GeometricAlgebra`GeometricAlgebra", 22 | "Wolfram`GeometricAlgebra`GeometricProduct", 23 | "Wolfram`GeometricAlgebra`Grade", 24 | "Wolfram`GeometricAlgebra`Multivector" 25 | } 26 | }, 27 | { 28 | "Documentation", 29 | "Root" -> "Documentation", 30 | "Language" -> "English" 31 | } 32 | } 33 | |> 34 | ] 35 | -------------------------------------------------------------------------------- /GeometricAlgebra/ResourceDefinition.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:3c65a66a50749485f04f191ee152a80fc3699779d9582344a4424b002a61d4f5 3 | size 1116075 4 | -------------------------------------------------------------------------------- /Notebooks/GeometricAlgebra-Dev.nb: -------------------------------------------------------------------------------- 1 | version https://git-lfs.github.com/spec/v1 2 | oid sha256:fb9b31ff269aa7696b9dad7dfae4a1a988c385a564b7697799b470a16bcba6fe 3 | size 8726 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Geometric Algebra paclet 2 | 3 | Check it out in [Paclet Repository](https://resources.wolframcloud.com/PacletRepository/resources/Wolfram/GeometricAlgebra/). 4 | 5 | ## Installation 6 | 7 | 8 | Install from the paclet repository: 9 | 10 | ``` 11 | PacletInstall["Wolfram/GeometricAlgebra"] 12 | ``` 13 | 14 | Or locally: 15 | 16 | ``` 17 | PacletDirectoryLoad["path_to_paclet_directory"] 18 | ``` 19 | 20 | ## Load and use 21 | 22 | ``` 23 | << Wolfram`GeometricAlgebra` 24 | ``` 25 | 26 | ``` 27 | e = GeometricAlgebra[3]; 28 | 29 | r = 2 e[1] + 3 e[2] + 4 e[3] 30 | 31 | r ** e[1, 2] 32 | ``` -------------------------------------------------------------------------------- /Tests/Tests.wlt: -------------------------------------------------------------------------------- 1 | BeginTestSection["Test"] 2 | 3 | SetOptions[Multivector, "GeometricAlgebra" -> GeometricAlgebra[0, 1]]; 4 | 5 | VerificationTest[ 6 | Normal[Multivector[{1, 2}] ** Multivector[{3, -4}]], 7 | ReIm[(1 + 2 I) (3 - 4 I)], 8 | TestID -> "Complex number multiplication" 9 | ] 10 | 11 | SetOptions[Multivector, "GeometricAlgebra" -> GeometricAlgebra[2, 3]]; 12 | 13 | VerificationTest[ 14 | Map[Grade[Multivector[SparseArray[{1 -> 01, 3 -> 13, 9 -> 29, 25 -> 316, 28 -> 428, 30 -> 430, 32 -> 532}]], #]&, Range[0, 5]], 15 | { 16 | Multivector[SparseArray[{1 -> 01}]], 17 | Multivector[SparseArray[{3 -> 13}]], 18 | Multivector[SparseArray[{9 -> 29}]], 19 | Multivector[SparseArray[{25 -> 316}]], 20 | Multivector[SparseArray[{28 -> 428, 30 -> 430}]], 21 | Multivector[SparseArray[{32 -> 532}]] 22 | }, 23 | TestID -> "Grade computation" 24 | ] 25 | 26 | VerificationTest[ 27 | MakeBoxes[x Multivector[{1,2,3}, "GeometricAlgebra" -> GeometricAlgebra[4,1]], StandardForm], 28 | $Failed, 29 | TestID -> "Boxes" 30 | ] 31 | 32 | EndTestSection[] 33 | --------------------------------------------------------------------------------