module Algebra.Structures.Coherent
( Coherent(solve)
, propCoherent
, solveMxN, propSolveMxN
, solveWithIntersection
, solveGeneralEquation, propSolveGeneralEquation
, solveGeneral, propSolveGeneral
) where
import Test.QuickCheck
import Algebra.Structures.IntegralDomain
import Algebra.Structures.StronglyDiscrete
import Algebra.Matrix
import Algebra.Ideal
class IntegralDomain a => Coherent a where
solve :: Vector a -> Matrix a
isSolution :: (CommutativeRing a, Eq a) => Matrix a -> Matrix a -> Bool
isSolution m sol = all (==zero) (concat (unMVec (m `mulM` sol)))
propCoherent :: (Coherent a, Eq a) => Vector a -> Bool
propCoherent m = isSolution (vectorToMatrix m) (solve m)
solveMxN :: (Coherent a, Eq a) => Matrix a -> Matrix a
solveMxN (M (l:ls)) = solveMxN' (solve l) ls
where
solveMxN' :: (Coherent a, Eq a) => Matrix a -> [Vector a] -> Matrix a
solveMxN' m [] = m
solveMxN' m1 (x:xs) = if isSolution (vectorToMatrix x) m1
then solveMxN' m1 xs
else solveMxN' (m1 `mulM` m2) xs
where m2 = solve (matrixToVector (mulM (vectorToMatrix x) m1))
propSolveMxN :: (Coherent a, Eq a) => Matrix a -> Bool
propSolveMxN m = isSolution m (solveMxN m)
solveWithIntersection :: (IntegralDomain a, Eq a)
=> Vector a
-> (Ideal a -> Ideal a -> (Ideal a,[[a]],[[a]]))
-> Matrix a
solveWithIntersection (Vec xs) int = transpose $ matrix $ solveInt xs
where
solveInt [] = error "solveInt: Can't solve an empty system"
solveInt [x] = [[zero]]
solveInt (x:xs)
| x == zero = map (zero:) $ solveInt xs
| isSameIdeal int as bs = s ++ m'
| otherwise = error "solveInt: This does not compute the intersection"
where
as = Id [x]
bs = Id (map neg xs)
(Id ts,us,vs) = as `int` bs
s = [ u ++ v | (u,v) <- zip us vs ]
m = solveInt xs
m' = map (zero:) m
solveGeneralEquation :: (Coherent a, StronglyDiscrete a) => Vector a -> a -> Maybe (Matrix a)
solveGeneralEquation v@(Vec xs) b =
let sol = solve v
in case b `member` (Id xs) of
Just as -> Just $ transpose (M (replicate (length (head (unMVec sol))) (Vec as)))
`addM` sol
Nothing -> Nothing
propSolveGeneralEquation :: (Coherent a, StronglyDiscrete a, Eq a)
=> Vector a
-> a
-> Bool
propSolveGeneralEquation v b = case solveGeneralEquation v b of
Just sol -> all (==b) $ concat $ unMVec $ vectorToMatrix v `mulM` sol
Nothing -> True
isSolutionB v sol b = all (==b) $ concat $ unMVec $ vectorToMatrix v `mulM` sol
solveGeneral :: (Coherent a, StronglyDiscrete a, Eq a)
=> Matrix a
-> Vector a
-> Maybe (Matrix a, Matrix a)
solveGeneral (M (l:ls)) (Vec (a:as)) =
case solveGeneral' (solveGeneralEquation l a) ls as [(l,a)] of
Just x0 -> Just (solveMxN (M (l:ls)), x0)
Nothing -> Nothing
where
solveGeneral' Nothing _ _ _ = Nothing
solveGeneral' (Just m) [] [] old = Just m
solveGeneral' (Just m) (l:ls) (a:as) old =
if isSolutionB l m a
then solveGeneral' (Just m) ls as old
else case solveGeneralEquation (matrixToVector (vectorToMatrix l `mulM` m)) a of
Just m' -> let m'' = m `mulM` m'
in if all (\(x,y) -> isSolutionB x m'' y) old
then solveGeneral' (Just m'') ls as ((l,a):old)
else Nothing
Nothing -> Nothing
solveGeneral' _ _ _ _ = error "solveGeneral: Bad input"
propSolveGeneral m b = length (unM m) == length (unVec b) ==> case solveGeneral m b of
Just (l,x) -> all (==b) (unM (transpose (m `mulM` x))) &&
isSolution m l
Nothing -> True