diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for multisets + +## 0.1.0.0 -- 2026-09-15 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2026 Florian Ragwitz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/multisets.cabal b/multisets.cabal new file mode 100644 --- /dev/null +++ b/multisets.cabal @@ -0,0 +1,53 @@ +cabal-version: 3.0 +name: multisets +version: 0.1.0.0 +synopsis: Multisets with arbitrary-precision Natural multiplicities +description: + Finite multisets with arbitrary-precision 'Natural' multiplicities. + + A 'MultiSet' is like a 'Data.Set.Set', except that values may occur more than + once. The number of occurrences of a value is its /multiplicity/. + + Unlike "Data.MultiSet", this package represents multiplicities using + 'Natural' rather than 'Int', allowing them to grow beyond the range of 'Int' + while reflecting that multiplicities cannot be negative. + + The API is broadly similar to "Data.MultiSet", and many common uses are + source-compatible after changing the module import. +homepage: https://github.com/rafl/multisets +bug-reports: https://github.com/rafl/multisets/issues +license: MIT +license-file: LICENSE +author: Florian Ragwitz +maintainer: florian.ragwitz@gmail.com +copyright: (c) 2026 Florian Ragwitz +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + branch: main + location: https://github.com/rafl/multisets + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Data.MultiSet.Natural + build-depends: base >= 4.9 && < 4.24, containers >= 0.6.2.1 && < 0.9, deepseq >= 1.4 && < 1.6 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite multisets-test + import: warnings + default-language: Haskell2010 + other-modules: Test.Gen, Test.Valid, Test.ToFrom, Test.Queries, Test.Instances, Test.Effects, Test.Folds, Test.Transformations, Test.Updates, Test.Combining, Test.Extremes + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, containers, multisets, deepseq, + tasty >= 1.2.3 && < 1.6, tasty-quickcheck >= 0.10.1.1 && < 0.12, QuickCheck >= 2.13.2 && < 2.19 + ghc-options: -Wall -threaded -rtsopts diff --git a/src/Data/MultiSet/Natural.hs b/src/Data/MultiSet/Natural.hs new file mode 100644 --- /dev/null +++ b/src/Data/MultiSet/Natural.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} + +{- | + Module: Data.MultiSet.Natural + Description: Multisets with arbitrary-precision Natural multiplicities + Copyright: (c) 2026 Florian Ragwitz + License: MIT + + Finite multisets with 'Natural' multiplicities. + + A 'MultiSet' is like a 'Data.Set.Set', except that values may occur more than + once. The number of occurrences of a value is its /multiplicity/. + + In contrast to "Data.MultiSet", this module represents multiplicities by + 'Natural', allowing them to exceed the range of 'Int'. See + [Comparison to Data.MultiSet]("Data.MultiSet.Natural#g:comparison") + for more details on how the two modules differ. + + This module is intended to be imported qualified, to avoid name clashes with + Prelude functions, e.g. + + > import Data.MultiSet.Natural (MultiSet) + > import qualified Data.MultiSet.Natural as MS + + When distinct values compare equal under 'Ord', no guarantee is made about + which value is retained as the representative. +-} +module Data.MultiSet.Natural ( + -- * Comparison to @Data.MultiSet@ #comparison# + + {- | + + This module is broadly similar to "Data.MultiSet". Many common uses are + source-compatible after changing the module import, and migration is + usually straightforward. + + The main difference is that this module represents multiplicities using + 'Natural' rather than 'Int', allowing them to grow beyond the range of + 'Int' while also reflecting that multiplicities cannot be negative. + + This module was also motivated in part by a number of longstanding + issues in "Data.MultiSet", including correctness bugs, alongside + relatively limited maintenance in recent years. + + The API is intentionally similar rather than identical. Some + "Data.MultiSet" operations are omitted, this module provides some + additional operations, and a few concepts are exposed under different + names. + + If you're missing any particular functions from this module, please + file a bug report! + -} + + -- * Types + MultiSet, + MaxUnion (..), + + -- * Construction + empty, + singleton, + singletonMany, + fromMultiplicityList, + fromList, + fromSet, + fromMap, + + -- * Conversion + toMultiplicityList, + toList, + toSet, + toDistinctList, + toMap, + + -- * Query + null, + member, + notMember, + multiplicity, + size, + distinctSize, + + -- * Insertion and deletion + insert, + insertMany, + delete, + deleteMany, + deleteAll, + + -- * Transformations + alterMultiplicity, + alterMultiplicityF, + setMultiplicity, + filter, + filterWithMultiplicity, + filterA, + filterWithMultiplicityA, + partition, + partitionA, + partitionWithMultiplicity, + partitionWithMultiplicityA, + map, + mapWithMultiplicity, + mapMultiplicities, + mapMaybe, + mapMaybeWithMultiplicity, + concatMap, + + -- * Folds + + -- ** Lazy + foldrWithMultiplicity, + foldlWithMultiplicity, + foldMapWithMultiplicity, + + -- ** Strict + foldlWithMultiplicity', + foldrWithMultiplicity', + + -- * Traversals + traverse, + traverseMaybe, + traverseWithMultiplicity, + traverseWithMultiplicity_, + traverseMaybeWithMultiplicity, + + -- * Combining multisets + union, + unions, + difference, + symmetricDifference, + intersection, + intersections, + maxUnion, + cartesianProduct, + + -- * Relations + isSubsetOf, + isProperSubsetOf, + disjoint, + + -- * Ordered queries + lookupLT, + lookupLE, + lookupGT, + lookupGE, + + -- * Minimum and maximum + lookupMin, + lookupMax, + deleteMin, + deleteMax, + deleteMinAll, + deleteMaxAll, + minView, + maxView, + minViewWithMultiplicity, + maxViewWithMultiplicity, + + -- * Splitting + split, +) where + +import Control.Applicative ((<|>)) +import qualified Control.Applicative as A +import Control.DeepSeq (NFData (..)) +import Control.Monad +import Data.Bifunctor +import Data.Bool +import Data.Coerce +import qualified Data.Foldable as F +import Data.List (genericReplicate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Semigroup as SG +import qualified Data.Set as S +import GHC.Natural +import Prelude hiding (concatMap, filter, map, null, traverse) +import qualified Prelude as P + +type Tally a = M.Map a Natural + +{-# INLINE lift #-} +lift :: (Tally a -> Tally b) -> MultiSet a -> MultiSet b +lift = coerce + +{-# INLINE lift2 #-} +lift2 :: (Tally a -> Tally b -> Tally c) -> MultiSet a -> MultiSet b -> MultiSet c +lift2 = coerce + +{-# INLINE with2 #-} +with2 :: (Tally a -> Tally b -> c) -> MultiSet a -> MultiSet b -> c +with2 = coerce + +{- | A finite multiset of type @a@. Each value has a 'Natural' multiplicity, + with multiplicity zero indicating that the value is absent. +-} +newtype MultiSet a = MS {unMS :: Tally a} -- invariant: n > 0 + deriving (Eq, NFData) + +-- | Via 'union'. +instance (Ord a) => SG.Semigroup (MultiSet a) where + (<>) = union + +instance (Ord a) => Monoid (MultiSet a) where + mempty = empty + mappend = (SG.<>) + +{- | Orders multisets as their sorted 'toList' expansions would be ordered, + giving an ordering based on elements rather than the internal representation. +-} +instance (Ord a) => Ord (MultiSet a) where + compare as bs = compareRuns (M.toAscList $ unMS as) (M.toAscList $ unMS bs) + where + compareRuns ((x, n) : xs) ((y, m) : ys) = + compare x y SG.<> case compare n m of + EQ -> compareRuns xs ys + LT -> if P.null xs then LT else GT + GT -> if P.null ys then GT else LT + compareRuns xs ys = compare xs ys + +instance (Show a) => Show (MultiSet a) where + showsPrec d ms = + showParen (d > 10) $ + showString "fromMultiplicityList " + . shows (M.toAscList $ unMS ms) + +instance (Ord a, Read a) => Read (MultiSet a) where + readsPrec d = + readParen (d > 10) $ \s -> do + ("fromMultiplicityList", rest) <- lex s + (xs, rest') <- reads rest + pure (fromMultiplicityList xs, rest') + +-- | Wrapper providing 'SG.Semigroup' and 'Monoid' using 'maxUnion' rather than 'union'. +newtype MaxUnion a = MaxUnion {getMaxUnion :: MultiSet a} + deriving (Eq, Ord, Show, Read, NFData) + +instance (Ord a) => SG.Semigroup (MaxUnion a) where + (<>) = coerce maxUnion + +instance (Ord a) => Monoid (MaxUnion a) where + mempty = coerce empty + mappend = (SG.<>) + +-- | The empty 'MultiSet'. +empty :: MultiSet a +empty = MS M.empty + +-- | The 'MultiSet' containing the given element with multiplicity 1. +singleton :: a -> MultiSet a +singleton = (`singletonMany` 1) + +-- | The 'MultiSet' containing a single element with the given multiplicity. +singletonMany :: a -> Natural -> MultiSet a +singletonMany _ 0 = empty +singletonMany x n = MS $ M.singleton x n + +{- | Construct a 'MultiSet' from a list. + +For any 'Foldable', use @foldMap 'singleton'@. +-} +fromList :: (Ord a) => [a] -> MultiSet a +fromList = MS . M.fromListWith (+) . P.map (,1) + +{- | Construct a 'MultiSet' from a list of pairs of elements and their multiplicity. + +For any 'Foldable', use @foldMap (uncurry 'singletonMany')@. +-} +fromMultiplicityList :: (Ord a) => [(a, Natural)] -> MultiSet a +fromMultiplicityList = MS . M.fromListWith (+) . P.filter ((> 0) . snd) + +-- | Construct a 'MultiSet' from a 'M.Map' of element multiplicities. +fromMap :: M.Map a Natural -> MultiSet a +fromMap = MS . M.filter (> 0) + +-- | Construct a 'MultiSet' from a 'S.Set'. +fromSet :: (Ord a) => S.Set a -> MultiSet a +fromSet = MS . M.fromSet (const 1) + +-- | Insert one occurrence of the given element. +insert :: (Ord a) => a -> MultiSet a -> MultiSet a +insert = (`insertMany` 1) + +-- | Insert many occurrences of the given element. +insertMany :: (Ord a) => a -> Natural -> MultiSet a -> MultiSet a +insertMany _ 0 = id +insertMany x n = lift $ M.insertWith (+) x n + +positive :: Maybe Natural -> Maybe Natural +positive = mfilter (> 0) + +(-?) :: Natural -> Natural -> Maybe Natural +x -? y = positive $ x `minusNaturalMaybe` y + +-- | Delete one occurrence of the given element. +delete :: (Ord a) => a -> MultiSet a -> MultiSet a +delete = (`deleteMany` 1) + +-- | Delete many occurrences of the given element. +deleteMany :: (Ord a) => a -> Natural -> MultiSet a -> MultiSet a +deleteMany _ 0 = id -- not required to maintain invariant +deleteMany x n = lift $ M.update (-? n) x + +-- | Delete all occurrences of the given element. +deleteAll :: (Ord a) => a -> MultiSet a -> MultiSet a +deleteAll x = lift $ M.delete x + +-- | Delete all elements which don't satisfy the given predicate. +filter :: (a -> Bool) -> MultiSet a -> MultiSet a +filter = filterWithMultiplicity . (const .) + +-- | Like 'filter', but the predicate receives the element multiplicity as well. +filterWithMultiplicity :: (a -> Natural -> Bool) -> MultiSet a -> MultiSet a +filterWithMultiplicity = lift . M.filterWithKey + +-- | Like 'filter', but the predicate is effectful. +filterA :: (Applicative f) => (a -> f Bool) -> MultiSet a -> f (MultiSet a) +filterA = filterWithMultiplicityA . (const .) + +-- | Like 'filterA', but the predicate receives the element multiplicity as well. +filterWithMultiplicityA :: + (Applicative f) => (a -> Natural -> f Bool) -> MultiSet a -> f (MultiSet a) +filterWithMultiplicityA p = + fmap MS . M.traverseMaybeWithKey (\x n -> (n <$) . guard <$> p x n) . unMS + +{- | Split a `MultiSet` into a pair of `MultiSet`s, the elements of which do + and do not satisfy the given predicate, respectively. +-} +partition :: (a -> Bool) -> MultiSet a -> (MultiSet a, MultiSet a) +partition = partitionWithMultiplicity . (const .) + +-- | Like 'partition', but the predicate is effectful. +partitionA :: (Applicative f) => (a -> f Bool) -> MultiSet a -> f (MultiSet a, MultiSet a) +partitionA = partitionWithMultiplicityA . (const .) + +-- | Like 'partition', but the predicate receives the element multiplicity as well. +partitionWithMultiplicity :: (a -> Natural -> Bool) -> MultiSet a -> (MultiSet a, MultiSet a) +partitionWithMultiplicity f = bimap MS MS . M.partitionWithKey f . unMS + +-- | Like 'partitionWithMultiplicity', but the predicate is effectful. +partitionWithMultiplicityA :: + (Applicative f) => (a -> Natural -> f Bool) -> MultiSet a -> f (MultiSet a, MultiSet a) +partitionWithMultiplicityA f = + fmap (bimap wrap wrap) . M.foldrWithKey classify (pure ([], [])) . unMS + where + classify x n = A.liftA2 (\b -> bool second first b ((x, n) :)) (f x n) + wrap = MS . M.fromDistinctAscList + +{- | @'map' f s@ is the 'MultiSet' obtained from applying @f@ to each element + of @s@. Multiplicities are added when multiple @a@s map to the same @b@, + and preserved otherwise. +-} +map :: (Ord b) => (a -> b) -> MultiSet a -> MultiSet b +map f = lift $ M.mapKeysWith (+) f + +{- | @'mapWithMultiplicity' f s == + 'fromMultiplicityList' (fmap (uncurry f) ('toMultiplicityList' s))@. + + Multiplicities of equal resulting elements are added, and resulting zero + multiplicities are discarded. +-} +mapWithMultiplicity :: (Ord b) => (a -> Natural -> (b, Natural)) -> MultiSet a -> MultiSet b +mapWithMultiplicity f = foldlWithMultiplicity' (\ms x n -> uncurry insertMany (f x n) ms) empty + +{- | @'mapMultiplicities' f s@ is the 'MultiSet' obtained from applying @f@ to + the multiplicity of each element of @s@. Zero multiplicities are removed. +-} +mapMultiplicities :: (Natural -> Natural) -> MultiSet a -> MultiSet a +mapMultiplicities f = lift $ M.mapMaybe (positive . Just . f) + +-- | Like 'map', but elements can be removed by using 'Nothing' and kept using 'Just'. +mapMaybe :: (Ord b) => (a -> Maybe b) -> MultiSet a -> MultiSet b +mapMaybe f = mapMaybeWithMultiplicity (\x n -> (,n) <$> f x) + +{- | Like 'mapWithMultiplicity', but elements can be removed using 'Nothing' + and kept using 'Just'. +-} +mapMaybeWithMultiplicity :: + (Ord b) => (a -> Natural -> Maybe (b, Natural)) -> MultiSet a -> MultiSet b +mapMaybeWithMultiplicity f = + foldlWithMultiplicity' (\ms x n -> maybe ms (flip (uncurry insertMany) ms) (f x n)) empty + +-- | @'concatMap' f s@ applies @f@ to each element of @s@, and 'unions' the resulting 'MultiSet's. +concatMap :: (Ord b) => (a -> MultiSet b) -> MultiSet a -> MultiSet b +concatMap f = foldlWithMultiplicity' (\ms x n -> union ms $ mapMultiplicities (* n) $ f x) empty + +{- | @'alterMultiplicity' f x s@ sets the multiplicity of @x@ in @s@ to the +result of applying @f@ to its current multiplicity (which might be zero). +-} +alterMultiplicity :: (Ord a) => (Natural -> Natural) -> a -> MultiSet a -> MultiSet a +alterMultiplicity f = lift . M.alter (positive . Just . f . fromMaybe 0) + +-- | Like 'alterMultiplicity', but the update function is effectful. +alterMultiplicityF :: + (Functor f, Ord a) => (Natural -> f Natural) -> a -> MultiSet a -> f (MultiSet a) +alterMultiplicityF f x = fmap MS . M.alterF (fmap (positive . Just) . f . fromMaybe 0) x . unMS + +-- | @'setMultiplicity' x n s@ sets the multiplicity of @x@ in @s@ to @n@. +setMultiplicity :: (Ord a) => a -> Natural -> MultiSet a -> MultiSet a +setMultiplicity x n = alterMultiplicity (const n) x + +{- | Right-associatively fold the elements and their multiplicities of a + 'MultiSet' into a single value. +-} +foldrWithMultiplicity :: (a -> Natural -> r -> r) -> r -> MultiSet a -> r +foldrWithMultiplicity f r = M.foldrWithKey f r . unMS + +-- | Strict version of 'foldrWithMultiplicity'. +foldrWithMultiplicity' :: (a -> Natural -> r -> r) -> r -> MultiSet a -> r +foldrWithMultiplicity' f r = M.foldrWithKey' f r . unMS + +{- | Left-associatively fold the elements and their multiplicities of a + 'MultiSet' into a single value. +-} +foldlWithMultiplicity :: (r -> a -> Natural -> r) -> r -> MultiSet a -> r +foldlWithMultiplicity f r = M.foldlWithKey f r . unMS + +-- | Strict version of 'foldlWithMultiplicity'. +foldlWithMultiplicity' :: (r -> a -> Natural -> r) -> r -> MultiSet a -> r +foldlWithMultiplicity' f r = M.foldlWithKey' f r . unMS + +-- | Fold the elements and their multiplicities of a 'MultiSet' using the given 'Monoid'. +foldMapWithMultiplicity :: (Monoid m) => (a -> Natural -> m) -> MultiSet a -> m +foldMapWithMultiplicity f = M.foldMapWithKey f . unMS + +-- | Like 'traverseWithMultiplicity', but preserves element multiplicities. +traverse :: (Applicative f, Ord b) => (a -> f b) -> MultiSet a -> f (MultiSet b) +traverse f = traverseWithMultiplicity (\x n -> (,n) <$> f x) + +{- | Like 'traverse', but elements can be removed using 'Nothing' and kept +using 'Just'. +-} +traverseMaybe :: (Applicative f, Ord b) => (a -> f (Maybe b)) -> MultiSet a -> f (MultiSet b) +traverseMaybe f = traverseMaybeWithMultiplicity (\x n -> fmap (,n) <$> f x) + +{- | @'traverseWithMultiplicity' f s@ applies the effect @f@ to each distinct +element of @s@ and its multiplicity in increasing order of elements. The +@(element, multiplicity)@ result pairs are used to construct the resulting +'MultiSet'. +-} +traverseWithMultiplicity :: + (Applicative f, Ord b) => (a -> Natural -> f (b, Natural)) -> MultiSet a -> f (MultiSet b) +traverseWithMultiplicity f = traverseMaybeWithMultiplicity ((fmap Just .) . f) + +{- | Like 'traverseWithMultiplicity', but elements can be removed using +'Nothing' and kept using 'Just'. +-} +traverseMaybeWithMultiplicity :: + (Applicative f, Ord b) => + (a -> Natural -> f (Maybe (b, Natural))) -> + MultiSet a -> + f (MultiSet b) +traverseMaybeWithMultiplicity f = + foldrWithMultiplicity (\x n -> A.liftA2 (maybe id (uncurry insertMany)) (f x n)) (pure empty) + +{- | Like 'traverseWithMultiplicity', but discards the results of the effect +and doesn't build a resulting 'MultiSet'. +-} +traverseWithMultiplicity_ :: (Applicative f) => (a -> Natural -> f b) -> MultiSet a -> f () +traverseWithMultiplicity_ f = foldrWithMultiplicity (\x n rest -> f x n *> rest) (pure ()) + +-- | Convert to a 'M.Map' from element to its multiplicity. +toMap :: MultiSet a -> M.Map a Natural +toMap = unMS + +-- | Convert to a list of @(element, multiplicity)@ pairs. +toMultiplicityList :: MultiSet a -> [(a, Natural)] +toMultiplicityList = M.toAscList . unMS + +-- | The set of distinct elements. +toSet :: MultiSet a -> S.Set a +toSet = M.keysSet . unMS + +-- | The list of distinct elements. +toDistinctList :: MultiSet a -> [a] +toDistinctList = M.keys . unMS + +-- | Convert to an ascending list, repeating each element according to its multiplicity. +toList :: MultiSet a -> [a] +toList = foldrWithMultiplicity (\x n -> (++) $ genericReplicate n x) [] + +-- | Is the 'MultiSet' empty? +null :: MultiSet a -> Bool +null = M.null . unMS + +-- | Is the value a member of the 'MultiSet'? +member :: (Ord a) => a -> MultiSet a -> Bool +member x = M.member x . unMS + +-- | Is the value not a member of the 'MultiSet'? +notMember :: (Ord a) => a -> MultiSet a -> Bool +notMember x = M.notMember x . unMS + +-- | How many times is the element contained in the 'MultiSet'? +multiplicity :: (Ord a) => a -> MultiSet a -> Natural +multiplicity x = M.findWithDefault 0 x . unMS + +-- | How many elements are in the 'MultiSet'? This is the sum of multiplicities. +size :: MultiSet a -> Natural +size = M.foldl' (+) 0 . unMS + +-- | How many distinct elements are in the 'MultiSet'? +distinctSize :: MultiSet a -> Int +distinctSize = M.size . unMS + +-- | The union two 'MultiSet's, adding multiplicities for elements present in both. +union :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a +union = lift2 $ M.unionWith (+) + +{- | The union of a list of 'MultiSet's. + +For any 'Foldable', use @foldMap id@. +-} +unions :: (Ord a) => [MultiSet a] -> MultiSet a +unions = MS . M.unionsWith (+) . P.map unMS + +-- | The difference of two 'MultiSet's. +difference :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a +difference = lift2 $ M.differenceWith (-?) + +{- | The symmetric difference of two 'MultiSet's, taking the absolute difference + of multiplicities for elements present in both. +-} +symmetricDifference :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a +symmetricDifference = lift2 $ M.mergeWithKey (\_ m n -> m -? n <|> n -? m) id id + +-- | The intersection of two 'MultiSet's. +intersection :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a +intersection = lift2 $ M.intersectionWith min + +-- | The intersection of a series of 'MultiSet's. +intersections :: (Ord a) => NonEmpty (MultiSet a) -> MultiSet a +intersections (x :| xs) = F.foldl' intersection x xs + +-- | The union of two 'MultiSet's, taking the maximum multiplicity of each element. +maxUnion :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a +maxUnion = lift2 $ M.unionWith max + +{- | The cartesian product of two 'MultiSet's. Each pair @(x, y)@ appears with + multiplicity equal to the multiplicity of @x@ in the first 'MultiSet' + multiplied by the multiplicity of @y@ in the second. +-} +cartesianProduct :: (Ord a, Ord b) => MultiSet a -> MultiSet b -> MultiSet (a, b) +cartesianProduct xs = concatMap (\y -> map (,y) xs) + +-- | Is the first 'MultiSet' contained in the second, respecting multiplicities? +isSubsetOf :: (Ord a) => MultiSet a -> MultiSet a -> Bool +isSubsetOf = with2 $ M.isSubmapOfBy (<=) + +-- | Like 'isSubsetOf', but 'False' if the two 'MultiSet's are equal. +isProperSubsetOf :: (Ord a) => MultiSet a -> MultiSet a -> Bool +isProperSubsetOf x y = x /= y && isSubsetOf x y + +-- | Do the two 'MultiSet's have no common elements? +disjoint :: (Ord a) => MultiSet a -> MultiSet a -> Bool +disjoint = with2 M.disjoint + +{- | Find the largest element smaller than the given one and return the + corresponding @(element, multiplicity)@ pair. +-} +lookupLT :: (Ord a) => a -> MultiSet a -> Maybe (a, Natural) +lookupLT x = M.lookupLT x . unMS + +{- | Find the largest element smaller than or equal to the given one and return + the corresponding @(element, multiplicity)@ pair. +-} +lookupLE :: (Ord a) => a -> MultiSet a -> Maybe (a, Natural) +lookupLE x = M.lookupLE x . unMS + +{- | Find the smallest element greater than the given one and return the + corresponding @(element, multiplicity)@ pair. +-} +lookupGT :: (Ord a) => a -> MultiSet a -> Maybe (a, Natural) +lookupGT x = M.lookupGT x . unMS + +{- | Find the smallest element greater than or equal to the given one and + return the corresponding @(element, multiplicity)@ pair. +-} +lookupGE :: (Ord a) => a -> MultiSet a -> Maybe (a, Natural) +lookupGE x = M.lookupGE x . unMS + +-- | Find the smallest element of the 'MultiSet' and its multiplicity. +lookupMin :: MultiSet a -> Maybe (a, Natural) +lookupMin = M.lookupMin . unMS + +-- | Find the largest element of the 'MultiSet' and its multiplicity. +lookupMax :: MultiSet a -> Maybe (a, Natural) +lookupMax = M.lookupMax . unMS + +-- | Remove one occurrence of the smallest element of the 'MultiSet'. +deleteMin :: MultiSet a -> MultiSet a +deleteMin = lift $ M.updateMin (-? 1) + +-- | Remove one occurrence of the largest element of the 'MultiSet'. +deleteMax :: MultiSet a -> MultiSet a +deleteMax = lift $ M.updateMax (-? 1) + +-- | Remove all occurrences of the smallest element of the 'MultiSet'. +deleteMinAll :: MultiSet a -> MultiSet a +deleteMinAll = lift M.deleteMin + +-- | Remove all occurrences of the largest element of the 'MultiSet'. +deleteMaxAll :: MultiSet a -> MultiSet a +deleteMaxAll = lift M.deleteMax + +-- two traversals for both of these, but maybe we don't care for now? + +{- | Return the least element and the remaining 'MultiSet' with one occurrence + removed, or 'Nothing' if empty. +-} +minView :: (Ord a) => MultiSet a -> Maybe (a, MultiSet a) +minView ms = do + ((x, n), xs) <- M.minViewWithKey $ unMS ms + pure (x, insertMany x (n - 1) $ MS xs) + +{- | Return the greatest element and the remaining 'MultiSet' with one + occurrence removed, or 'Nothing' if empty. +-} +maxView :: (Ord a) => MultiSet a -> Maybe (a, MultiSet a) +maxView ms = do + ((x, n), xs) <- M.maxViewWithKey $ unMS ms + pure (x, insertMany x (n - 1) $ MS xs) + +{- | Return the least element with its multiplicity, and the remaining + 'MultiSet', or 'Nothing' if empty. +-} +minViewWithMultiplicity :: MultiSet a -> Maybe ((a, Natural), MultiSet a) +minViewWithMultiplicity = fmap (second MS) . M.minViewWithKey . unMS + +{- | Return the greatest element with its multiplicity, and the remaining + 'MultiSet', or 'Nothing' if empty. +-} +maxViewWithMultiplicity :: MultiSet a -> Maybe ((a, Natural), MultiSet a) +maxViewWithMultiplicity = fmap (second MS) . M.maxViewWithKey . unMS + +{- | @'split' x s@ produces the tuple @(sl, nx, sg)@, where @nx@ is the + multiplicity of @x@ in @s@, and @sl@ and @sg@ are 'MultiSet's containing + the elements of @s@ which are less than and greater than @x@, respectively. + + @x@ is not required to be a 'member' of @s@, and @nx@ will be zero if it + isn't. +-} +split :: (Ord a) => a -> MultiSet a -> (MultiSet a, Natural, MultiSet a) +split x = ret . M.splitLookup x . unMS + where + ret (ls, m, rs) = (MS ls, fromMaybe 0 m, MS rs) + +-- TODO: +-- - mapMonotonic and other unsafe functions? +-- - Intersection wrapper with Semigroup instance? diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeApplications #-} + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Test.Gen + +import qualified Test.Combining +import qualified Test.Effects +import qualified Test.Extremes +import qualified Test.Folds +import qualified Test.Instances +import qualified Test.Queries +import qualified Test.ToFrom +import qualified Test.Transformations +import qualified Test.Updates +import qualified Test.Valid + +main :: IO () +main = + defaultMain $ + testGroup + "Data.MultiSet.Natural" + [ testProperty "LNat large" prop_lnatLarge + , Test.Valid.tests + , Test.ToFrom.tests + , Test.Queries.tests + , Test.Instances.tests + , Test.Effects.tests + , Test.Folds.tests + , Test.Transformations.tests + , Test.Updates.tests + , Test.Combining.tests + , Test.Extremes.tests + ] + +prop_lnatLarge :: LNat -> Property +prop_lnatLarge (LNat n) = checkCoverage $ cover 20 big "> max Int" True + where + big = n > fromIntegral (maxBound @Int) diff --git a/test/Test/Combining.hs b/test/Test/Combining.hs new file mode 100644 --- /dev/null +++ b/test/Test/Combining.hs @@ -0,0 +1,191 @@ +module Test.Combining ( + tests, +) where + +import Data.Foldable +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "combining" + [ testProperty "union/empty" prop_unionEmpty + , testProperty "union/commutative" prop_unionCommutative + , testProperty "union/associative" prop_unionAssociative + , testProperty "union/multiplicity" prop_unionMultiplicity + , testProperty "union/size" prop_unionSize + , testProperty "unions/fold" prop_unionsFold + , testProperty "difference/empty" prop_differenceEmpty + , testProperty "difference/self" prop_differenceSelf + , testProperty "difference/subset" prop_differenceSubset + , testProperty "difference/multiplicity" prop_differenceMultiplicity + , testProperty "difference/undo union" prop_differenceUndoUnion + , testProperty "symmetricDifference/empty" prop_symmetricDifferenceEmpty + , testProperty "symmetricDifference/self" prop_symmetricDifferenceSelf + , testProperty "symmetricDifference/commutative" prop_symmetricDifferenceCommutative + , testProperty "symmetricDifference/multiplicity" prop_symmetricDifferenceMultiplicity + , testProperty "symmetricDifference/differences" prop_symmetricDifferenceDifferences + , testProperty "intersection/self" prop_intersectionSelf + , testProperty "intersection/commutative" prop_intersectionCommutative + , testProperty "intersection/associative" prop_intersectionAssociative + , testProperty "intersection/subsets" prop_intersectionSubsets + , testProperty "intersection/multiplicity" prop_intersectionMultiplicity + , testProperty "intersections/multiplicity" prop_intersectionsMultiplicity + , testProperty "intersections/subsets" prop_intersectionsSubsets + , testProperty "maxUnion/empty" prop_maxUnionEmpty + , testProperty "maxUnion/self" prop_maxUnionSelf + , testProperty "maxUnion/commutative" prop_maxUnionCommutative + , testProperty "maxUnion/associative" prop_maxUnionAssociative + , testProperty "maxUnion/multiplicity" prop_maxUnionMultiplicity + , testProperty "cartesianProduct/empty left" prop_cartesianProductEmptyLeft + , testProperty "cartesianProduct/empty right" prop_cartesianProductEmptyRight + , testProperty "cartesianProduct/multiplicity" prop_cartesianProductMultiplicity + , testProperty "cartesianProduct/size" prop_cartesianProductSize + , testProperty "cartesianProduct/distinctSize" prop_cartesianProductDistinctSize + , testProperty "difference+intersection decomposition" prop_differenceIntersectionDecomposition + ] + +prop_unionEmpty :: AMS -> Property +prop_unionEmpty (AMS xs) = conjoin [MS.union MS.empty xs === xs, MS.union xs MS.empty === xs] + +prop_unionCommutative :: AMS -> AMS -> Property +prop_unionCommutative (AMS xs) (AMS ys) = MS.union xs ys === MS.union ys xs + +prop_unionAssociative :: AMS -> AMS -> AMS -> Property +prop_unionAssociative (AMS xs) (AMS ys) (AMS zs) = + MS.union xs (MS.union ys zs) === MS.union (MS.union xs ys) zs + +prop_unionMultiplicity :: AMSWithKey2 -> Property +prop_unionMultiplicity (AMSWithKey2 x xs ys) = + MS.multiplicity x (MS.union xs ys) === MS.multiplicity x xs + MS.multiplicity x ys + +prop_unionSize :: AMS -> AMS -> Property +prop_unionSize (AMS xs) (AMS ys) = MS.size (MS.union xs ys) === MS.size xs + MS.size ys + +prop_unionsFold :: [AMS] -> Property +prop_unionsFold xss = MS.unions xs === foldr MS.union MS.empty xs + where + xs = getAMS <$> xss + +prop_differenceEmpty :: AMS -> Property +prop_differenceEmpty (AMS xs) = MS.difference xs MS.empty === xs + +prop_differenceSelf :: AMS -> Property +prop_differenceSelf (AMS xs) = MS.difference xs xs === MS.empty + +prop_differenceSubset :: AMS -> AMS -> Property +prop_differenceSubset (AMS xs) (AMS ys) = property $ MS.difference xs ys `MS.isSubsetOf` xs + +prop_differenceMultiplicity :: AMSWithKey2 -> Property +prop_differenceMultiplicity (AMSWithKey2 x xs ys) = + MS.multiplicity x (MS.difference xs ys) === MS.multiplicity x xs `monus` MS.multiplicity x ys + +prop_differenceUndoUnion :: AMS -> AMS -> Property +prop_differenceUndoUnion (AMS xs) (AMS ys) = MS.difference (MS.union xs ys) ys === xs + +prop_symmetricDifferenceEmpty :: AMS -> Property +prop_symmetricDifferenceEmpty (AMS xs) = + conjoin [MS.symmetricDifference xs MS.empty === xs, MS.symmetricDifference MS.empty xs === xs] + +prop_symmetricDifferenceSelf :: AMS -> Property +prop_symmetricDifferenceSelf (AMS xs) = MS.symmetricDifference xs xs === MS.empty + +prop_symmetricDifferenceCommutative :: AMS -> AMS -> Property +prop_symmetricDifferenceCommutative (AMS xs) (AMS ys) = + MS.symmetricDifference xs ys === MS.symmetricDifference ys xs + +prop_symmetricDifferenceMultiplicity :: AMSWithKey2 -> Property +prop_symmetricDifferenceMultiplicity (AMSWithKey2 x xs ys) = + MS.multiplicity x (MS.symmetricDifference xs ys) + === distance (MS.multiplicity x xs) (MS.multiplicity x ys) + +prop_symmetricDifferenceDifferences :: AMS -> AMS -> Property +prop_symmetricDifferenceDifferences (AMS xs) (AMS ys) = + MS.symmetricDifference xs ys === MS.union (MS.difference xs ys) (MS.difference ys xs) + +prop_intersectionSelf :: AMS -> Property +prop_intersectionSelf (AMS xs) = MS.intersection xs xs === xs + +prop_intersectionCommutative :: AMS -> AMS -> Property +prop_intersectionCommutative (AMS xs) (AMS ys) = MS.intersection xs ys === MS.intersection ys xs + +prop_intersectionAssociative :: AMS -> AMS -> AMS -> Property +prop_intersectionAssociative (AMS xs) (AMS ys) (AMS zs) = + MS.intersection xs (MS.intersection ys zs) === MS.intersection (MS.intersection xs ys) zs + +prop_intersectionSubsets :: AMS -> AMS -> Property +prop_intersectionSubsets (AMS xs) (AMS ys) = + conjoin + [ property $ MS.intersection xs ys `MS.isSubsetOf` xs + , property $ MS.intersection xs ys `MS.isSubsetOf` ys + ] + +prop_intersectionMultiplicity :: AMSWithKey2 -> Property +prop_intersectionMultiplicity (AMSWithKey2 x xs ys) = + MS.multiplicity x (MS.intersection xs ys) + === min (MS.multiplicity x xs) (MS.multiplicity x ys) + +prop_intersectionsMultiplicity :: AMSsWithKey -> Property +prop_intersectionsMultiplicity (AMSsWithKey x xss) = + MS.multiplicity x (MS.intersections xss) === minimum (MS.multiplicity x <$> xss) + +prop_intersectionsSubsets :: AMSsWithKey -> Property +prop_intersectionsSubsets (AMSsWithKey _ xss) = + conjoin $ (res `MS.isSubsetOf`) <$> toList xss + where + res = MS.intersections xss + +prop_maxUnionEmpty :: AMS -> Property +prop_maxUnionEmpty (AMS xs) = + conjoin [MS.maxUnion MS.empty xs === xs, MS.maxUnion xs MS.empty === xs] + +prop_maxUnionSelf :: AMS -> Property +prop_maxUnionSelf (AMS xs) = MS.maxUnion xs xs === xs + +prop_maxUnionCommutative :: AMS -> AMS -> Property +prop_maxUnionCommutative (AMS xs) (AMS ys) = MS.maxUnion xs ys === MS.maxUnion ys xs + +prop_maxUnionAssociative :: AMS -> AMS -> AMS -> Property +prop_maxUnionAssociative (AMS xs) (AMS ys) (AMS zs) = + MS.maxUnion xs (MS.maxUnion ys zs) === MS.maxUnion (MS.maxUnion xs ys) zs + +prop_maxUnionMultiplicity :: AMSWithKey2 -> Property +prop_maxUnionMultiplicity (AMSWithKey2 x xs ys) = + MS.multiplicity x (MS.maxUnion xs ys) === max (MS.multiplicity x xs) (MS.multiplicity x ys) + +prop_cartesianProductEmptyLeft :: AMS -> Property +prop_cartesianProductEmptyLeft (AMS ys) = + MS.cartesianProduct (MS.empty :: MS.MultiSet Int) ys === MS.empty + +prop_cartesianProductEmptyRight :: AMS -> Property +prop_cartesianProductEmptyRight (AMS xs) = + MS.cartesianProduct xs (MS.empty :: MS.MultiSet Int) === MS.empty + +prop_cartesianProductMultiplicity :: AMSWithKey -> AMSWithKey -> Property +prop_cartesianProductMultiplicity (AMSWithKey x xs) (AMSWithKey y ys) = + MS.multiplicity (x, y) (MS.cartesianProduct xs ys) + === MS.multiplicity x xs * MS.multiplicity y ys + +prop_cartesianProductSize :: AMS -> AMS -> Property +prop_cartesianProductSize (AMS xs) (AMS ys) = + MS.size (MS.cartesianProduct xs ys) === MS.size xs * MS.size ys + +prop_cartesianProductDistinctSize :: AMS -> AMS -> Property +prop_cartesianProductDistinctSize (AMS xs) (AMS ys) = + MS.distinctSize (MS.cartesianProduct xs ys) === MS.distinctSize xs * MS.distinctSize ys + +prop_differenceIntersectionDecomposition :: AMS -> AMS -> Property +prop_differenceIntersectionDecomposition (AMS xs) (AMS ys) = + MS.union (MS.difference xs ys) (MS.intersection xs ys) === xs + +monus :: Natural -> Natural -> Natural +monus x y + | x >= y = x - y + | otherwise = 0 + +distance :: Natural -> Natural -> Natural +distance x y = monus x y + monus y x diff --git a/test/Test/Effects.hs b/test/Test/Effects.hs new file mode 100644 --- /dev/null +++ b/test/Test/Effects.hs @@ -0,0 +1,97 @@ +module Test.Effects ( + tests, +) where + +import Data.Coerce +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "effects" + [ testProperty "filterA" prop_filterA + , testProperty "filterWithMultiplicityA" prop_filterWithMultiplicityA + , testProperty "partitionA" prop_partitionA + , testProperty "partitionWithMultiplicityA" prop_partitionWithMultiplicityA + , testProperty "traverse" prop_traverse + , testProperty "traverseMaybe" prop_traverseMaybe + , testProperty "traverseWithMultiplicity" prop_traverseWithMultiplicity + , testProperty "traverseMaybeWithMultiplicity" prop_traverseMaybeWithMultiplicity + , testProperty "traverseWithMultiplicity_" prop_traverseWithMultiplicity_ + , testProperty "alterMultiplicityF" prop_alterMultiplicityF + ] + +prop_filterA :: Fun Int Bool -> AMS -> Property +prop_filterA fun (AMS xs) = + conjoin [seen === MS.toDistinctList xs, ys === MS.filter f xs] + where + f = applyFun fun + (seen, ys) = MS.filterA (\x -> ([x], f x)) xs + +prop_filterWithMultiplicityA :: Fun (Int, Natural') Bool -> AMS -> Property +prop_filterWithMultiplicityA fun (AMS xs) = + conjoin [seen === MS.toMultiplicityList xs, ys === MS.filterWithMultiplicity (curry f) xs] + where + f = coerce $ applyFun fun + (seen, ys) = MS.filterWithMultiplicityA (\x n -> ([(x, n)], f (x, n))) xs + +prop_partitionA :: Fun Int Bool -> AMS -> Property +prop_partitionA fun (AMS xs) = + conjoin [seen === MS.toDistinctList xs, ys === MS.partition f xs] + where + f = applyFun fun + (seen, ys) = MS.partitionA (\x -> ([x], f x)) xs + +prop_partitionWithMultiplicityA :: Fun (Int, Natural') Bool -> AMS -> Property +prop_partitionWithMultiplicityA fun (AMS xs) = + conjoin [seen === MS.toMultiplicityList xs, ys === MS.partitionWithMultiplicity (curry f) xs] + where + f = coerce $ applyFun fun + (seen, ys) = MS.partitionWithMultiplicityA (\x n -> ([(x, n)], f (x, n))) xs + +prop_traverse :: Fun Int Int -> AMS -> Property +prop_traverse fun (AMS xs) = + conjoin [seen === MS.toDistinctList xs, ys === MS.map f xs] + where + f = applyFun fun + (seen, ys) = MS.traverse (\x -> ([x], f x)) xs + +prop_traverseMaybe :: Fun Int (Maybe Int) -> AMS -> Property +prop_traverseMaybe fun (AMS xs) = + conjoin [seen === MS.toDistinctList xs, ys === MS.mapMaybe f xs] + where + f = applyFun fun + (seen, ys) = MS.traverseMaybe (\x -> ([x], f x)) xs + +prop_traverseWithMultiplicity :: Fun (Int, Natural') (Int, Natural') -> AMS -> Property +prop_traverseWithMultiplicity fun (AMS xs) = + conjoin [seen === MS.toMultiplicityList xs, ys === MS.mapWithMultiplicity (curry f) xs] + where + f :: (Int, Natural) -> (Int, Natural) + f = coerce $ applyFun fun + (seen, ys) = MS.traverseWithMultiplicity (\x n -> ([(x, n)], f (x, n))) xs + +prop_traverseMaybeWithMultiplicity :: Fun (Int, Natural') (Maybe (Int, Natural')) -> AMS -> Property +prop_traverseMaybeWithMultiplicity fun (AMS xs) = + conjoin [seen === MS.toMultiplicityList xs, ys === MS.mapMaybeWithMultiplicity (curry f) xs] + where + f :: (Int, Natural) -> Maybe (Int, Natural) + f = coerce $ applyFun fun + (seen, ys) = MS.traverseMaybeWithMultiplicity (\x n -> ([(x, n)], f (x, n))) xs + +prop_traverseWithMultiplicity_ :: AMS -> Property +prop_traverseWithMultiplicity_ (AMS xs) = + conjoin [seen === MS.toMultiplicityList xs, y === ()] + where + (seen, y) = MS.traverseWithMultiplicity_ (\x n -> ([(x, n)], ())) xs + +prop_alterMultiplicityF :: Fun Natural' Natural' -> AMSWithKey -> Property +prop_alterMultiplicityF fun (AMSWithKey x xs) = + conjoin [seen === [MS.multiplicity x xs], ys === MS.alterMultiplicity f x xs] + where + f = coerce $ applyFun fun + (seen, ys) = MS.alterMultiplicityF (\n -> ([n], f n)) x xs diff --git a/test/Test/Extremes.hs b/test/Test/Extremes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extremes.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TupleSections #-} + +module Test.Extremes ( + tests, +) where + +import qualified Data.MultiSet.Natural as MS +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "extremes" + [ testProperty "deleteMin/delete" prop_deleteMinDelete + , testProperty "deleteMax/delete" prop_deleteMaxDelete + , testProperty "deleteMinAll/deleteAll" prop_deleteMinAllDeleteAll + , testProperty "deleteMaxAll/deleteAll" prop_deleteMaxAllDeleteAll + , testProperty "minView/lookupMin + deleteMin" prop_minView + , testProperty "maxView/lookupMax + deleteMax" prop_maxView + , testProperty "minViewWithMultiplicity/lookupMin + deleteMinAll" prop_minViewWithMultiplicity + , testProperty "maxViewWithMultiplicity/lookupMax + deleteMaxAll" prop_maxViewWithMultiplicity + , testProperty "split/multiplicity" prop_splitMultiplicity + , testProperty "split/bounds" prop_splitBounds + , testProperty "split/reconstruct" prop_splitReconstruct + ] + +prop_deleteMinDelete :: AMS -> Property +prop_deleteMinDelete (AMS xs) = + MS.deleteMin xs === maybe xs (\(x, _) -> MS.delete x xs) (MS.lookupMin xs) + +prop_deleteMaxDelete :: AMS -> Property +prop_deleteMaxDelete (AMS xs) = + MS.deleteMax xs === maybe xs (\(x, _) -> MS.delete x xs) (MS.lookupMax xs) + +prop_deleteMinAllDeleteAll :: AMS -> Property +prop_deleteMinAllDeleteAll (AMS xs) = + MS.deleteMinAll xs === maybe xs (\(x, _) -> MS.deleteAll x xs) (MS.lookupMin xs) + +prop_deleteMaxAllDeleteAll :: AMS -> Property +prop_deleteMaxAllDeleteAll (AMS xs) = + MS.deleteMaxAll xs === maybe xs (\(x, _) -> MS.deleteAll x xs) (MS.lookupMax xs) + +prop_minView :: AMS -> Property +prop_minView (AMS xs) = MS.minView xs === fmap (\(x, _) -> (x, MS.deleteMin xs)) (MS.lookupMin xs) + +prop_maxView :: AMS -> Property +prop_maxView (AMS xs) = MS.maxView xs === fmap (\(x, _) -> (x, MS.deleteMax xs)) (MS.lookupMax xs) + +prop_minViewWithMultiplicity :: AMS -> Property +prop_minViewWithMultiplicity (AMS xs) = + MS.minViewWithMultiplicity xs === fmap (,MS.deleteMinAll xs) (MS.lookupMin xs) + +prop_maxViewWithMultiplicity :: AMS -> Property +prop_maxViewWithMultiplicity (AMS xs) = + MS.maxViewWithMultiplicity xs === fmap (,MS.deleteMaxAll xs) (MS.lookupMax xs) + +prop_splitMultiplicity :: AMSWithKey -> Property +prop_splitMultiplicity (AMSWithKey x xs) = n === MS.multiplicity x xs + where + (_, n, _) = MS.split x xs + +prop_splitBounds :: AMSWithKey -> Property +prop_splitBounds (AMSWithKey x xs) = + conjoin + [ property $ all (< x) $ MS.toDistinctList lt + , property $ all (> x) $ MS.toDistinctList gt + ] + where + (lt, _, gt) = MS.split x xs + +prop_splitReconstruct :: AMSWithKey -> Property +prop_splitReconstruct (AMSWithKey x xs) = MS.union lt (MS.insertMany x n gt) === xs + where + (lt, n, gt) = MS.split x xs diff --git a/test/Test/Folds.hs b/test/Test/Folds.hs new file mode 100644 --- /dev/null +++ b/test/Test/Folds.hs @@ -0,0 +1,101 @@ +module Test.Folds ( + tests, +) where + +import Data.Coerce +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "folds" + [ testProperty "foldrWithMultiplicity/reconstruct" prop_foldrReconstruct + , testProperty "foldrWithMultiplicity/reference" prop_foldrReference + , testProperty "foldrWithMultiplicity'/reconstruct" prop_foldrStrictReconstruct + , testProperty "foldrWithMultiplicity'/reference" prop_foldrStrictReference + , testProperty "foldlWithMultiplicity/reconstruct" prop_foldlReconstruct + , testProperty "foldlWithMultiplicity/reference" prop_foldlReference + , testProperty "foldlWithMultiplicity'/reconstruct" prop_foldlStrictReconstruct + , testProperty "foldlWithMultiplicity'/reference" prop_foldlStrictReference + , testProperty "foldMapWithMultiplicity/reconstruct" prop_foldMapReconstruct + , testProperty "foldMapWithMultiplicity/reference" prop_foldMapReference + , testProperty "foldrWithMultiplicity'/agrees with lazy" prop_foldrStrictAgrees + , testProperty "foldlWithMultiplicity'/agrees with lazy" prop_foldlStrictAgrees + ] + +prop_foldrReconstruct :: AMS -> Property +prop_foldrReconstruct (AMS xs) = + MS.foldrWithMultiplicity (\x n -> ((x, n) :)) [] xs === MS.toMultiplicityList xs + +prop_foldrReference :: Fun (Int, Natural', Int) Int -> Int -> AMS -> Property +prop_foldrReference fun z (AMS xs) = + MS.foldrWithMultiplicity f z xs === foldr (\(x, n) acc -> f x n acc) z (MS.toMultiplicityList xs) + where + f :: Int -> Natural -> Int -> Int + f x n acc = (coerce . applyFun) fun (x, n, acc) + +prop_foldrStrictReconstruct :: AMS -> Property +prop_foldrStrictReconstruct (AMS xs) = + MS.foldrWithMultiplicity' (\x n -> ((x, n) :)) [] xs === MS.toMultiplicityList xs + +prop_foldrStrictReference :: Fun (Int, Natural', Int) Int -> Int -> AMS -> Property +prop_foldrStrictReference fun z (AMS xs) = + MS.foldrWithMultiplicity' f z xs + === F.foldr' (\(x, n) acc -> f x n acc) z (MS.toMultiplicityList xs) + where + f :: Int -> Natural -> Int -> Int + f x n acc = (coerce . applyFun) fun (x, n, acc) + +prop_foldlReconstruct :: AMS -> Property +prop_foldlReconstruct (AMS xs) = + reverse (MS.foldlWithMultiplicity (\acc x n -> (x, n) : acc) [] xs) === MS.toMultiplicityList xs + +prop_foldlReference :: Fun (Int, Int, Natural') Int -> Int -> AMS -> Property +prop_foldlReference fun z (AMS xs) = + MS.foldlWithMultiplicity f z xs === foldl (\acc (x, n) -> f acc x n) z (MS.toMultiplicityList xs) + where + f :: Int -> Int -> Natural -> Int + f acc x n = (coerce . applyFun) fun (acc, x, n) + +prop_foldlStrictReconstruct :: AMS -> Property +prop_foldlStrictReconstruct (AMS xs) = + reverse (MS.foldlWithMultiplicity' (\acc x n -> (x, n) : acc) [] xs) === MS.toMultiplicityList xs + +prop_foldlStrictReference :: Fun (Int, Int, Natural') Int -> Int -> AMS -> Property +prop_foldlStrictReference fun z (AMS xs) = + MS.foldlWithMultiplicity' f z xs + === L.foldl' (\acc (x, n) -> f acc x n) z (MS.toMultiplicityList xs) + where + f :: Int -> Int -> Natural -> Int + f acc x n = (coerce . applyFun) fun (acc, x, n) + +prop_foldMapReconstruct :: AMS -> Property +prop_foldMapReconstruct (AMS xs) = + MS.foldMapWithMultiplicity (\x n -> [(x, n)]) xs === MS.toMultiplicityList xs + +prop_foldMapReference :: Fun (Int, Natural') [Int] -> AMS -> Property +prop_foldMapReference fun (AMS xs) = + MS.foldMapWithMultiplicity (curry f) xs === foldMap f (MS.toMultiplicityList xs) + where + f :: (Int, Natural) -> [Int] + f = coerce $ applyFun fun + +prop_foldrStrictAgrees :: Fun (Int, Natural', Int) Int -> Int -> AMS -> Property +prop_foldrStrictAgrees fun z (AMS xs) = + MS.foldrWithMultiplicity' f z xs === MS.foldrWithMultiplicity f z xs + where + f :: Int -> Natural -> Int -> Int + f x n acc = (coerce . applyFun) fun (x, n, acc) + +prop_foldlStrictAgrees :: Fun (Int, Int, Natural') Int -> Int -> AMS -> Property +prop_foldlStrictAgrees fun z (AMS xs) = + MS.foldlWithMultiplicity' f z xs === MS.foldlWithMultiplicity f z xs + where + f :: Int -> Int -> Natural -> Int + f acc x n = (coerce . applyFun) fun (acc, x, n) diff --git a/test/Test/Gen.hs b/test/Test/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Gen.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} + +module Test.Gen ( + LNat (..), + AMSOf (..), + AMS, + AMSWithKey (..), + AMSWithKey2 (..), + AMSsWithKey (..), + Natural' (..), +) where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.QuickCheck + +newtype LNat = LNat {getLNat :: Natural} + deriving (Eq, Ord, Show) + +instance Arbitrary LNat where + arbitrary = LNat <$> sized genNatural + where + genNatural s = do + bits <- choose (0, 2 * s) + fromInteger <$> choose (0, 2 ^ bits - 1) + shrink (LNat n) = LNat <$> shrinkIntegral n + +newtype AMSOf a = AMS {getAMS :: MS.MultiSet a} + deriving (Eq, Show) + +instance (Ord a, Arbitrary a) => Arbitrary (AMSOf a) where + arbitrary = + AMS . MS.fromMultiplicityList + <$> listOf ((,) <$> arbitrary <*> (succ . getLNat <$> arbitrary)) + shrink (AMS ms) = AMS . MS.fromMultiplicityList <$> shrinkList f (MS.toMultiplicityList ms) + where + f (x, n) = map (,n) (shrink x) ++ map (x,) (filter (> 0) $ shrinkIntegral n) + +type AMS = AMSOf Int + +data AMSWithKey = AMSWithKey Int (MS.MultiSet Int) + deriving (Eq, Show) + +instance Arbitrary AMSWithKey where + arbitrary = arbitrary >>= \(AMS xs) -> (`AMSWithKey` xs) <$> keyFor xs + where + keyFor xs + | MS.null xs = arbitrary + | otherwise = + oneof + [ arbitrary `suchThat` (`MS.notMember` xs) + , elements (MS.toDistinctList xs) + ] + shrink (AMSWithKey x xs) = + [AMSWithKey x xs' | AMS xs' <- shrink (AMS xs), MS.member x xs' == present] + where + present = x `MS.member` xs + +data AMSWithKey2 = AMSWithKey2 Int (MS.MultiSet Int) (MS.MultiSet Int) + deriving (Eq, Show) + +instance Arbitrary AMSWithKey2 where + arbitrary = do + (x, AMS xs, AMS ys) <- arbitrary + (n, d) <- (,) <$> pos <*> pos + (nx, ny) <- elements [(0, 0), (n, 0), (0, n), (n, n + d), (n, n), (n + d, n)] + pure $ AMSWithKey2 x (MS.setMultiplicity x nx xs) (MS.setMultiplicity x ny ys) + where + pos = succ . getLNat <$> arbitrary + shrink (AMSWithKey2 x xs ys) = + [ AMSWithKey2 x xs' ys' + | (AMS xs', AMS ys') <- shrink (AMS xs, AMS ys) + , keyClass xs' ys' == keyClass xs ys + ] + where + keyClass as bs = (na == 0, nb == 0, compare na nb) + where + (na, nb) = (MS.multiplicity x as, MS.multiplicity x bs) + +data AMSsWithKey = AMSsWithKey Int (NonEmpty (MS.MultiSet Int)) + deriving (Show) + +instance Arbitrary AMSsWithKey where + arbitrary = do + x <- arbitrary + xss <- (:|) <$> arbitrary <*> listOf1 arbitrary + AMSsWithKey x <$> traverse (withKey x) xss + where + withKey x (AMS xs) = do + n <- succ . getLNat <$> arbitrary + pure $ MS.setMultiplicity x n xs + + shrink (AMSsWithKey x xss) = + [ AMSsWithKey x (getAMS <$> yss) + | y : y' : ys <- shrinkList shrink $ NE.toList (AMS <$> xss) + , let yss = y :| (y' : ys) + , all (MS.member x . getAMS) yss + ] + +newtype Natural' = Natural' {getNatural :: Natural} + deriving (Eq, Ord, Show, Num, Real, Enum, Integral) + +instance Arbitrary Natural' where + arbitrary = Natural' <$> arbitrarySizedNatural + shrink (Natural' n) = Natural' <$> shrinkIntegral n + +instance CoArbitrary Natural' where + coarbitrary = coarbitraryIntegral . getNatural + +instance Function Natural' where + function = functionIntegral diff --git a/test/Test/Instances.hs b/test/Test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/Instances.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Instances ( + tests, +) where + +import Control.DeepSeq +import Control.Exception +import Data.Either +import Data.List (sort) +import qualified Data.MultiSet.Natural as MS +import qualified Data.Semigroup as SG +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "instances" + [ testProperty "Eq/semantics" prop_eqSemantics + , testProperty "Ord/semantics" prop_ordSemantics + , testProperty "Ord/EQ agrees with Eq" prop_ordEq + , testProperty "Ord/shorter equal run" $ + compare + (MS.fromMultiplicityList [(0 :: Int, 1)]) + (MS.fromMultiplicityList [(0, 2)]) + === LT + , testProperty "Ord/shorter run with tail" $ + compare + (MS.fromMultiplicityList [(0 :: Int, 1), (1, 1)]) + (MS.fromMultiplicityList [(0, 2)]) + === GT + , testProperty "Ord/longer equal run" $ + compare + (MS.fromMultiplicityList [(0 :: Int, 2)]) + (MS.fromMultiplicityList [(0, 1)]) + === GT + , testProperty "Ord/longer run against tail" $ + compare + (MS.fromMultiplicityList [(0 :: Int, 2)]) + (MS.fromMultiplicityList [(0, 1), (1, 1)]) + === LT + , testProperty "Show/Read" prop_showRead + , testProperty "Show/Read/precedence" prop_showReadPrec + , testProperty "Semigroup/associative" prop_semigroupAssociative + , testProperty "Monoid/left identity" prop_monoidLeftIdentity + , testProperty "Monoid/right identity" prop_monoidRightIdentity + , testProperty "MaxUnion/Show/Read" prop_maxUnionShowRead + , testProperty "MaxUnion/Semigroup/associative" prop_maxUnionAssociative + , testProperty "MaxUnion/Monoid/left identity" prop_maxUnionLeftIdentity + , testProperty "MaxUnion/Monoid/right identity" prop_maxUnionRightIdentity + , testProperty "MaxUnion/idempotent" prop_maxUnionIdempotent + , testProperty "NFData/forces elements" $ + ioProperty $ do + let xs = MS.singleton (NFKey 0 undefined) + result <- try @SomeException $ evaluate $ rnf xs + pure $ isLeft result + , testProperty "MaxUnion/Ord/semantics" prop_maxUnionOrdSemantics + , testProperty "MaxUnion/Ord/EQ agrees with Eq" prop_maxUnionOrdEq + , testProperty "MaxUnion/NFData/defined" prop_maxUnionNFDataDefined + , testProperty "MaxUnion/NFData/forces elements" $ + ioProperty $ do + let xs = MS.MaxUnion $ MS.singleton (NFKey 0 undefined) + result <- try @SomeException $ evaluate $ rnf xs + pure $ isLeft result + ] + +prop_eqSemantics :: [Int] -> [Int] -> Property +prop_eqSemantics xs ys = (MS.fromList xs == MS.fromList ys) === (sort xs == sort ys) + +prop_ordSemantics :: [Int] -> [Int] -> Property +prop_ordSemantics xs ys = compare (MS.fromList xs) (MS.fromList ys) === compare (sort xs) (sort ys) + +prop_ordEq :: AMS -> AMS -> Property +prop_ordEq (AMS xs) (AMS ys) = isEQ (compare xs ys) === (xs == ys) + +prop_showRead :: AMS -> Property +prop_showRead (AMS xs) = read (show xs) === xs + +prop_showReadPrec :: AMS -> Property +prop_showReadPrec (AMS xs) = readsPrec 11 (showsPrec 11 xs "") === [(xs, "")] + +prop_semigroupAssociative :: AMS -> AMS -> AMS -> Property +prop_semigroupAssociative (AMS xs) (AMS ys) (AMS zs) = + (xs SG.<> ys) SG.<> zs === xs SG.<> (ys SG.<> zs) + +prop_monoidLeftIdentity :: AMS -> Property +prop_monoidLeftIdentity (AMS xs) = mempty SG.<> xs === xs + +prop_monoidRightIdentity :: AMS -> Property +prop_monoidRightIdentity (AMS xs) = xs SG.<> mempty === xs + +prop_maxUnionShowRead :: AMS -> Property +prop_maxUnionShowRead = ((===) <$> read . show <*> id) . MS.MaxUnion . getAMS + +prop_maxUnionAssociative :: AMS -> AMS -> AMS -> Property +prop_maxUnionAssociative (AMS xs) (AMS ys) (AMS zs) = + (mx SG.<> my) SG.<> mz === mx SG.<> (my SG.<> mz) + where + mx = MS.MaxUnion xs + my = MS.MaxUnion ys + mz = MS.MaxUnion zs + +prop_maxUnionLeftIdentity :: AMS -> Property +prop_maxUnionLeftIdentity (AMS xs) = mempty SG.<> MS.MaxUnion xs === MS.MaxUnion xs + +prop_maxUnionRightIdentity :: AMS -> Property +prop_maxUnionRightIdentity (AMS xs) = MS.MaxUnion xs SG.<> mempty === MS.MaxUnion xs + +prop_maxUnionIdempotent :: AMS -> Property +prop_maxUnionIdempotent (AMS xs) = mx SG.<> mx === mx + where + mx = MS.MaxUnion xs + +data NFKey = NFKey Int Int + +instance Eq NFKey where + NFKey x _ == NFKey y _ = x == y + +instance Ord NFKey where + compare (NFKey x _) (NFKey y _) = compare x y + +instance NFData NFKey where + rnf (NFKey x y) = rnf x `seq` rnf y + +prop_maxUnionOrdSemantics :: [Int] -> [Int] -> Property +prop_maxUnionOrdSemantics xs ys = + compare (MS.MaxUnion $ MS.fromList xs) (MS.MaxUnion $ MS.fromList ys) + === compare (sort xs) (sort ys) + +prop_maxUnionOrdEq :: AMS -> AMS -> Property +prop_maxUnionOrdEq (AMS xs) (AMS ys) = + isEQ (compare mx my) === (mx == my) + where + mx = MS.MaxUnion xs + my = MS.MaxUnion ys + +prop_maxUnionNFDataDefined :: AMS -> Property +prop_maxUnionNFDataDefined (AMS xs) = rnf (MS.MaxUnion xs) `seq` property True + +isEQ :: Ordering -> Bool +isEQ = (== EQ) diff --git a/test/Test/Queries.hs b/test/Test/Queries.hs new file mode 100644 --- /dev/null +++ b/test/Test/Queries.hs @@ -0,0 +1,128 @@ +module Test.Queries ( + tests, +) where + +import Data.List +import Data.Maybe +import qualified Data.MultiSet.Natural as MS +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "queries" + [ testProperty "null" prop_null + , testProperty "member" prop_member + , testProperty "notMember" prop_notMember + , testProperty "multiplicity" prop_multiplicity + , testProperty "size" prop_size + , testProperty "distinctSize" prop_distinctSize + , testProperty "lookupLT" prop_lookupLT + , testProperty "lookupLE" prop_lookupLE + , testProperty "lookupGT" prop_lookupGT + , testProperty "lookupGE" prop_lookupGE + , testProperty "lookupMin" prop_lookupMin + , testProperty "lookupMax" prop_lookupMax + , testProperty "isSubsetOf/reflexive" prop_isSubsetOfReflexive + , testProperty "isSubsetOf/constructed" prop_isSubsetOfConstructed + , testProperty "isSubsetOf/difference" prop_isSubsetOfDifference + , testProperty "isProperSubsetOf/implies subset" prop_isProperSubsetOfSubset + , testProperty "isProperSubsetOf/irreflexive" prop_isProperSubsetOfIrreflexive + , testProperty "isProperSubsetOf/definition" prop_isProperSubsetOfDefinition + , testProperty "disjoint/symmetric" prop_disjointSymmetric + , testProperty "disjoint/empty" prop_disjointEmpty + , testProperty "disjoint/intersection" prop_disjointIntersection + ] + +prop_null :: AMS -> Property +prop_null (AMS xs) = MS.null xs === (MS.distinctSize xs == 0) + +prop_member :: AMSWithKey -> Property +prop_member (AMSWithKey x xs) = MS.member x xs === (MS.multiplicity x xs > 0) + +prop_notMember :: AMSWithKey -> Property +prop_notMember (AMSWithKey x xs) = MS.notMember x xs === not (MS.member x xs) + +prop_multiplicity :: AMSWithKey -> Property +prop_multiplicity (AMSWithKey x xs) = + MS.multiplicity x xs === maybe 0 snd (find ((== x) . fst) $ MS.toMultiplicityList xs) + +prop_size :: AMS -> Property +prop_size (AMS xs) = MS.size xs === sum (map snd $ MS.toMultiplicityList xs) + +prop_distinctSize :: AMS -> Property +prop_distinctSize (AMS xs) = MS.distinctSize xs === genericLength (MS.toDistinctList xs) + +prop_lookupLT :: AMSWithKey -> Property +prop_lookupLT (AMSWithKey x xs) = + MS.lookupLT x xs === lastMaybe (takeWhile ((< x) . fst) $ MS.toMultiplicityList xs) + +prop_lookupLE :: AMSWithKey -> Property +prop_lookupLE (AMSWithKey x xs) = + MS.lookupLE x xs === lastMaybe (takeWhile ((<= x) . fst) $ MS.toMultiplicityList xs) + +prop_lookupGT :: AMSWithKey -> Property +prop_lookupGT (AMSWithKey x xs) = MS.lookupGT x xs === find ((> x) . fst) (MS.toMultiplicityList xs) + +prop_lookupGE :: AMSWithKey -> Property +prop_lookupGE (AMSWithKey x xs) = + MS.lookupGE x xs === find ((>= x) . fst) (MS.toMultiplicityList xs) + +prop_lookupMin :: AMS -> Property +prop_lookupMin (AMS xs) = MS.lookupMin xs === listToMaybe (MS.toMultiplicityList xs) + +prop_lookupMax :: AMS -> Property +prop_lookupMax (AMS xs) = MS.lookupMax xs === lastMaybe (MS.toMultiplicityList xs) + +lastMaybe :: [a] -> Maybe a +lastMaybe = listToMaybe . reverse + +prop_isSubsetOfReflexive :: AMS -> Property +prop_isSubsetOfReflexive (AMS xs) = property $ MS.isSubsetOf xs xs + +prop_isSubsetOfConstructed :: AMS -> AMS -> AMS -> Property +prop_isSubsetOfConstructed (AMS xs) (AMS ys') (AMS zs') = property $ MS.isSubsetOf xs zs + where + ys = MS.union xs ys' + zs = MS.union ys zs' + +prop_isProperSubsetOfSubset :: Int -> AMS -> Property +prop_isProperSubsetOfSubset x (AMS xs) = + conjoin + [ property $ MS.isProperSubsetOf xs ys + , property $ MS.isSubsetOf xs ys + ] + where + ys = MS.insert x xs + +prop_isProperSubsetOfIrreflexive :: AMS -> Property +prop_isProperSubsetOfIrreflexive (AMS xs) = property . not $ MS.isProperSubsetOf xs xs + +prop_disjointSymmetric :: AMS -> AMS -> Property +prop_disjointSymmetric (AMS xs) (AMS ys) = MS.disjoint xs ys === MS.disjoint ys xs + +prop_disjointEmpty :: AMS -> Property +prop_disjointEmpty (AMS xs) = property $ MS.disjoint xs MS.empty + +prop_disjointIntersection :: AMS -> AMS -> Property +prop_disjointIntersection (AMS xs) (AMS ys) = MS.disjoint xs ys === MS.null (MS.intersection xs ys) + +prop_isSubsetOfDifference :: Property +prop_isSubsetOfDifference = + forAll genSubsetPair $ \(xs, ys) -> MS.isSubsetOf xs ys === MS.null (MS.difference xs ys) + +prop_isProperSubsetOfDefinition :: Property +prop_isProperSubsetOfDefinition = + forAll genSubsetPair $ \(xs, ys) -> + MS.isProperSubsetOf xs ys === (MS.isSubsetOf xs ys && xs /= ys) + +genSubsetPair :: Gen (MS.MultiSet Int, MS.MultiSet Int) +genSubsetPair = + arbitrary >>= \(x, AMS xs, AMS ys) -> + oneof + [ pure (xs, xs) + , pure (xs, MS.insert x xs) + , pure (MS.setMultiplicity x (MS.multiplicity x ys + 1) xs, ys) + ] diff --git a/test/Test/ToFrom.hs b/test/Test/ToFrom.hs new file mode 100644 --- /dev/null +++ b/test/Test/ToFrom.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TupleSections #-} + +module Test.ToFrom ( + tests, +) where + +import Data.List +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import qualified Data.MultiSet.Natural as MS +import qualified Data.Set as S +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "constructors" + [ testProperty "empty" prop_empty + , testProperty "singleton" prop_singleton + , testProperty "singletonMany" prop_singletonMany + , testProperty "fromMultiplicityList" prop_fromMultiplicityList + , testProperty "fromMultiplicityList/zero" prop_fromMultiplicityListZero + , testProperty "fromMultiplicityList/duplicates" prop_fromMultiplicityListDuplicates + , testProperty "fromList" prop_fromList + , testProperty "fromSet" prop_fromSet + , testProperty "fromMap" prop_fromMap + , testProperty "fromMultiplicityList . toMultiplicityList" prop_multiplicityListRoundtrip + , testProperty "fromList . toList" prop_listRoundtrip + , testProperty "fromMap . toMap" prop_mapRoundtrip + , testProperty "toSet . fromSet" prop_setRoundtrip + , testProperty "toDistinctList . fromList" prop_distinctList + , testProperty "toMultiplicityList/ascending" prop_toMultiplicityListAscending + , testProperty "toList/ascending" prop_toListAscending + , testProperty "toDistinctList/ascending" prop_toDistinctListAscending + , testProperty "toMultiplicityList/toDistinctList" prop_toMultiplicityListDistinct + , testProperty "toMultiplicityList/toMap" prop_toMultiplicityListMap + , testProperty "toDistinctList/toSet" prop_toDistinctListSet + , testProperty "toMultiplicityList/distinctSize" prop_toMultiplicityListDistinctSize + , testProperty "toDistinctList/distinctSize" prop_toDistinctListDistinctSize + , testProperty "toList/toMultiplicityList" prop_toListMultiplicityList + ] + +prop_empty :: Property +prop_empty = MS.toMap (MS.empty :: MS.MultiSet Int) === M.empty + +prop_singleton :: Int -> Property +prop_singleton x = MS.toMap (MS.singleton x) === M.singleton x 1 + +prop_singletonMany :: Int -> LNat -> Property +prop_singletonMany x (LNat n) = + MS.toMap (MS.singletonMany x n) === if n == 0 then M.empty else M.singleton x n + +prop_fromMultiplicityList :: [(Int, LNat)] -> Property +prop_fromMultiplicityList = + ((===) <$> MS.toMap . MS.fromMultiplicityList <*> M.filter (> 0) . M.fromListWith (+)) + . fmap (fmap getLNat) + +prop_fromMultiplicityListZero :: Int -> Property +prop_fromMultiplicityListZero x = MS.fromMultiplicityList [(x, 0)] === MS.empty + +prop_fromMultiplicityListDuplicates :: Int -> LNat -> LNat -> Property +prop_fromMultiplicityListDuplicates x (LNat n) (LNat m) = + MS.toMap (MS.fromMultiplicityList [(x, n), (x, m)]) + === if n + m == 0 then M.empty else M.singleton x (n + m) + +prop_fromList :: [Int] -> Property +prop_fromList = (===) <$> MS.toMap . MS.fromList <*> M.fromListWith (+) . fmap (,1) + +prop_fromSet :: S.Set Int -> Property +prop_fromSet xs = MS.toMap (MS.fromSet xs) === M.fromSet (const 1) xs + +prop_fromMap :: M.Map Int LNat -> Property +prop_fromMap xs = MS.toMap (MS.fromMap ys) === M.filter (> 0) ys + where + ys = getLNat <$> xs + +prop_multiplicityListRoundtrip :: AMS -> Property +prop_multiplicityListRoundtrip (AMS xs) = MS.fromMultiplicityList (MS.toMultiplicityList xs) === xs + +prop_mapRoundtrip :: AMS -> Property +prop_mapRoundtrip (AMS xs) = MS.fromMap (MS.toMap xs) === xs + +-- not based on AMS to avoid the explosion of toList with AMS +prop_listRoundtrip :: [Int] -> Property +prop_listRoundtrip = (===) <$> MS.toList . MS.fromList <*> sort + +prop_setRoundtrip :: S.Set Int -> Property +prop_setRoundtrip xs = MS.toSet (MS.fromSet xs) === xs + +prop_distinctList :: [Int] -> Property +prop_distinctList = (===) <$> MS.toDistinctList . MS.fromList <*> S.toAscList . S.fromList + +prop_toMultiplicityListAscending :: AMS -> Property +prop_toMultiplicityListAscending (AMS xs) = + property $ strictlyAscending $ map fst $ MS.toMultiplicityList xs + +prop_toListAscending :: [Int] -> Property +prop_toListAscending = ((===) <$> MS.toList <*> sort . MS.toList) . MS.fromList + +prop_toDistinctListAscending :: AMS -> Property +prop_toDistinctListAscending (AMS xs) = property $ strictlyAscending $ MS.toDistinctList xs + +prop_toMultiplicityListDistinct :: AMS -> Property +prop_toMultiplicityListDistinct (AMS xs) = + map fst (MS.toMultiplicityList xs) === MS.toDistinctList xs + +prop_toMultiplicityListMap :: AMS -> Property +prop_toMultiplicityListMap (AMS xs) = MS.toMultiplicityList xs === M.toAscList (MS.toMap xs) + +prop_toDistinctListSet :: AMS -> Property +prop_toDistinctListSet (AMS xs) = MS.toDistinctList xs === S.toAscList (MS.toSet xs) + +prop_toMultiplicityListDistinctSize :: AMS -> Property +prop_toMultiplicityListDistinctSize (AMS xs) = + length (MS.toMultiplicityList xs) === MS.distinctSize xs + +prop_toDistinctListDistinctSize :: AMS -> Property +prop_toDistinctListDistinctSize (AMS xs) = length (MS.toDistinctList xs) === MS.distinctSize xs + +prop_toListMultiplicityList :: [Int] -> Property +prop_toListMultiplicityList = ((===) <$> MS.toMultiplicityList <*> counts . MS.toList) . MS.fromList + where + counts = map ((,) <$> NE.head <*> fromIntegral . length) . NE.group + +strictlyAscending :: (Ord a) => [a] -> Bool +strictlyAscending xs = and $ zipWith (<) xs (drop 1 xs) diff --git a/test/Test/Transformations.hs b/test/Test/Transformations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Transformations.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Transformations ( + tests, +) where + +import Control.Monad ((>=>)) +import Data.Coerce +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "transformations" + [ testProperty "filter/true" prop_filterTrue + , testProperty "filter/false" prop_filterFalse + , testProperty "filter/composition" prop_filterComposition + , testProperty "filterWithMultiplicity/bridge" prop_filterWithMultiplicityBridge + , testProperty "filterWithMultiplicity/composition" prop_filterWithMultiplicityComposition + , testProperty "partition/reconstruct" prop_partitionReconstruct + , testProperty "partition/filter" prop_partitionFilter + , testProperty "partitionWithMultiplicity/reconstruct" prop_partitionWithMultiplicityReconstruct + , testProperty "partitionWithMultiplicity/filter" prop_partitionWithMultiplicityFilter + , testProperty "partitionWithMultiplicity/bridge" prop_partitionWithMultiplicityBridge + , testProperty "map/identity" prop_mapIdentity + , testProperty "map/composition" prop_mapComposition + , testProperty "map/union" prop_mapUnion + , testProperty "mapWithMultiplicity/identity" prop_mapWithMultiplicityIdentity + , testProperty "mapWithMultiplicity/decompose" prop_mapWithMultiplicityDecompose + , testProperty "mapMultiplicities/identity" prop_mapMultiplicitiesIdentity + , testProperty "mapMultiplicities/zero" prop_mapMultiplicitiesZero + , testProperty "mapMultiplicities/composition" prop_mapMultiplicitiesComposition + , testProperty "mapMaybe/identity" prop_mapMaybeIdentity + , testProperty "mapMaybe/nothing" prop_mapMaybeNothing + , testProperty "mapMaybe/composition" prop_mapMaybeComposition + , testProperty "mapMaybe/map" prop_mapMaybeMap + , testProperty "mapMaybeWithMultiplicity/identity" prop_mapMaybeWithMultiplicityIdentity + , testProperty "mapMaybeWithMultiplicity/nothing" prop_mapMaybeWithMultiplicityNothing + , testProperty "mapMaybeWithMultiplicity/mapMaybe" prop_mapMaybeWithMultiplicityMapMaybe + , testProperty + "mapMaybeWithMultiplicity/mapWithMultiplicity" + prop_mapMaybeWithMultiplicityMapWithMultiplicity + , testProperty "concatMap/left identity" prop_concatMapLeftIdentity + , testProperty "concatMap/right identity" prop_concatMapRightIdentity + , testProperty "concatMap/associativity" prop_concatMapAssociativity + , testProperty "concatMap/map" prop_concatMapMap + , testProperty "concatMap/scaling" prop_concatMapScaling + ] + +prop_filterTrue :: AMS -> Property +prop_filterTrue (AMS xs) = MS.filter (const True) xs === xs + +prop_filterFalse :: AMS -> Property +prop_filterFalse (AMS xs) = MS.filter (const False) xs === MS.empty + +prop_filterComposition :: Fun Int Bool -> Fun Int Bool -> AMS -> Property +prop_filterComposition pFun qFun (AMS xs) = + MS.filter p (MS.filter q xs) === MS.filter (\x -> p x && q x) xs + where + p = applyFun pFun + q = applyFun qFun + +prop_filterWithMultiplicityBridge :: Fun Int Bool -> AMS -> Property +prop_filterWithMultiplicityBridge fun (AMS xs) = + MS.filterWithMultiplicity (\x _ -> f x) xs === MS.filter f xs + where + f = applyFun fun + +prop_filterWithMultiplicityComposition :: + Fun (Int, Natural') Bool -> Fun (Int, Natural') Bool -> AMS -> Property +prop_filterWithMultiplicityComposition pFun qFun (AMS xs) = + MS.filterWithMultiplicity p (MS.filterWithMultiplicity q xs) + === MS.filterWithMultiplicity (\x n -> p x n && q x n) xs + where + p = curry . coerce $ applyFun pFun + q = curry . coerce $ applyFun qFun + +prop_partitionReconstruct :: Fun Int Bool -> AMS -> Property +prop_partitionReconstruct fun (AMS xs) = + conjoin + [ MS.union yes no === xs + , property $ MS.disjoint yes no + ] + where + (yes, no) = MS.partition (applyFun fun) xs + +prop_partitionFilter :: Fun Int Bool -> AMS -> Property +prop_partitionFilter fun (AMS xs) = + MS.partition p xs === (MS.filter p xs, MS.filter (not . p) xs) + where + p = applyFun fun + +prop_partitionWithMultiplicityReconstruct :: Fun (Int, Natural') Bool -> AMS -> Property +prop_partitionWithMultiplicityReconstruct fun (AMS xs) = + conjoin + [ MS.union yes no === xs + , property $ MS.disjoint yes no + ] + where + (yes, no) = MS.partitionWithMultiplicity (curry . coerce $ applyFun fun) xs + +prop_partitionWithMultiplicityFilter :: Fun (Int, Natural') Bool -> AMS -> Property +prop_partitionWithMultiplicityFilter fun (AMS xs) = + MS.partitionWithMultiplicity p xs + === (MS.filterWithMultiplicity p xs, MS.filterWithMultiplicity (\x n -> not $ p x n) xs) + where + p = curry . coerce $ applyFun fun + +prop_partitionWithMultiplicityBridge :: Fun Int Bool -> AMS -> Property +prop_partitionWithMultiplicityBridge fun (AMS xs) = + MS.partitionWithMultiplicity (\x _ -> p x) xs === MS.partition p xs + where + p = applyFun fun + +prop_mapIdentity :: AMS -> Property +prop_mapIdentity (AMS xs) = MS.map id xs === xs + +prop_mapComposition :: Fun Int Int -> Fun Int Int -> AMS -> Property +prop_mapComposition fFun gFun (AMS xs) = + MS.map f (MS.map g xs) === MS.map (f . g) xs + where + f = applyFun fFun + g = applyFun gFun + +prop_mapUnion :: Fun Int Int -> AMS -> AMS -> Property +prop_mapUnion (Fun _ f) (AMS xs) (AMS ys) = + MS.map f (MS.union xs ys) === MS.union (MS.map f xs) (MS.map f ys) + +prop_mapWithMultiplicityIdentity :: AMS -> Property +prop_mapWithMultiplicityIdentity (AMS xs) = MS.mapWithMultiplicity (,) xs === xs + +prop_mapWithMultiplicityDecompose :: Fun Int Int -> Fun Natural' Natural' -> AMS -> Property +prop_mapWithMultiplicityDecompose fFun gFun (AMS xs) = + MS.mapWithMultiplicity (\x n -> (f x, g n)) xs === MS.map f (MS.mapMultiplicities g xs) + where + f = applyFun fFun + g = coerce $ applyFun gFun + +prop_mapMultiplicitiesIdentity :: AMS -> Property +prop_mapMultiplicitiesIdentity (AMS xs) = MS.mapMultiplicities id xs === xs + +prop_mapMultiplicitiesZero :: AMS -> Property +prop_mapMultiplicitiesZero (AMS xs) = MS.mapMultiplicities (const 0) xs === MS.empty + +prop_mapMultiplicitiesComposition :: + Fun Natural' Natural' -> Fun Natural' Natural' -> AMS -> Property +prop_mapMultiplicitiesComposition fFun gFun (AMS xs) = + MS.mapMultiplicities f (MS.mapMultiplicities g xs) === MS.mapMultiplicities (f . g) xs + where + f = zeroPreserving fFun + g = zeroPreserving gFun + + zeroPreserving _ 0 = 0 + zeroPreserving fun n = coerce (applyFun fun) n + +prop_mapMaybeIdentity :: AMS -> Property +prop_mapMaybeIdentity (AMS xs) = MS.mapMaybe Just xs === xs + +prop_mapMaybeNothing :: AMS -> Property +prop_mapMaybeNothing (AMS xs) = MS.mapMaybe @Int (const Nothing) xs === MS.empty + +prop_mapMaybeComposition :: Fun Int (Maybe Int) -> Fun Int (Maybe Int) -> AMS -> Property +prop_mapMaybeComposition fFun gFun (AMS xs) = + MS.mapMaybe f (MS.mapMaybe g xs) === MS.mapMaybe (g >=> f) xs + where + f = applyFun fFun + g = applyFun gFun + +prop_mapMaybeMap :: Fun Int Int -> AMS -> Property +prop_mapMaybeMap fun (AMS xs) = MS.mapMaybe (Just . f) xs === MS.map f xs + where + f = applyFun fun + +prop_mapMaybeWithMultiplicityIdentity :: AMS -> Property +prop_mapMaybeWithMultiplicityIdentity (AMS xs) = + MS.mapMaybeWithMultiplicity (curry Just) xs === xs + +prop_mapMaybeWithMultiplicityNothing :: AMS -> Property +prop_mapMaybeWithMultiplicityNothing (AMS xs) = + MS.mapMaybeWithMultiplicity @Int (\_ _ -> Nothing) xs === MS.empty + +prop_mapMaybeWithMultiplicityMapMaybe :: Fun Int (Maybe Int) -> AMS -> Property +prop_mapMaybeWithMultiplicityMapMaybe fun (AMS xs) = + MS.mapMaybeWithMultiplicity (\x n -> (,n) <$> f x) xs === MS.mapMaybe f xs + where + f = applyFun fun + +prop_mapMaybeWithMultiplicityMapWithMultiplicity :: + Fun (Int, Natural') (Int, Natural') -> AMS -> Property +prop_mapMaybeWithMultiplicityMapWithMultiplicity fun (AMS xs) = + MS.mapMaybeWithMultiplicity (\x n -> Just $ f x n) xs === MS.mapWithMultiplicity f xs + where + f :: Int -> Natural -> (Int, Natural) + f = curry . coerce $ applyFun fun + +prop_concatMapLeftIdentity :: Int -> Fun Int AMS -> Property +prop_concatMapLeftIdentity x fun = MS.concatMap f (MS.singleton x) === f x + where + f = getAMS . applyFun fun + +prop_concatMapRightIdentity :: AMS -> Property +prop_concatMapRightIdentity (AMS xs) = MS.concatMap MS.singleton xs === xs + +prop_concatMapAssociativity :: Fun Int AMS -> Fun Int AMS -> AMS -> Property +prop_concatMapAssociativity fFun gFun (AMS xs) = + MS.concatMap f (MS.concatMap g xs) === MS.concatMap (MS.concatMap f . g) xs + where + f = getAMS . applyFun fFun + g = getAMS . applyFun gFun + +prop_concatMapMap :: Fun Int Int -> AMS -> Property +prop_concatMapMap fun (AMS xs) = MS.concatMap (MS.singleton . f) xs === MS.map f xs + where + f = applyFun fun + +prop_concatMapScaling :: Fun Int AMS -> Int -> LNat -> Property +prop_concatMapScaling (Fun _ f) x (LNat n) = + MS.concatMap (getAMS . f) (MS.singletonMany x n) === MS.mapMultiplicities (* n) (getAMS $ f x) diff --git a/test/Test/Updates.hs b/test/Test/Updates.hs new file mode 100644 --- /dev/null +++ b/test/Test/Updates.hs @@ -0,0 +1,142 @@ +module Test.Updates ( + tests, +) where + +import Data.Coerce +import Data.Functor.Identity +import qualified Data.MultiSet.Natural as MS +import Numeric.Natural +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "updates" + [ testProperty "insert/insertMany" prop_insertInsertMany + , testProperty "insert/multiplicity" prop_insertMultiplicity + , testProperty "insert/preserves others" prop_insertPreservesOthers + , testProperty "insertMany/zero" prop_insertManyZero + , testProperty "insertMany/multiplicity" prop_insertManyMultiplicity + , testProperty "insertMany/preserves others" prop_insertManyPreservesOthers + , testProperty "delete/deleteMany" prop_deleteDeleteMany + , testProperty "delete/multiplicity" prop_deleteMultiplicity + , testProperty "delete/preserves others" prop_deletePreservesOthers + , testProperty "deleteMany/zero" prop_deleteManyZero + , testProperty "deleteMany/multiplicity" prop_deleteManyMultiplicity + , testProperty "deleteMany/preserves others" prop_deleteManyPreservesOthers + , testProperty "deleteMany/undo insertMany" prop_deleteManyUndoInsertMany + , testProperty "deleteAll/multiplicity" prop_deleteAllMultiplicity + , testProperty "deleteAll/idempotent" prop_deleteAllIdempotent + , testProperty "deleteAll/preserves others" prop_deleteAllPreservesOthers + , testProperty "setMultiplicity/multiplicity" prop_setMultiplicityMultiplicity + , testProperty "setMultiplicity/zero" prop_setMultiplicityZero + , testProperty "setMultiplicity/preserves others" prop_setMultiplicityPreservesOthers + , testProperty "setMultiplicity/alterMultiplicity" prop_setMultiplicityAlterMultiplicity + , testProperty "alterMultiplicity/identity" prop_alterMultiplicityIdentity + , testProperty "alterMultiplicity/multiplicity" prop_alterMultiplicityMultiplicity + , testProperty "alterMultiplicity/preserves others" prop_alterMultiplicityPreservesOthers + , testProperty "alterMultiplicityF/Identity" prop_alterMultiplicityFIdentity + ] + +prop_insertInsertMany :: AMSWithKey -> Property +prop_insertInsertMany (AMSWithKey x xs) = MS.insert x xs === MS.insertMany x 1 xs + +prop_insertMultiplicity :: AMSWithKey -> Property +prop_insertMultiplicity (AMSWithKey x xs) = + MS.multiplicity x (MS.insert x xs) === MS.multiplicity x xs + 1 + +prop_insertPreservesOthers :: AMSWithKey -> Property +prop_insertPreservesOthers (AMSWithKey x xs) = MS.deleteAll x (MS.insert x xs) === MS.deleteAll x xs + +prop_insertManyZero :: AMSWithKey -> Property +prop_insertManyZero (AMSWithKey x xs) = MS.insertMany x 0 xs === xs + +prop_insertManyMultiplicity :: LNat -> AMSWithKey -> Property +prop_insertManyMultiplicity (LNat n) (AMSWithKey x xs) = + MS.multiplicity x (MS.insertMany x n xs) === MS.multiplicity x xs + n + +prop_insertManyPreservesOthers :: LNat -> AMSWithKey -> Property +prop_insertManyPreservesOthers (LNat n) (AMSWithKey x xs) = + MS.deleteAll x (MS.insertMany x n xs) === MS.deleteAll x xs + +prop_deleteDeleteMany :: AMSWithKey -> Property +prop_deleteDeleteMany (AMSWithKey x xs) = MS.delete x xs === MS.deleteMany x 1 xs + +prop_deleteMultiplicity :: AMSWithKey -> Property +prop_deleteMultiplicity (AMSWithKey x xs) = + MS.multiplicity x (MS.delete x xs) === MS.multiplicity x xs `monus` 1 + +prop_deletePreservesOthers :: AMSWithKey -> Property +prop_deletePreservesOthers (AMSWithKey x xs) = MS.deleteAll x (MS.delete x xs) === MS.deleteAll x xs + +prop_deleteManyZero :: AMSWithKey -> Property +prop_deleteManyZero (AMSWithKey x xs) = MS.deleteMany x 0 xs === xs + +prop_deleteManyMultiplicity :: LNat -> AMSWithKey -> Property +prop_deleteManyMultiplicity (LNat n) (AMSWithKey x xs) = + MS.multiplicity x (MS.deleteMany x n xs) === MS.multiplicity x xs `monus` n + +prop_deleteManyPreservesOthers :: LNat -> AMSWithKey -> Property +prop_deleteManyPreservesOthers (LNat n) (AMSWithKey x xs) = + MS.deleteAll x (MS.deleteMany x n xs) === MS.deleteAll x xs + +prop_deleteManyUndoInsertMany :: LNat -> AMSWithKey -> Property +prop_deleteManyUndoInsertMany (LNat n) (AMSWithKey x xs) = + MS.deleteMany x n (MS.insertMany x n xs) === xs + +prop_deleteAllMultiplicity :: AMSWithKey -> Property +prop_deleteAllMultiplicity (AMSWithKey x xs) = MS.multiplicity x (MS.deleteAll x xs) === 0 + +prop_deleteAllIdempotent :: AMSWithKey -> Property +prop_deleteAllIdempotent (AMSWithKey x xs) = + MS.deleteAll x (MS.deleteAll x xs) === MS.deleteAll x xs + +prop_deleteAllPreservesOthers :: LNat -> AMSWithKey -> Property +prop_deleteAllPreservesOthers (LNat n) (AMSWithKey x xs) = + MS.deleteAll x (MS.insertMany x n xs) === MS.deleteAll x xs + +prop_setMultiplicityMultiplicity :: LNat -> AMSWithKey -> Property +prop_setMultiplicityMultiplicity (LNat n) (AMSWithKey x xs) = + MS.multiplicity x (MS.setMultiplicity x n xs) === n + +prop_setMultiplicityZero :: AMSWithKey -> Property +prop_setMultiplicityZero (AMSWithKey x xs) = MS.setMultiplicity x 0 xs === MS.deleteAll x xs + +prop_setMultiplicityPreservesOthers :: LNat -> AMSWithKey -> Property +prop_setMultiplicityPreservesOthers (LNat n) (AMSWithKey x xs) = + MS.deleteAll x (MS.setMultiplicity x n xs) === MS.deleteAll x xs + +prop_setMultiplicityAlterMultiplicity :: LNat -> AMSWithKey -> Property +prop_setMultiplicityAlterMultiplicity (LNat n) (AMSWithKey x xs) = + MS.setMultiplicity x n xs === MS.alterMultiplicity (const n) x xs + +prop_alterMultiplicityIdentity :: AMSWithKey -> Property +prop_alterMultiplicityIdentity (AMSWithKey x xs) = MS.alterMultiplicity id x xs === xs + +prop_alterMultiplicityMultiplicity :: Fun Natural' Natural' -> AMSWithKey -> Property +prop_alterMultiplicityMultiplicity fun (AMSWithKey x xs) = + MS.multiplicity x (MS.alterMultiplicity f x xs) === f (MS.multiplicity x xs) + where + f :: Natural -> Natural + f = coerce $ applyFun fun + +prop_alterMultiplicityPreservesOthers :: Fun Natural' Natural' -> AMSWithKey -> Property +prop_alterMultiplicityPreservesOthers fun (AMSWithKey x xs) = + MS.deleteAll x (MS.alterMultiplicity f x xs) === MS.deleteAll x xs + where + f :: Natural -> Natural + f = coerce $ applyFun fun + +prop_alterMultiplicityFIdentity :: Fun Natural' Natural' -> AMSWithKey -> Property +prop_alterMultiplicityFIdentity fun (AMSWithKey x xs) = + runIdentity (MS.alterMultiplicityF (Identity . f) x xs) === MS.alterMultiplicity f x xs + where + f :: Natural -> Natural + f = coerce $ applyFun fun + +monus :: Natural -> Natural -> Natural +monus x y + | x >= y = x - y + | otherwise = 0 diff --git a/test/Test/Valid.hs b/test/Test/Valid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Valid.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Valid ( + tests, +) where + +import Data.Bifunctor +import Data.Coerce +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as M +import qualified Data.MultiSet.Natural as MS +import qualified Data.Set as S +import Test.Gen +import Test.Tasty +import Test.Tasty.QuickCheck + +valid :: (Ord a) => MS.MultiSet a -> Bool +valid = (&&) <$> M.valid . MS.toMap <*> all (> 0) . MS.toMap + +tests :: TestTree +tests = + testGroup + "validity" + [ constructs @() @Int "empty" $ + const MS.empty + , constructs @Int + "singleton" + MS.singleton + , constructs @(Int, LNat) "singletonMany" $ + \(x, LNat n) -> MS.singletonMany x n + , constructs @[(Int, LNat)] "fromMultiplicityList" $ + MS.fromMultiplicityList . map (second getLNat) + , constructs @[Int] + "fromList" + MS.fromList + , constructs @(S.Set Int) + "fromSet" + MS.fromSet + , constructs @(M.Map Int LNat) "fromMap" $ + MS.fromMap . fmap getLNat + , preserves "deleteMin" MS.deleteMin + , preserves "deleteMax" MS.deleteMax + , preserves "deleteMinAll" MS.deleteMinAll + , preserves "deleteMaxAll" MS.deleteMaxAll + , preserves1 "insert" MS.insert + , preserves1 "delete" MS.delete + , preserves1 "deleteAll" MS.deleteAll + , preserves1 "union" $ + \(AMS xs) -> (`MS.union` xs) + , preserves1 "unions" $ + \xss ms -> MS.unions $ ms : (getAMS <$> xss) + , preserves1 "difference" $ + \(AMS xs) -> (`MS.difference` xs) + , preserves1 "symmetricDifference" $ + \(AMS xs) -> (`MS.symmetricDifference` xs) + , preserves1 "intersection" $ + \(AMS xs) -> (`MS.intersection` xs) + , preserves1 "intersections" $ + \xss ms -> MS.intersections $ ms :| (getAMS <$> xss) + , preserves1 "maxUnion" $ + \(AMS xs) -> (`MS.maxUnion` xs) + , preserves1 @AMS "cartesianProduct" $ + \(AMS xs) -> (`MS.cartesianProduct` xs) + , preserves2 "insertMany" $ + \x (LNat n) -> MS.insertMany x n + , preserves2 "deleteMany" $ + \x (LNat n) -> MS.deleteMany x n + , preserves2 "setMultiplicity" $ + \x (LNat n) -> MS.setMultiplicity x n + , preservesFun "filter" MS.filter + , preservesFun @(Int, Natural') @Bool "filterWithMultiplicity" $ + coerce (MS.filterWithMultiplicity . curry) + , preservesFun "filterA" $ + \f -> runIdentity . MS.filterA (Identity . f) + , preservesFun @(Int, Natural') @Bool "filterWithMultiplicityA" $ + coerce $ + \f -> runIdentity . MS.filterWithMultiplicityA ((Identity .) . curry f) + , preservesFun @Int @Int "map" MS.map + , preservesFun @(Int, Natural') @(Char, Natural') @Char "mapWithMultiplicity" $ + coerce (MS.mapWithMultiplicity . curry) + , preservesFun @Natural' @Natural' "mapMultiplicities" $ + coerce MS.mapMultiplicities + , preservesFun @Int @(Maybe Int) "mapMaybe" MS.mapMaybe + , preservesFun @(Int, Natural') @(Maybe (Integer, Natural')) @Integer "mapMaybeWithMultiplicity" $ + coerce (MS.mapMaybeWithMultiplicity . curry) + , preservesFun @Int @AMS "concatMap" $ + \f -> MS.concatMap (getAMS . f) + , preservesFun @Int @String "traverse" $ + \f -> runIdentity . MS.traverse (Identity . f) + , preservesFun @Int @(Maybe Float) "traverseMaybe" $ + \f -> runIdentity . MS.traverseMaybe (Identity . f) + , preservesFun @(Int, Natural') @(Bool, Natural') @Bool "traverseWithMultiplicity" $ + coerce $ + \f -> runIdentity . MS.traverseWithMultiplicity (\x n -> Identity $ f (x, n)) + , preservesFun @(Int, Natural') @(Maybe (Word, Natural')) @Word "traverseMaybeWithMultiplicity" $ + coerce $ + \f -> runIdentity . MS.traverseMaybeWithMultiplicity (\x n -> Identity $ f (x, n)) + , preservesAllFun "partition" $ + \f -> pair . MS.partition f + , preservesAllFun @(Int, Natural') @Bool @[] "partitionWithMultiplicity" $ + coerce $ + \f -> pair . MS.partitionWithMultiplicity (curry f) + , preservesAllFun "partitionA" $ + \f -> pair . runIdentity . MS.partitionA (Identity . f) + , preservesAllFun @(Int, Natural') @Bool @[] "partitionWithMultiplicityA" $ + coerce $ \f -> + pair + . runIdentity + . MS.partitionWithMultiplicityA ((Identity .) . curry f) + , preservesAll "minView" $ + fmap snd . MS.minView + , preservesAll "maxView" $ + fmap snd . MS.maxView + , preservesAll "minViewWithMultiplicity" $ + fmap snd . MS.minViewWithMultiplicity + , preservesAll "maxViewWithMultiplicity" $ + fmap snd . MS.maxViewWithMultiplicity + , preservesAll1 "split" $ + \x ms -> let (lt, _, gt) = MS.split x ms in [lt, gt] + , preservesFun1 @Natural' @Natural' @Int "alterMultiplicity" $ + coerce MS.alterMultiplicity + , preservesFun1 @Natural' @Natural' @Int "alterMultiplicityF" $ + coerce $ + \f x -> runIdentity . MS.alterMultiplicityF (Identity . f) x + ] + +constructs :: (Arbitrary a, Show a, Ord b) => String -> (a -> MS.MultiSet b) -> TestTree +constructs name = testProperty name . (valid .) + +preserves :: (Ord b) => String -> (MS.MultiSet Int -> MS.MultiSet b) -> TestTree +preserves name f = testProperty name $ \(AMS ms) -> valid $ f ms + +preserves1 :: + (Arbitrary a, Show a, Ord b) => String -> (a -> MS.MultiSet Int -> MS.MultiSet b) -> TestTree +preserves1 name f = testProperty name $ \x (AMS ms) -> valid $ f x ms + +preserves2 :: + (Arbitrary a, Show a, Arbitrary b, Show b, Ord c) => + String -> (a -> b -> MS.MultiSet Int -> MS.MultiSet c) -> TestTree +preserves2 name f = testProperty name $ \x y (AMS ms) -> valid $ f x y ms + +preservesFun :: + ( Function a + , CoArbitrary a + , Show a + , Arbitrary b + , Show b + , Ord c + ) => + String -> + ((a -> b) -> MS.MultiSet Int -> MS.MultiSet c) -> + TestTree +preservesFun name f = testProperty name $ \fun (AMS ms) -> valid $ f (applyFun fun) ms + +preservesAllFun :: + ( Function a + , CoArbitrary a + , Show a + , Arbitrary b + , Show b + , Foldable t + , Ord c + ) => + String -> + ((a -> b) -> MS.MultiSet Int -> t (MS.MultiSet c)) -> + TestTree +preservesAllFun name f = testProperty name $ \fun (AMS ms) -> all valid $ f (applyFun fun) ms + +pair :: (a, a) -> [a] +pair (x, y) = [x, y] + +preservesAll :: + (Foldable t, Ord b) => + String -> + (MS.MultiSet Int -> t (MS.MultiSet b)) -> + TestTree +preservesAll name f = testProperty name $ \(AMS ms) -> all valid $ f ms + +preservesAll1 :: + (Arbitrary a, Show a, Foldable t, Ord b) => + String -> + (a -> MS.MultiSet Int -> t (MS.MultiSet b)) -> + TestTree +preservesAll1 name f = testProperty name $ \x (AMS ms) -> all valid $ f x ms + +preservesFun1 :: + ( Function a + , CoArbitrary a + , Show a + , Arbitrary b + , Show b + , Arbitrary c + , Show c + , Ord d + ) => + String -> + ((a -> b) -> c -> MS.MultiSet Int -> MS.MultiSet d) -> + TestTree +preservesFun1 name f = testProperty name $ \fun x (AMS ms) -> valid $ f (applyFun fun) x ms