Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
HSlice/Graphics/Slicer/Math/GeometricAlgebra.hs
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
849 lines (744 sloc)
38.3 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{- ORMOLU_DISABLE -} | |
{- | |
- Copyright 2020 Julia Longtin | |
- | |
- This program is free software: you can redistribute it and/or modify | |
- it under the terms of the GNU Affero General Public License as published by | |
- the Free Software Foundation, either version 3 of the License, or | |
- (at your option) any later version. | |
- | |
- This program is distributed in the hope that it will be useful, | |
- but WITHOUT ANY WARRANTY; without even the implied warranty of | |
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
- GNU Affero General Public License for more details. | |
- You should have received a copy of the GNU Affero General Public License | |
- along with this program. If not, see <http://www.gnu.org/licenses/>. | |
-} | |
-- For adding Generic and NFData to our types. | |
{-# LANGUAGE DeriveGeneric #-} | |
{-# LANGUAGE DeriveAnyClass #-} | |
-- For TowardInf. | |
{-# LANGUAGE DataKinds #-} | |
-- So we can map applying (,mempty) to a list. | |
{-# LANGUAGE TupleSections #-} | |
-- For :->: | |
{-# LANGUAGE TypeOperators, TypeFamilies #-} | |
-- So we can create an instance of HasTrie for NonEmpty GNum. | |
{-# LANGUAGE FlexibleInstances #-} | |
-- | Our geometric algebra library. | |
module Graphics.Slicer.Math.GeometricAlgebra( | |
ErrVal(ErrVal), | |
GNum(G0, GEMinus, GEPlus, GEZero), | |
GVal(GVal), | |
GVec(GVec), | |
UlpSum(UlpSum), | |
(⎣+), | |
(⎣), | |
(⎤+), | |
(⎤), | |
(⨅+), | |
(⨅), | |
(•+), | |
(•), | |
(⋅+), | |
(⋅), | |
(∧+), | |
(∧), | |
addErr, | |
addValPairWithErr, | |
addValWithErr, | |
addValWithoutErr, | |
addVecPair, | |
addVecPairWithErr, | |
addVecPairWithoutErr, | |
divVecScalarWithErr, | |
eValOf, | |
getVal, | |
hpDivVecScalar, | |
mulScalarVecWithErr, | |
reduceVecPair, | |
scalarPart, | |
subVal, | |
subValPairWithErr, | |
subVecPair, | |
sumErrVals, | |
ulpRaw, | |
ulpVal, | |
unlikeVecPair, | |
valOf, | |
vectorPart | |
) where | |
import Prelude (Eq, Monoid(mempty), Ord(compare), Semigroup((<>)), Show(show), (==), (/=), (+), fst, otherwise, snd, ($), not, (>), (*), concatMap, (<$>), sum, (&&), (/), Bool(True, False), error, flip, (&&), not, null, realToFrac, abs, (.), realToFrac) | |
import Prelude as P (filter) | |
import GHC.Generics (Generic) | |
import Control.DeepSeq (NFData) | |
import Data.Bits.Floating.Ulp (doubleUlp) | |
import Data.Either (Either(Left, Right)) | |
import Data.List (foldl', uncons) | |
import Data.List.NonEmpty (NonEmpty((:|)), toList, cons, nonEmpty) | |
import Data.List.Ordered (sort, insertSet) | |
import Data.Maybe (Maybe(Just, Nothing), isJust) | |
import Data.MemoTrie (HasTrie(enumerate, trie, untrie), Reg, (:->:), enumerateGeneric, memo, trieGeneric, untrieGeneric) | |
import Data.Number.BigFloat (BigFloat, PrecPlus20, Eps1) | |
import Data.Set (Set, singleton, disjoint, elems, size, elemAt, fromAscList) | |
import Data.Set as S (filter) | |
import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf, ToNearest), getRounded) | |
import Graphics.Slicer.Definitions (ℝ, Fastℕ) | |
import Graphics.Slicer.Orphans () | |
-- | The geometric numbers. | |
-- We must derive Ord so we can sort the terms during simplification. | |
data GNum = | |
GEMinus !Fastℕ -- squared equal to -1 -- associated with rotation | |
| GEZero !Fastℕ -- squared equal to 0 -- associated with translations | |
| GEPlus !Fastℕ -- squared equal to +1 -- associated with space/time or hyperbolic rotations | |
| G0 -- A scalar type. short lived. | |
deriving (Eq, Generic, NFData, Show, Ord) | |
instance HasTrie GNum where | |
newtype (GNum :->: b) = GNumTrie { unGNumTrie :: Reg GNum :->: b } | |
trie = trieGeneric GNumTrie | |
untrie = untrieGeneric unGNumTrie | |
enumerate = enumerateGeneric unGNumTrie | |
instance HasTrie (NonEmpty GNum) where | |
newtype ((NonEmpty GNum) :->: b) = NEGNumTrie { unNEGNumTrie :: Reg (NonEmpty GNum) :->: b } | |
trie = trieGeneric NEGNumTrie | |
untrie = untrieGeneric unNEGNumTrie | |
enumerate = enumerateGeneric unNEGNumTrie | |
-- | A value in geometric algebra. this will have duplicate members filtered out, and the members will be in order. | |
data GVal = GVal | |
-- _real :: | |
!ℝ | |
-- _basis :: | |
!(Set GNum) | |
deriving (Eq, Generic, NFData, Show) | |
instance HasTrie GVal where | |
newtype (GVal :->: b) = GValTrie { unGValTrie :: Reg GVal :->: b } | |
trie = trieGeneric GValTrie | |
untrie = untrieGeneric unGValTrie | |
enumerate = enumerateGeneric unGValTrie | |
-- | A value in geometric algebra, in need of reduction. this may have duplicate members, or members out of order. | |
data GRVal = GRVal | |
-- real component | |
!ℝ | |
-- basis vector | |
!(NonEmpty GNum) | |
deriving (Eq, Generic, NFData, Show) | |
-- | A constantly increasing sum of error. Used for increasing our error bars proportonally to error collected from the FPU during calculations. | |
newtype UlpSum = UlpSum { ulpRaw :: Rounded 'TowardInf ℝ } | |
deriving (Show, Eq, Generic, NFData, Ord) | |
-- | A value extractor directly to ℝ, which is a newtype of Double. | |
ulpVal :: UlpSum -> ℝ | |
ulpVal = getRounded . ulpRaw | |
instance Semigroup UlpSum where | |
(<>) (UlpSum sum1) (UlpSum sum2) = UlpSum $ sum1 + sum2 | |
instance Monoid UlpSum where | |
mempty = UlpSum 0 | |
instance HasTrie UlpSum where | |
newtype (UlpSum :->: b) = UlpSumTrie { unUlpSumTrie :: Reg UlpSum :->: b } | |
trie = trieGeneric UlpSumTrie | |
untrie = untrieGeneric unUlpSumTrie | |
enumerate = enumerateGeneric unUlpSumTrie | |
data ErrVal = ErrVal | |
-- { _ulpVal :: | |
!UlpSum | |
-- _ulpBasis :: | |
!(Set GNum) | |
deriving (Eq, Generic, NFData, Show) | |
data ErrRVal = ErrRVal { _ulpRVal :: !UlpSum, _ulpRBasis :: NonEmpty GNum } | |
deriving (Eq, Generic, NFData, Show) | |
instance HasTrie ErrVal where | |
newtype (ErrVal :->: b) = ErrValTrie { unErrValTrie :: Reg ErrVal :->: b } | |
trie = trieGeneric ErrValTrie | |
untrie = untrieGeneric unErrValTrie | |
enumerate = enumerateGeneric unErrValTrie | |
-- | Fake instance. do not try to order by ErrVal. | |
instance Ord ErrVal where | |
compare (ErrVal _ a) (ErrVal _ b) = compare a b | |
instance Semigroup ErrVal where | |
(<>) e1@(ErrVal r1 i1) e2@(ErrVal r2 i2) | |
| e1 == mempty = e2 | |
| e2 == mempty = e1 | |
| i1 == i2 = ErrVal (r1 <> r2) i1 | |
| otherwise = error $ "tried to <> two ErrVals with different basises.\n" <> show i1 <> "\n" <> show i2 <> "\n" | |
instance Monoid ErrVal where | |
mempty = ErrVal mempty mempty | |
-- | When sorting gvals, sort the basis, THEN sort the multiplier. | |
instance Ord GVal where | |
(GVal r1 i1) `compare` (GVal r2 i2) | |
| i1 == i2 = compare r1 r2 | |
| otherwise = compare i1 i2 | |
-- | A (multi)vector in geometric algebra. | |
newtype GVec = GVec [GVal] | |
deriving (Eq, Generic, NFData, Show, Ord) | |
instance HasTrie GVec where | |
newtype (GVec :->: b) = GVecTrie { unGVecTrie :: Reg GVec :->: b } | |
trie = trieGeneric GVecTrie | |
untrie = untrieGeneric unGVecTrie | |
enumerate = enumerateGeneric unGVecTrie | |
-- | a list contains geometric values that can be queried. | |
class UniqueVals a where | |
getVal :: [GNum] -> [a] -> Maybe a | |
instance UniqueVals GVal where | |
-- | Extract a value from a list of values. | |
getVal nums vs = case matches of | |
[] -> Nothing | |
[oneMatch@(GVal v _)] -> if v == 0 then Nothing else Just oneMatch | |
multiMatch@(_:_) -> error $ "found multiple candidates:\n" <> show multiMatch <> "\nWas using getVals on:\n" <> show vs <> "\nWas searching for:\n" <> show nums <> "\n" | |
where | |
matches = P.filter (\(GVal _ n) -> n == fromAscList nums) vs | |
instance UniqueVals ErrVal where | |
-- | Extract a value from a list of values. | |
getVal nums vs = case matches of | |
[] -> Nothing | |
[oneMatch@(ErrVal v _)] -> if v == mempty then Nothing else Just oneMatch | |
multiMatch@(_:_) -> error $ "found multiple candidates:\n" <> show multiMatch <> "\nWas using getVals on:\n" <> show vs <> "\nWas searching for:\n" <> show nums <> "\n" | |
where | |
matches = P.filter (\(ErrVal _ n) -> n == fromAscList nums) vs | |
-- | Return the value of a (vector, or bivector, or trivector, or...), OR a given value, if the vector requested is not found. | |
valOf :: ℝ -> Maybe GVal -> ℝ | |
valOf r Nothing = r | |
valOf _ (Just (GVal v _)) = v | |
-- | Return the error component saved from a calculation that produced a vector, OR return a given value, if the error component requested is not found. | |
eValOf :: UlpSum -> Maybe ErrVal -> UlpSum | |
eValOf r Nothing = r | |
eValOf _ (Just (ErrVal v _)) = v | |
-- | Add two geometric values together. | |
addValPairWithErr :: GVal -> GVal -> [(GVal, ErrVal)] | |
addValPairWithErr v1@(GVal r1 i1) v2@(GVal r2 i2) | |
| r1 == 0 && r2 == 0 = [] | |
| r1 == 0 = [(v2,mempty)] | |
| r2 == 0 = [(v1,mempty)] | |
| i1 == i2 && r1 == (-r2) = [] | |
| i1 == i2 = [(GVal res i1 | |
, ErrVal resErr i1)] | |
| otherwise = sort [(v1,mempty),(v2,mempty)] | |
where | |
res :: ℝ | |
res = realToFrac (realToFrac r1 + realToFrac r2 :: Rounded 'ToNearest ℝ) | |
resErr = UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac (realToFrac r1 + realToFrac r2 :: Rounded 'TowardInf ℝ) | |
-- | Subtract a geometric value from another geometric value, providing our error quotent. | |
subValPairWithErr :: GVal -> GVal -> [(GVal, ErrVal)] | |
subValPairWithErr v1@(GVal r1 i1) (GVal r2 i2) | |
| i1 == i2 && r1 == r2 = [] | |
| otherwise = addValPairWithErr v1 $ GVal (-r2) i2 | |
-- | Add a geometric value to a list of geometric values. | |
-- Assumes the list of values is in ascending order by basis vector, so we can find items with matching basis vectors easily. | |
addVal :: [GVal] -> GVal -> [GVal] | |
addVal dst src = fst <$> addValWithErr ((,mempty) <$> dst) src | |
-- | Add a geometric value to a list of geometric values. | |
-- Assumes the list of values is in ascending order by basis vector, so we can find items with matching basis vectors easily. | |
addValWithErr :: [(GVal, ErrVal)] -> GVal -> [(GVal, ErrVal)] | |
addValWithErr dstVals src@(GVal r1 _) | |
| r1 == 0 = dstVals | |
| null dstVals = [(src, mempty)] | |
| otherwise = case sameI src dstVals of | |
Nothing -> insertSet (src, mempty) dstVals | |
(Just ((a,e), [])) -> if rOf a == (-r1) | |
then diffI src dstVals | |
else insertSet (GVal newVal $ iOf src, newErr) $ diffI src dstVals | |
where | |
newVal :: ℝ | |
newVal = realToFrac (realToFrac (rOf a) + realToFrac r1 :: Rounded 'ToNearest ℝ) | |
newErr = e <> ErrVal (UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac newErrVal) (iOf src) | |
newErrVal = (realToFrac (rOf a) + realToFrac r1 :: Rounded 'TowardInf ℝ) | |
_ -> error "found too many sameI candidates." | |
where | |
sameI :: GVal -> [(GVal,ErrVal)] -> Maybe ((GVal,ErrVal), [(GVal, ErrVal)]) | |
sameI val srcVals = uncons $ P.filter (\(GVal _ i,_) -> i == iOf val) srcVals | |
diffI :: GVal -> [(GVal,ErrVal)] -> [(GVal,ErrVal)] | |
diffI val = P.filter (\(GVal _ i,_) -> i /= iOf val) | |
iOf (GVal _ i) = i | |
rOf (GVal r _) = r | |
-- | Add a geometric value to a list of geometric values. | |
-- Assumes the list of values is in ascending order by basis vector, so we can find items with matching basis vectors easily. | |
addValWithoutErr :: [GVal] -> GVal -> [GVal] | |
addValWithoutErr dstVals src@(GVal r1 _) | |
| r1 == 0 = dstVals | |
| null dstVals = [src] | |
| otherwise = case sameI src dstVals of | |
Nothing -> insertSet src dstVals | |
(Just a) -> error $ "Condition failed: found two values with the same basis vector to add:\n" | |
<> show dstVals <> "\n" | |
<> show a <> "\n" | |
<> show src <> "\n" | |
where | |
sameI :: GVal -> [GVal] -> Maybe (GVal, [GVal]) | |
sameI val srcVals = uncons $ P.filter (\a -> iOf a == iOf val) srcVals | |
iOf (GVal _ i) = i | |
-- | Subtract a geometric value from a list of geometric values. | |
-- Assumes the list of values is in ascending order by basis vector, so we can find items with matching basis vectors easily. | |
subVal :: [GVal] -> GVal -> [GVal] | |
subVal dst src = fst <$> subValWithErr ((,mempty) <$> dst) src | |
-- | Subtract a geometric value from a list of geometric values. | |
subValWithErr :: [(GVal, ErrVal)] -> GVal -> [(GVal, ErrVal)] | |
subValWithErr dst (GVal r i) = addValWithErr dst $ GVal (-r) i | |
-- | add an error quotent to a list of error quotents. | |
addErr :: [ErrVal] -> ErrVal -> [ErrVal] | |
addErr dstErrs src@(ErrVal _ i1) | |
| src == mempty = dstErrs | |
| dstErrs == mempty = [src] | |
| otherwise = case sameI i1 dstErrs of | |
Nothing -> insertSet src dstErrs | |
Just (match, []) -> insertSet (src <> match) $ diffI i1 dstErrs | |
_ -> error "too many sameI values" | |
where | |
diffI :: Set GNum -> [ErrVal] -> [ErrVal] | |
diffI i = P.filter (\(ErrVal _ i2) -> i2 /= i) | |
sameI :: Set GNum -> [ErrVal] -> Maybe (ErrVal, [ErrVal]) | |
sameI i errs = uncons $ P.filter (\(ErrVal _ i2) -> i2 == i) errs | |
-- | Add two vectors together. | |
addVecPair :: GVec -> GVec -> GVec | |
addVecPair vec1 vec2 = fst $ addVecPairWithErr vec1 vec2 | |
-- | Add two vectors together, preserving the error quotents. | |
addVecPairWithErr :: GVec -> GVec -> (GVec, [ErrVal]) | |
addVecPairWithErr (GVec vals1) (GVec vals2) = (resVec, resErr) | |
where | |
resVec = GVec $ fst <$> res | |
resErr = P.filter (/= mempty) $ snd <$> res | |
res = foldl' addValWithErr ((,mempty) <$> vals1) vals2 | |
-- | Add two vectors together, and ensure that there is not any error produced by the operation | |
addVecPairWithoutErr :: GVec -> GVec -> GVec | |
addVecPairWithoutErr (GVec vals1) (GVec vals2) = GVec vals | |
where | |
vals = foldl' addValWithoutErr vals1 vals2 | |
-- | Subtract one vector from the other. | |
subVecPair :: GVec -> GVec -> GVec | |
subVecPair vec1 vec2 = fst $ subVecPairWithErr vec1 vec2 | |
-- | subtract the second vector from the first vector. | |
subVecPairWithErr :: GVec -> GVec -> (GVec, [ErrVal]) | |
subVecPairWithErr (GVec vals1) (GVec vals2) = (resVec, resErr) | |
where | |
resVec = GVec $ fst <$> res | |
resErr = P.filter (/= mempty) $ snd <$> res | |
res = foldl' subValWithErr ((,mempty) <$> vals1) vals2 | |
-- | Multiply a vector by a scalar. arguments are given in this order for maximum readability. | |
mulScalarVecWithErr :: ℝ -> GVec -> (GVec,[ErrVal]) | |
mulScalarVecWithErr s (GVec vals) = (GVec resVals, resErr) | |
where | |
resVals = mulVal s <$> vals | |
resErr = (\(GVal a b) -> ErrVal (UlpSum $ abs $ realToFrac $ doubleUlp a) b) <$> resVals | |
mulVal s1 (GVal r i) = GVal (s1*r) i | |
-- | Divide a vector by a scalar. arguments are given in this order for maximum readability. | |
divVecScalarWithErr :: GVec -> ℝ -> (GVec,[ErrVal]) | |
divVecScalarWithErr (GVec vals) s = (GVec resVals, resErr) | |
where | |
resVals = divVal s <$> vals | |
resErr = (\(GVal a b) -> ErrVal (UlpSum $ abs $ realToFrac $ doubleUlp a) b) <$> resVals | |
divVal s1 (GVal r i) = GVal (r/s1) i | |
-- | Divide a vector by a scalar, high precision (read: slow) version. arguments are given in this order for maximum readability. | |
hpDivVecScalar :: GVec -> BigFloat (PrecPlus20 Eps1) -> GVec | |
hpDivVecScalar (GVec vals) s = GVec $ divVal s <$> vals | |
where | |
divVal s1 (GVal r i) = GVal (realToFrac r `hpdiv` realToFrac s1) i | |
hpdiv :: BigFloat (PrecPlus20 Eps1) -> BigFloat (PrecPlus20 Eps1) -> ℝ | |
hpdiv a b = realToFrac $ a / b | |
-- | Calculate the like product of a vector pair. | |
-- actually a wrapper to make use of the fact that gvec1 `likeVecPair` gvec2 == gvec2 `likeVecPair` gvec1. | |
likeVecPair :: GVec -> GVec -> [Either GRVal GVal] | |
likeVecPair a b | |
| a > b = fstEither <$> likeVecPairWithErr' a b | |
| otherwise = fstEither <$> likeVecPairWithErr' b a | |
where | |
fstEither v = case v of | |
(Left (c,_)) -> Left c | |
(Right (c,_)) -> Right c | |
-- | Calculate the like product of a vector pair. | |
-- actually a wrapper to make use of the fact that gvec1 `likeVecPair` gvec2 == gvec2 `likeVecPair` gvec1. | |
likeVecPairWithErr :: GVec -> GVec -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
likeVecPairWithErr a b | |
| a > b = likeVecPairWithErr' a b | |
| otherwise = likeVecPairWithErr' b a | |
-- | Generate the like product of a vector pair. multiply only the values in the basis vector sets that are common between the two GVecs. | |
likeVecPairWithErr' :: GVec -> GVec -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
likeVecPairWithErr' vec1 vec2 = results | |
where | |
results = likeVecPair'' vec1 vec2 | |
-- cycle through one list, and generate a pair with the second list when the two basis vectors are the same. | |
likeVecPair'' :: GVec -> GVec -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
likeVecPair'' (GVec v1) (GVec v2) = concatMap (multiplyLike v1) v2 | |
where | |
multiplyLike :: [GVal] -> GVal -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
multiplyLike vals val@(GVal _ i1) = mulLikePair val <$> P.filter (\(GVal _ i2) -> i2 == i1) vals | |
where | |
mulLikePair :: GVal -> GVal -> Either (GRVal,ErrRVal) (GVal, ErrVal) | |
mulLikePair (GVal r1 i) (GVal r2 _) | |
| size i == 1 = Right (simplify GVal res (elemAt 0 i), simplifyAbs ErrVal resErr (elemAt 0 i)) | |
| otherwise = case nonEmpty (elems i) of | |
(Just newi) -> Left (GRVal res (newi <> newi), ErrRVal resErr (newi <> newi)) | |
Nothing -> error "empty set?" | |
where | |
simplify :: (ℝ -> Set GNum -> c) -> ℝ -> GNum -> c | |
simplify fn v G0 = fn v (singleton G0) | |
simplify fn v (GEPlus _) = fn v (singleton G0) | |
simplify fn v (GEMinus _) = fn (-v) (singleton G0) | |
simplify fn _ (GEZero _) = fn 0 (singleton G0) | |
simplifyAbs :: Monoid c => (a -> Set GNum -> c) -> a -> GNum -> c | |
simplifyAbs fn v G0 = fn v (singleton G0) | |
simplifyAbs fn v (GEPlus _) = fn v (singleton G0) | |
simplifyAbs fn v (GEMinus _) = fn v (singleton G0) | |
simplifyAbs _ _ (GEZero _) = mempty | |
res :: ℝ | |
res = realToFrac (realToFrac r1 * realToFrac r2 :: Rounded 'ToNearest ℝ) | |
resErr = UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac resErrRaw | |
resErrRaw = realToFrac r1 * realToFrac r2 :: Rounded 'TowardInf ℝ | |
-- | Generate the unlike product of a vector pair. multiply only the values in the basis vector sets that are not the same between the two GVecs. | |
unlikeVecPair :: GVec -> GVec -> [Either GRVal GVal] | |
unlikeVecPair vec1 vec2 = fstEither <$> unlikeVecPairWithErr vec1 vec2 | |
where | |
fstEither v = case v of | |
(Left (c,_)) -> Left c | |
(Right (c,_)) -> Right c | |
unlikeVecPairWithErr :: GVec -> GVec -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
unlikeVecPairWithErr vec1 vec2 = results | |
where | |
results = unlikeVecPair' vec1 vec2 | |
-- cycle through one list of vectors, and generate a pair with the second list when the two basis vectors are not the same. | |
unlikeVecPair' :: GVec -> GVec -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
unlikeVecPair' (GVec v1) (GVec v2) = concatMap (multiplyUnlike v1) v2 | |
where | |
multiplyUnlike :: [GVal] -> GVal -> [Either (GRVal,ErrRVal) (GVal, ErrVal)] | |
multiplyUnlike vals val@(GVal _ i) = mulUnlikePair val <$> P.filter (\(GVal _ i2) -> i2 /= i) vals | |
where | |
mulUnlikePair :: GVal -> GVal -> Either (GRVal, ErrRVal) (GVal, ErrVal) | |
mulUnlikePair (GVal r1 i1) (GVal r2 i2) | |
| i1 == singleton G0 = Right (GVal res i2, ErrVal resUlp i2) | |
| i2 == singleton G0 = Right (GVal res i1, ErrVal resUlp i1) | |
| otherwise = case nonEmpty (elems i1) of | |
Nothing -> error "empty set?" | |
(Just newI1) -> case nonEmpty (elems i2) of | |
Nothing -> error "empty set?" | |
(Just newI2) -> Left (GRVal res (newI1 <> newI2), | |
ErrRVal resUlp (newI1 <> newI2)) | |
where | |
res :: ℝ | |
res = realToFrac (realToFrac r1 * realToFrac r2 :: Rounded 'ToNearest ℝ) | |
resUlp = UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac resUlpRaw | |
resUlpRaw = realToFrac r1 * realToFrac r2 :: Rounded 'TowardInf ℝ | |
-- | Generate the reductive product of a vector pair. multiply only values where one of the basis vectors is eliminated by the multiplication. | |
reduceVecPair :: GVec -> GVec -> [GRVal] | |
reduceVecPair vec1 vec2 = fst <$> reduceVecPairWithErr vec1 vec2 | |
-- | Generate the reductive product of a vector pair. multiply only values where one of the basis vectors is eliminated by the multiplication. | |
reduceVecPairWithErr :: GVec -> GVec -> [(GRVal, ErrRVal)] | |
reduceVecPairWithErr vec1 vec2 = results | |
where | |
results = reduceVecPair' vec1 vec2 | |
-- | cycle through one list of vectors, and generate a pair with the second list. multiplies only the values where one set has some common vectors with the other set, but they do not have identical sets. | |
reduceVecPair' :: GVec -> GVec -> [(GRVal, ErrRVal)] | |
reduceVecPair' (GVec v1) (GVec v2) = concatMap (multiplyReducing v1) v2 | |
where | |
multiplyReducing :: [GVal] -> GVal -> [(GRVal, ErrRVal)] | |
multiplyReducing vals val@(GVal _ i) = flip mulReducingPair val <$> P.filter (\(GVal _ i2) -> i2 `common` i) (P.filter (\(GVal _ i2) -> i2 `hasDifferentZeros` i) $ P.filter (\(GVal _ i2) -> i2 /= i) vals) | |
where | |
common :: Set GNum -> Set GNum -> Bool | |
common a b = not $ disjoint a b | |
hasDifferentZeros :: Set GNum -> Set GNum -> Bool | |
hasDifferentZeros nums1 nums2 = disjoint (S.filter isGEZero nums1) (S.filter isGEZero nums2) | |
where | |
isGEZero :: GNum -> Bool | |
isGEZero (GEZero _) = True | |
isGEZero _ = False | |
mulReducingPair (GVal r1 i1) (GVal r2 i2) = | |
case nonEmpty (elems i1) of | |
Nothing -> error "empty set?" | |
(Just newI1) -> | |
case nonEmpty (elems i2) of | |
Nothing -> error "empty set?" | |
(Just newI2) -> (GRVal res (newI1 <> newI2), ErrRVal resUlp (newI1 <> newI2)) | |
where | |
res :: ℝ | |
res = realToFrac (realToFrac r1 * realToFrac r2 :: Rounded 'ToNearest ℝ) | |
resUlp = UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac resUlpRaw | |
resUlpRaw = (realToFrac r1 * realToFrac r2 :: Rounded 'TowardInf ℝ) | |
-- | Generate the geometric product of a vector pair. | |
mulVecPair :: GVec -> GVec -> [Either GRVal GVal] | |
mulVecPair vec1 vec2 = results | |
where | |
results = mulVecPair' vec1 vec2 | |
-- | cycle through one list of vectors, and generate a pair with the second list. | |
mulVecPair' :: GVec -> GVec -> [Either GRVal GVal] | |
mulVecPair' (GVec v1) (GVec v2) = concatMap (mulvals v2) v1 | |
where | |
mulvals :: [GVal] -> GVal -> [Either GRVal GVal] | |
mulvals vals val = mulValPair val <$> vals | |
mulValPair (GVal r1 i1) (GVal r2 i2) | |
| i1 == i2 && size i1 == 1 = simplifyVal (r1*r2) (elemAt 0 i1) | |
| i1 == singleton G0 = Right $ GVal (r1*r2) i2 | |
| i2 == singleton G0 = Right $ GVal (r1*r2) i1 | |
| otherwise = case nonEmpty (elems i1) of | |
Nothing -> error "empty set?" | |
(Just newI1) -> case nonEmpty (elems i2) of | |
Nothing -> error "empty set?" | |
(Just newI2) -> Left $ GRVal (r1 * r2) (newI1 <> newI2) | |
where | |
simplifyVal v G0 = Right $ GVal v (singleton G0) | |
simplifyVal v (GEPlus _) = Right $ GVal v (singleton G0) | |
simplifyVal v (GEMinus _) = Right $ GVal (-v) (singleton G0) | |
simplifyVal _ (GEZero _) = Right $ GVal 0 (singleton G0) | |
-- | Generate the geometric product of a vector pair, preserving the error quotents. | |
mulVecPairWithErr :: GVec -> GVec -> [Either (GRVal, ErrRVal) (GVal, ErrVal)] | |
mulVecPairWithErr vec1 vec2 = results | |
where | |
results = mulVecPairWithErr' vec1 vec2 | |
-- | cycle through one list of vectors, and generate a pair with the second list. | |
mulVecPairWithErr' :: GVec -> GVec -> [Either (GRVal, ErrRVal) (GVal, ErrVal)] | |
mulVecPairWithErr' (GVec v1) (GVec v2) = concatMap (mulvals v2) v1 | |
where | |
mulvals :: [GVal] -> GVal -> [Either (GRVal, ErrRVal) (GVal, ErrVal)] | |
mulvals vals val = mulValPairWithErr val <$> vals | |
mulValPairWithErr :: GVal -> GVal -> Either (GRVal, ErrRVal) (GVal, ErrVal) | |
mulValPairWithErr (GVal r1 i1) (GVal r2 i2) | |
| i1 == i2 && size i1 == 1 = Right (simplify GVal res (elemAt 0 i1), simplifyAbs ErrVal resUlp (elemAt 0 i1)) | |
| i1 == singleton G0 = Right (GVal res i2, ErrVal resUlp i2) | |
| i2 == singleton G0 = Right (GVal res i1, ErrVal resUlp i1) | |
| otherwise = case nonEmpty (elems i1) of | |
Nothing -> error "empty set?" | |
(Just newI1) -> case nonEmpty (elems i2) of | |
Nothing -> error "empty set?" | |
(Just newI2) -> Left (GRVal res (newI1 <> newI2), ErrRVal resUlp (newI1 <> newI2)) | |
where | |
res :: ℝ | |
res = realToFrac (realToFrac r1 * realToFrac r2 :: Rounded 'ToNearest ℝ) | |
resUlp = UlpSum $ abs $ realToFrac $ doubleUlp $ realToFrac resUlpRaw | |
resUlpRaw = realToFrac r1 * realToFrac r2 :: Rounded 'TowardInf ℝ | |
simplify :: (ℝ -> Set GNum -> c) -> ℝ -> GNum -> c | |
simplify fn v G0 = fn v (singleton G0) | |
simplify fn v (GEPlus _) = fn v (singleton G0) | |
simplify fn v (GEMinus _) = fn (-v) (singleton G0) | |
simplify fn _ (GEZero _) = fn 0 (singleton G0) | |
simplifyAbs :: Monoid c => (a -> Set GNum -> c) -> a -> GNum -> c | |
simplifyAbs fn v G0 = fn v (singleton G0) | |
simplifyAbs fn v (GEPlus _) = fn v (singleton G0) | |
simplifyAbs fn v (GEMinus _) = fn v (singleton G0) | |
simplifyAbs _ _ (GEZero _) = mempty | |
-- | For a multi-basis value where each basis vector is wedged against one another, sort the basis vectors remembering to invert the value if necessary. | |
sortBasis :: GRVal -> GRVal | |
sortBasis (GRVal r i) = if shouldFlip then GRVal (-r) basis else GRVal r basis | |
where | |
(shouldFlip, basis) = sortBasis' i | |
-- | For a multi-basis error quotent where each basis vector is wedged against one another, just sort the basis vectors. | |
sortErrBasis :: ErrRVal -> ErrRVal | |
sortErrBasis (ErrRVal r i) = ErrRVal r basis | |
where | |
(_, basis) = sortBasis' i | |
-- | Wrap sortBasisInternal in a memoization, so it becomes a tree lookup over time. | |
sortBasis' :: NonEmpty GNum -> (Bool, NonEmpty GNum) | |
sortBasis' = memo sortBasisInternal | |
-- | Sort a set of basis vectors. Must return an ideal result, along with wehther the associated real value should be flipped or not. | |
sortBasisInternal :: NonEmpty GNum -> (Bool, NonEmpty GNum) | |
sortBasisInternal thisBasis | |
-- If the basis part of calling sortBasis'' once vs calling sortBasis'' twice doesn't change, we are done sorting. | |
| basisOf sortOnce == basisOf recurseTwice = sortOnce | |
-- If not, recurse. | |
| otherwise = recurseTwice | |
where | |
sortOnce = sortBasis'' thisBasis | |
recurseTwice :: (Bool, NonEmpty GNum) | |
recurseTwice = (flipOf (sortBasis'' $ basisOf sortOnce) /= flipOf sortOnce, basisOf $ sortBasis'' $ basisOf sortOnce) | |
basisOf = snd | |
flipOf = fst | |
-- | sort a set of wedged basis vectors. may not provide an ideal result, but should return a better result, along with whether the associated real value should be flipped or not. | |
sortBasis'' :: NonEmpty GNum -> (Bool, NonEmpty GNum) | |
sortBasis'' (a:|[]) = (False,a:|[]) | |
sortBasis'' (a:|[b]) = if a > b then (True, b:|[a]) else (False, a:|[b]) | |
sortBasis'' (a:|(b:xs)) = if a > b | |
then (not $ flipOf $ sortBasis'' (a:|xs), b `cons` basisOf (sortBasis'' (a:|xs))) | |
else ( flipOf $ sortBasis'' (b:|xs), a `cons` basisOf (sortBasis'' (b:|xs))) | |
-- | For a multi-basis value with each basis wedged against one another, where they are in ascending order, we can end up with vectors that have multiple occurances of the same basis vector. strip these out, negating the real part as appropriate. | |
stripPairs :: GRVal -> GRVal | |
stripPairs (GRVal real vals) | |
| isJust flipRes = if flipRes == Just False | |
then GRVal real res | |
else GRVal (-real) res | |
| otherwise = GRVal 0 (G0:|[]) | |
where | |
(flipRes, res) = withoutPairs (Just False, vals) | |
-- | For a multi-basis value with each basis wedged against one another, where they are in ascending order, we can end up with vectors that have multiple occurances of the same basis vector. strip these out, negating the real part as appropriate. | |
stripErrPairs :: ErrRVal -> ErrRVal | |
stripErrPairs (ErrRVal real vals) = ErrRVal real res | |
where | |
(_, res) = withoutPairs (Just False, vals) | |
withoutPairs :: (Maybe Bool, NonEmpty GNum) -> (Maybe Bool, NonEmpty GNum) | |
withoutPairs = memo withoutPairs' | |
-- | Perform elimination of basis pairs from the given basis set. only works right if the basis set has been sorted first. | |
-- The maybe bool tracks whether the result should be thrown away (two identical GEZeros), or if the result should have its value inverted. | |
withoutPairs' :: (Maybe Bool, NonEmpty GNum) -> (Maybe Bool, NonEmpty GNum) | |
withoutPairs' (_, oneI:|[]) = (Just False, oneI:|[]) | |
withoutPairs' (r, is@((GEPlus a):|(GEPlus b):xs)) | |
| a == b = case nonEmpty xs of | |
Nothing -> (r, G0:|[]) | |
(Just vs) -> withoutPairs (r, vs) | |
| a /= b = case nonEmpty xs of | |
Nothing -> (r, is) | |
(Just _) -> prependI (GEPlus a) $ withoutPairs (r, GEPlus b:|xs) | |
withoutPairs' (r, is@((GEMinus a):|(GEMinus b):xs)) | |
| a == b = case nonEmpty xs of | |
Nothing -> (maybeNot r,G0:|[]) | |
(Just vs) -> withoutPairs (maybeNot r,vs) | |
| a /= b = case nonEmpty xs of | |
Nothing -> (r,is) | |
(Just _) -> prependI (GEMinus a) $ withoutPairs (r, GEMinus b:|xs) | |
where | |
maybeNot :: Maybe Bool -> Maybe Bool | |
maybeNot Nothing = Nothing | |
maybeNot (Just v) = Just $ not v | |
withoutPairs' (r, is@((GEZero a):|(GEZero b):xs)) | |
| a == b = (Nothing,G0:|[]) | |
| a /= b = case nonEmpty xs of | |
Nothing -> (r,is) | |
(Just _) -> prependI (GEZero a) $ withoutPairs (r, GEZero b:|xs) | |
withoutPairs' (r, a:|b:xs) = prependI a $ withoutPairs (r,b:|xs) | |
-- | place a term on the front of the basis vector set. | |
-- if the vector set contains only the scalar vector, eliminate it. | |
prependI :: GNum -> (a,NonEmpty GNum) -> (a, NonEmpty GNum) | |
prependI num (r,nums) = (r, newPrependI num nums) | |
where | |
newPrependI :: GNum -> NonEmpty GNum -> NonEmpty GNum | |
newPrependI n ns | |
| ns == (G0:|[]) = n:|[] | |
| otherwise = n `cons` ns | |
-- | A post processor, to convert a GRVal into a GVal. this sorts the basis vectors as part of the conversion. | |
postProcess :: GRVal -> GVal | |
postProcess val = grValToGVal $ stripPairs $ sortBasis val | |
-- | A post processor, to convert a GRVal into a GVal. this sorts the basis vectors as part of the conversion. it may be given a GVal, in which case it short circuits. | |
postProcessVals :: Either GRVal GVal -> GVal | |
postProcessVals (Right gval) = gval | |
postProcessVals (Left grval) = grValToGVal $ stripPairs $ sortBasis grval | |
-- | A post processor, to convert a GRVal into a GVal, preserving the attached error. this sorts the basis vectors as part of the conversion. it may be given a GVal, in which case it short circuits. | |
postProcessEitherVals :: Either (GRVal, ErrRVal) (GVal, ErrVal) -> GVal | |
postProcessEitherVals (Right (v,_)) = v | |
postProcessEitherVals (Left (v,_)) = grValToGVal $ stripPairs $ sortBasis v | |
-- | Type Conversion of a GRval to a GVal. only to be used in postProcess, postProcessVals, and postProcessEitherVals. | |
grValToGVal :: GRVal -> GVal | |
grValToGVal (GRVal r i) = GVal r (fromAscList (toList i)) | |
-- | A post processor, to convert a ErrRVal into an ErrVal. this sorts the basis vectors as part of the conversion. | |
postProcessErrs :: ErrRVal -> ErrVal | |
postProcessErrs val = errRValToErrVal $ stripErrPairs $ sortErrBasis val | |
-- | A post processor, to convert a ErrRVal into an ErrVal, preserving the attached error. this sorts the basis vectors as part of the conversion. it may be given an ErrVal, in which case it short circuits. | |
postProcessEitherErrs :: Either (GRVal, ErrRVal) (GVal, ErrVal) -> ErrVal | |
postProcessEitherErrs (Right (_,v)) = v | |
postProcessEitherErrs (Left (_,v)) = errRValToErrVal $ stripErrPairs $ sortErrBasis v | |
-- | Type conversion of an ErrRVal to an ErrVal. only safe to use from postProcessErrs and postProcessEitherErrs. | |
errRValToErrVal :: ErrRVal -> ErrVal | |
errRValToErrVal (ErrRVal r i) = ErrVal r (fromAscList (toList i)) | |
-- | Our "like" operator. unicode point u+23a3. | |
(⎣) :: GVec -> GVec -> GVec | |
infixl 9 ⎣ | |
(⎣) v1 v2 = fst $ v1 ⎣+ v2 | |
-- | Our "like" operator, returning calculation error. unicode point u+23a3. | |
(⎣+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal])) | |
infixl 9 ⎣+ | |
(⎣+) v1 v2 = (GVec vals | |
, (mulErrs, addErrs)) | |
where | |
vals = fst <$> likeRes' | |
addErrs = P.filter (/= mempty) $ snd <$> likeRes' | |
likeRes'= foldl' addValWithErr [] $ postProcessEitherVals <$> likeRes | |
mulErrs = foldl' addErr [] $ postProcessEitherErrs <$> likeRes | |
likeRes = likeVecPairWithErr v1 v2 | |
-- | Our "unlike" operator. unicode point u+23a4. | |
(⎤) :: GVec -> GVec -> GVec | |
infixl 9 ⎤ | |
(⎤) v1 v2 = fst $ v1 ⎤+ v2 | |
-- | Our "unlike" operator, with attached Error bounds. unicode point u+23a4. | |
(⎤+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal])) | |
infixl 9 ⎤+ | |
(⎤+) v1 v2 = (GVec vals | |
, (mulErrs, addErrs)) | |
where | |
vals = fst <$> unlikeRes' | |
addErrs = P.filter (/= mempty) $ snd <$> unlikeRes' | |
unlikeRes' = foldl' addValWithErr [] $ postProcessEitherVals <$> unlikeRes | |
mulErrs = foldl' addErr [] $ postProcessEitherErrs <$> unlikeRes | |
unlikeRes = unlikeVecPairWithErr v1 v2 | |
-- | Our "reductive" operator. | |
(⨅) :: GVec -> GVec -> GVec | |
infixl 9 ⨅ | |
(⨅) v1 v2 = fst $ v1 ⨅+ v2 | |
-- | Our "reductive" operator, with attached Error. | |
(⨅+) :: GVec -> GVec -> (GVec, ([ErrVal],[ErrVal])) | |
infixl 9 ⨅+ | |
(⨅+) v1 v2 = (GVec vals | |
, (mulErrs, addErrs)) | |
where | |
vals = fst <$> res | |
addErrs = P.filter (/= mempty) $ snd <$> res | |
res = foldl' addValWithErr [] $ postProcess . fst <$> reduceRes | |
mulErrs = foldl' addErr [] $ postProcessErrs . snd <$> reduceRes | |
reduceRes = reduceVecPairWithErr v1 v2 | |
-- | A wedge operator. gets the wedge product of the two arguments. note that wedge = reductive minus unlike. | |
(∧) :: GVec -> GVec -> GVec | |
infixl 9 ∧ | |
(∧) v1 v2 = vec | |
where | |
vec = subVecPair (GVec resReduce) (GVec resUnlike) | |
resUnlike = foldl' addVal [] $ postProcessVals <$> unlikeVecPair v1 v2 | |
resReduce = foldl' addVal [] $ postProcess <$> reduceVecPair v1 v2 | |
-- | A wedge operator that preserves error. gets the wedge product of the two arguments. note that wedge = reductive minus unlike. | |
(∧+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal], [ErrVal], [ErrVal], [ErrVal])) | |
infixl 9 ∧+ | |
(∧+) v1 v2 = (vec, (unlikeMulErrs, unlikeAddErrs, reduceMulErrs, reduceAddErrs, vecSubErrs)) | |
where | |
(vec, vecSubErrs) = subVecPairWithErr (GVec reduceVals) (GVec unlikeVals) | |
unlikeVals = fst <$> unlikeRes' | |
unlikeAddErrs = P.filter (/= mempty) $ snd <$> unlikeRes' | |
unlikeRes' = foldl' addValWithErr [] $ postProcessEitherVals <$> unlikeRes | |
unlikeMulErrs =foldl' addErr [] $ postProcessEitherErrs <$> unlikeRes | |
unlikeRes = unlikeVecPairWithErr v1 v2 | |
reduceVals = fst <$> reduceRes' | |
reduceAddErrs = P.filter (/= mempty) $ snd <$> reduceRes' | |
reduceRes' = foldl' addValWithErr [] $ postProcess . fst <$> reduceRes | |
reduceMulErrs = postProcessErrs . snd <$> reduceRes | |
reduceRes = reduceVecPairWithErr v1 v2 | |
-- | A dot operator. gets the dot product of the two arguments. note that dot = reductive plus like. | |
(⋅) :: GVec -> GVec -> GVec | |
infixl 9 ⋅ | |
(⋅) v1 v2 = vals | |
where | |
vals = addVecPair (GVec resLike) (GVec resReduce) | |
resLike = foldl' addVal [] $ postProcessVals <$> likeVecPair v1 v2 | |
resReduce = foldl' addVal [] $ postProcess <$> reduceVecPair v1 v2 | |
-- | A dot operator that preserves error. gets the dot product of the two arguments. | |
-- Note that dot product = reductive product plus like product. | |
(⋅+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal], [ErrVal], [ErrVal], [ErrVal])) | |
infixl 9 ⋅+ | |
(⋅+) v1 v2 = (vec | |
, (likeMulErrs, reduceMulErrs, likeAddErrs, reduceAddErrs, vecAddErrs)) | |
where | |
vecAddErrs = P.filter (/= mempty) $ vecAddErrsRaw | |
(vec, vecAddErrsRaw) = addVecPairWithErr (GVec reduceVals) (GVec likeVals) | |
likeVals = fst <$> likeRes' | |
likeAddErrs = P.filter (/= mempty) $ snd <$> likeRes' | |
likeMulErrs = foldl' addErr [] $ postProcessEitherErrs <$> likeRes | |
likeRes' = foldl' addValWithErr [] $ postProcessEitherVals <$> likeRes | |
likeRes = likeVecPairWithErr v1 v2 | |
reduceVals = fst <$> reduceRes' | |
reduceAddErrs = P.filter (/= mempty) $ snd <$> reduceRes' | |
reduceRes' = foldl' addValWithErr [] $ postProcess . fst <$> reduceRes | |
reduceMulErrs = postProcessErrs . snd <$> reduceRes | |
reduceRes = reduceVecPairWithErr v1 v2 | |
-- | A geometric product operator. Gets the geometric product of the two arguments. | |
(•) :: GVec -> GVec -> GVec | |
infixl 9 • | |
(•) v1 v2 = GVec $ foldl' addVal [] $ postProcessVals <$> mulVecPair v1 v2 | |
-- | A geometric product operator. Gets the geometric product of the two arguments. | |
(•+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal])) | |
infixl 9 •+ | |
(•+) v1 v2 = (GVec vals, (geomMulErrs, geomAddErrs)) | |
where | |
vals = fst <$> geomRes' | |
geomAddErrs = P.filter (/= mempty) $ snd <$> geomRes' | |
geomMulErrs = foldl' addErr [] $ postProcessEitherErrs <$> geomRes | |
geomRes' = foldl' addValWithErr [] $ postProcessEitherVals <$> geomRes | |
geomRes = mulVecPairWithErr v1 v2 | |
-- | Return the scalar component of the given GVec. | |
scalarPart :: GVec -> ℝ | |
scalarPart (GVec vals) = sum $ realValue <$> vals | |
where | |
realValue (GVal r gnums) = if gnums == singleton G0 then r else 0 | |
-- | Return the non-scalar component of the given GVec. | |
vectorPart :: GVec -> GVec | |
vectorPart (GVec vals) = GVec $ foldl' addVal [] $ P.filter noRealValue vals | |
where | |
noRealValue (GVal _ gnums) = gnums /= singleton G0 | |
-- | Temporary hack. | |
sumErrVals :: [ErrVal] -> UlpSum | |
sumErrVals errVals = UlpSum $ sum $ ulpRaw . (\(ErrVal a _) -> a) <$> errVals |