{-| Module : Main Description : Test of Multilinear library Copyright : (c) Artur M. Brodzki, 2018 License : BSD3 Maintainer : artur@brodzki.org Stability : experimental Portability : Windows/POSIX -} module Main ( main ) where import Data.Maybe import qualified Data.Set as Set import Multilinear import Multilinear.Generic import qualified Multilinear.Index as Index import System.Exit import System.IO import Test.QuickCheck import Test.QuickCheck.Multilinear() -- | Default test number for property defTestN :: Int defTestN = 1000 ------------------------------ -- AUXILIARY TEST FUNCTIONS -- ------------------------------ -- quickCheck with parametrizable tests number quickCheckN :: Testable prop => Int -> prop -> IO Result quickCheckN n = quickCheckWithResult (Args Nothing -- ^ Should we replay a previous test? No. n -- ^ Maximum number of successful tests before succeeding set to N. 1 -- ^ Maximum number of discarded tests per successful test before giving up - gave up after first failure. n -- ^ Size to use for the biggest test cases. True -- ^ Whether to print anything? yes. 0) -- ^ Maximum number of shrinks to before giving up. Turn shrinking off. -- | Execute property test and check result: -- | exit test suite with successs code if no errors occured -- | exit test suite with failure code if any error occured executePropertyTest :: ( Testable prop ) => String -- ^ Tested property name -> Int -- ^ Number of tests to do -> prop -- ^ Property to test -> IO () executePropertyTest propName n f = do putStr $ " Checking " ++ propName ++ " " r <- quickCheckN n f case r of Success _ _ _ -> hFlush stdout _ -> exitFailure ------------------------------ -- TESTED TENSOR PROPERTIES -- ------------------------------ -- | Unary operator applied on any tensor, -- | must preserve tensor indices in the result. preserveIndicesUnary :: (Tensor Double -> Tensor Double) -- ^ Unary tensor operator to test -> Tensor Double -- ^ Operator argument -> Bool preserveIndicesUnary f t = indices t == indices (f t) -- | Binary operator applied on any two tensors which have all the same indices, -- | must preserve set union of these indices in the result. preserveIndicesBinary :: (Tensor Double -> Tensor Double -> Tensor Double) -- ^ Binary tensor operator to test -> Tensor Double -- ^ First operator argument -> Tensor Double -- ^ Second operator argument -> Bool preserveIndicesBinary f t1 t2 = let i1 = Set.fromList $ indices t1 i2 = Set.fromList $ indices t2 in i1 /= i2 || i1 == Set.fromList (indices $ f t1 t2) -- | Binary operator other than tensor product cannot contract (or consume) any index -- | it means, that in operators other than (*), the indices of result tensor are set union of arguments indices mergeCommonIndices :: (Tensor Double -> Tensor Double -> Tensor Double) -- ^ Binary tensor operator to test -> Tensor Double -- ^ First operator argument -> Tensor Double -- ^ Second operator argument -> Bool mergeCommonIndices f t1 t2 = let indices1 = Set.fromList $ indices t1 indices2 = Set.fromList $ indices t2 inames1 = Set.fromList $ Index.indexName <$> indices t1 inames2 = Set.fromList $ Index.indexName <$> indices t2 commonIndices = Set.intersection indices1 indices2 commonIndicesNames = Set.intersection inames1 inames2 expectedIndices = Set.union inames1 inames2 resultIndices = Set.fromList $ Index.indexName <$> indices (f t1 t2) -- if we have indices, which have the same name but different type, it is forbidden and test passed in Set.size commonIndices /= Set.size commonIndicesNames || -- otherwise, the result indices set must be union of arguments indices expectedIndices == resultIndices -- | Contracted indices have to be consumed in result tensor. consumeContractedIndices :: Tensor Double -- ^ first tensor to contract -> Tensor Double -- ^ second tensor to contract -> Bool consumeContractedIndices t1 t2 = let inames1 = Set.fromList $ Index.indexName <$> indices t1 inames2 = Set.fromList $ Index.indexName <$> indices t2 iContravariantNames1 = Set.fromList $ Index.indexName <$> (Index.isContravariant `Prelude.filter` indices t1) iCovariantNames1 = Set.fromList $ Index.indexName <$> (Index.isCovariant `Prelude.filter` indices t1) iContravariantNames2 = Set.fromList $ Index.indexName <$> (Index.isContravariant `Prelude.filter` indices t2) iCovariantNames2 = Set.fromList $ Index.indexName <$> (Index.isCovariant `Prelude.filter` indices t2) contractedIndices = -- contracted are indices covariant in the first tensor and contravariant in the second Set.intersection iCovariantNames1 iContravariantNames2 `Set.union` -- or contravariant in the first tensor and covariant in the second Set.intersection iContravariantNames1 iCovariantNames2 expectedIndices = Set.difference (Set.union inames1 inames2) contractedIndices resultIndices = Set.fromList $ Index.indexName <$> indices (t1 * t2) in expectedIndices == resultIndices -- | Order of the tensor must be equal to number of its covariant and contravariant indices orderIndices :: Tensor Double -> Bool orderIndices t = let (conv, cov) = order t iConv = Set.fromList $ Index.isContravariant `Prelude.filter` indices t iCov = Set.fromList $ Index.isCovariant `Prelude.filter` indices t in conv == Set.size iConv && cov == Set.size iCov -- | Tensor must be equivalent in terms of its indices after any index shift shiftEquiv :: Tensor Double -> Bool shiftEquiv t = let inames = indicesNames t rShiftedTs = (\i -> t |>> i) <$> inames lShiftedTs = (\i -> t <<| i) <$> inames rtShiftedTs = (\i -> t |>>> i) <$> inames ltShiftedTs = (\i -> t <<<| i) <$> inames allShiftedTs = rShiftedTs ++ lShiftedTs ++ rtShiftedTs ++ ltShiftedTs ++ [t] allPairs = pure (,) <*> allShiftedTs <*> allShiftedTs in all (uncurry (|==|)) allPairs {-| After rename, index must hold a new name This property assumes, tensor have max 5 indices of each type -} renameTest :: Tensor Double -> Bool renameTest t = let (conv, cov) = order t convNs = take conv ['m' .. ] covNs = take cov ['s' .. ] renamedT = t $| (convNs, covNs) inamesAfter = concat $ indicesNames renamedT in all (\i -> elem i convNs || elem i covNs) inamesAfter -- | After any raising or lowering index, it must be a valid type. raiseLowerTest :: Tensor Double -> Bool raiseLowerTest t = let inames = indicesNames t lowered = inames `zip` ((t \/) <$> inames) raised = inames `zip` ((t /\) <$> inames) isLowered (i,tl) = i `elem` (Index.indexName <$> (Index.isCovariant `Prelude.filter` indices tl)) isRaised (i,tr) = i `elem` (Index.indexName <$> (Index.isContravariant `Prelude.filter` indices tr)) in all isLowered lowered && all isRaised raised -- | Filter second half of elements for each tensor index and check if they disappeared filterIndexTest :: Tensor Double -> Bool filterIndexTest s@(Scalar _) = s == filterIndex "c" (const True) s filterIndexTest t = let indsT = indices t -- filter second half of an index filteredHalf i = filterIndex (Index.indexName i) (< (fromJust (Index.indexSize i) `div` 2)) t fts = indsT `zip` (filteredHalf <$> indsT) -- tensors with filtered indices, paired with respective transformed indices in all (\(i,ft) -> size ft (Index.indexName i) == (fromJust (Index.indexSize i) `div` 2) ) fts -- | ENTRY POINT main :: IO () main = do -- PRINT PROBABILITY DISTRIBUTION OF TESTED TENSORS ORDER executePropertyTest "probability distribution of order of tested tensors" 5000 $ \(t :: Tensor Double) -> collect (order t) $ preserveIndicesUnary abs putStrLn "\nTesting multilinear library...\n" --------------------------- -- CHECKING NUM INSTANCE -- --------------------------- executePropertyTest "preserveIndicesBinary for (+)" defTestN $ preserveIndicesBinary (+) executePropertyTest "preserveIndicesBinary for (-)" defTestN $ preserveIndicesBinary (-) executePropertyTest "preserveIndicesBinary for (*)" defTestN $ preserveIndicesBinary (*) executePropertyTest "preserveIndicesUnary for abs" defTestN $ preserveIndicesUnary abs executePropertyTest "preserveIndicesUnary for signum" defTestN $ preserveIndicesUnary signum executePropertyTest "mergeCommonIndices for (+)" defTestN $ mergeCommonIndices (+) executePropertyTest "mergeCommonIndices for (-)" defTestN $ mergeCommonIndices (-) executePropertyTest "consumeContractedIndices" defTestN consumeContractedIndices -------------------------------- -- CHECKING FLOATING INSTANCE -- -------------------------------- executePropertyTest "preserveIndicesUnary for exp" defTestN $ preserveIndicesUnary exp executePropertyTest "preserveIndicesUnary for log" defTestN $ preserveIndicesUnary log executePropertyTest "preserveIndicesUnary for sin" defTestN $ preserveIndicesUnary sin executePropertyTest "preserveIndicesUnary for cos" defTestN $ preserveIndicesUnary cos executePropertyTest "preserveIndicesUnary for asin" defTestN $ preserveIndicesUnary asin executePropertyTest "preserveIndicesUnary for acos" defTestN $ preserveIndicesUnary acos executePropertyTest "preserveIndicesUnary for atan" defTestN $ preserveIndicesUnary atan executePropertyTest "preserveIndicesUnary for sinh" defTestN $ preserveIndicesUnary sinh executePropertyTest "preserveIndicesUnary for cosh" defTestN $ preserveIndicesUnary cosh executePropertyTest "preserveIndicesUnary for asinh" defTestN $ preserveIndicesUnary asinh executePropertyTest "preserveIndicesUnary for acosh" defTestN $ preserveIndicesUnary acosh executePropertyTest "preserveIndicesUnary for atanh" defTestN $ preserveIndicesUnary atanh ----------------------------------- -- CHECKING MULTILINEAR INSTANCE -- ----------------------------------- executePropertyTest "preserveIndicesUnary for (+.)" defTestN $ preserveIndicesUnary (5 +.) executePropertyTest "preserveIndicesUnary for (.+)" defTestN $ preserveIndicesUnary (.+ 5) executePropertyTest "preserveIndicesUnary for (-.)" defTestN $ preserveIndicesUnary (5 -.) executePropertyTest "preserveIndicesUnary for (.-)" defTestN $ preserveIndicesUnary (.- 5) executePropertyTest "preserveIndicesUnary for (*.)" defTestN $ preserveIndicesUnary (5 *.) executePropertyTest "preserveIndicesUnary for (.*)" defTestN $ preserveIndicesUnary (.* 5) executePropertyTest "orderIndices" defTestN orderIndices executePropertyTest "shiftEquiv" defTestN shiftEquiv executePropertyTest "renamedTest" defTestN renameTest executePropertyTest "raiseLowerTest" defTestN raiseLowerTest executePropertyTest "filterIndexTest" defTestN filterIndexTest executePropertyTest "zipWithIndicesTest" defTestN $ preserveIndicesUnary (\t -> Multilinear.zipWith (+) t t)