mappings 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+230/−62 lines, 7 filesdep +indexed-traversabledep ~condPVP ok
version bump matches the API change (PVP)
Dependencies added: indexed-traversable
Dependency ranges changed: cond
API changes (from Hackage documentation)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, Data.Algebra.Boolean.Boolean a) => Data.Algebra.Boolean.Boolean (Data.Mapping.OnEither k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Base.Monoid a) => GHC.Base.Monoid (Data.Mapping.OnEither k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Base.Monoid a, forall v. GHC.Classes.Ord v => GHC.Classes.Ord (n v)) => GHC.Base.Monoid (Data.Mapping.OnPair k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Base.Semigroup a) => GHC.Base.Semigroup (Data.Mapping.OnEither k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Base.Semigroup a, forall v. GHC.Classes.Ord v => GHC.Classes.Ord (n v)) => GHC.Base.Semigroup (Data.Mapping.OnPair k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Num.Num a) => GHC.Num.Num (Data.Mapping.OnEither k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord a, GHC.Num.Num a, forall v. GHC.Classes.Ord v => GHC.Classes.Ord (n v)) => GHC.Num.Num (Data.Mapping.OnPair k l m n a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, Data.Mapping.Mapping l n, GHC.Classes.Ord b, Data.Algebra.Boolean.Boolean b, forall v. GHC.Classes.Ord v => GHC.Classes.Ord (n v)) => Data.Algebra.Boolean.Boolean (Data.Mapping.OnPair k l m n b)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord a, Data.Algebra.Boolean.Boolean a) => Data.Algebra.Boolean.Boolean (Data.Mapping.OnMaybe k m a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord a, GHC.Base.Monoid a) => GHC.Base.Monoid (Data.Mapping.OnMaybe k m a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord a, GHC.Base.Semigroup a) => GHC.Base.Semigroup (Data.Mapping.OnMaybe k m a)
+ Data.Mapping: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord a, GHC.Num.Num a) => GHC.Num.Num (Data.Mapping.OnMaybe k m a)
+ Data.Mapping: instance (GHC.Classes.Ord a, GHC.Base.Monoid a) => GHC.Base.Monoid (Data.Mapping.OnBool a)
+ Data.Mapping: instance (GHC.Classes.Ord a, GHC.Base.Semigroup a) => GHC.Base.Semigroup (Data.Mapping.OnBool a)
+ Data.Mapping: instance (GHC.Classes.Ord a, GHC.Num.Num a) => GHC.Num.Num (Data.Mapping.OnBool a)
+ Data.Mapping: instance (GHC.Classes.Ord b, Data.Algebra.Boolean.Boolean b) => Data.Algebra.Boolean.Boolean (Data.Mapping.OnBool b)
+ Data.Mapping: instance (WithIndex.FoldableWithIndex k m, WithIndex.FoldableWithIndex l n) => WithIndex.FoldableWithIndex (Data.Either.Either k l) (Data.Mapping.OnEither k l m n)
+ Data.Mapping: instance WithIndex.FoldableWithIndex GHC.Types.Bool Data.Mapping.OnBool
+ Data.Mapping: instance WithIndex.FoldableWithIndex k m => WithIndex.FoldableWithIndex (GHC.Maybe.Maybe k) (Data.Mapping.OnMaybe k m)
+ Data.Mapping: instance forall k1 v (k2 :: k1). Data.Algebra.Boolean.Boolean v => Data.Algebra.Boolean.Boolean (Data.Mapping.Constant k2 v)
+ Data.Mapping: instance forall k1 v (k2 :: k1). GHC.Base.Monoid v => GHC.Base.Monoid (Data.Mapping.Constant k2 v)
+ Data.Mapping: instance forall k1 v (k2 :: k1). GHC.Base.Semigroup v => GHC.Base.Semigroup (Data.Mapping.Constant k2 v)
+ Data.Mapping: instance forall k1 v (k2 :: k1). GHC.Num.Num v => GHC.Num.Num (Data.Mapping.Constant k2 v)
+ Data.Mapping.Decision: bestSuchThat :: (Mapping k m, Ord k, Ord a, Ord v) => (v -> Bool) -> (forall w. a -> m w -> Maybe (k, w)) -> Decision k m a v -> Maybe ([(a, k)], v)
+ Data.Mapping.Decision: chunksTrue :: (Mapping k m, FoldableWithIndex k m, Ord k, Ord a) => Decision k m a Bool -> [Map a k]
+ Data.Mapping.Decision: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord (m GHC.Types.Int), GHC.Classes.Ord a, GHC.Classes.Ord v, Data.Algebra.Boolean.Boolean v) => Data.Algebra.Boolean.Boolean (Data.Mapping.Decision.Decision k m a v)
+ Data.Mapping.Decision: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord (m GHC.Types.Int), GHC.Classes.Ord a, GHC.Classes.Ord v, GHC.Base.Monoid v) => GHC.Base.Monoid (Data.Mapping.Decision.Decision k m a v)
+ Data.Mapping.Decision: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord (m GHC.Types.Int), GHC.Classes.Ord a, GHC.Classes.Ord v, GHC.Base.Semigroup v) => GHC.Base.Semigroup (Data.Mapping.Decision.Decision k m a v)
+ Data.Mapping.Decision: instance (Data.Mapping.Mapping k m, GHC.Classes.Ord (m GHC.Types.Int), GHC.Classes.Ord a, GHC.Classes.Ord v, GHC.Num.Num v) => GHC.Num.Num (Data.Mapping.Decision.Decision k m a v)
+ Data.Mapping.Decision: listTrue :: forall k m a. (Mapping k m, FoldableWithIndex k m, Ord k, Ord a) => Set a -> Decision k m a Bool -> [Map a k]
+ Data.Mapping.Decision: numberTrueGeneral :: Mapping k m => (m Integer -> Integer) -> Int -> Int -> Decision k m Int Bool -> Integer
+ Data.Mapping.MapWithDefault: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, Data.Algebra.Boolean.Boolean b) => Data.Algebra.Boolean.Boolean (Data.Mapping.MapWithDefault.MapWithDefault k b)
+ Data.Mapping.MapWithDefault: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Base.Monoid b) => GHC.Base.Monoid (Data.Mapping.MapWithDefault.MapWithDefault k b)
+ Data.Mapping.MapWithDefault: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Base.Semigroup b) => GHC.Base.Semigroup (Data.Mapping.MapWithDefault.MapWithDefault k b)
+ Data.Mapping.MapWithDefault: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Num.Num b) => GHC.Num.Num (Data.Mapping.MapWithDefault.MapWithDefault k b)
+ Data.Mapping.Piecewise: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, Data.Algebra.Boolean.Boolean b) => Data.Algebra.Boolean.Boolean (Data.Mapping.Piecewise.Piecewise k b)
+ Data.Mapping.Piecewise: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Base.Monoid b) => GHC.Base.Monoid (Data.Mapping.Piecewise.Piecewise k b)
+ Data.Mapping.Piecewise: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Base.Semigroup b) => GHC.Base.Semigroup (Data.Mapping.Piecewise.Piecewise k b)
+ Data.Mapping.Piecewise: instance (GHC.Classes.Ord k, GHC.Classes.Ord b, GHC.Num.Num b) => GHC.Num.Num (Data.Mapping.Piecewise.Piecewise k b)
- Data.Mapping.Decision: genTest :: Boolean b => a -> AlgebraWrapper (a -> Bool) (Decision Bool OnBool a) b
+ Data.Mapping.Decision: genTest :: Boolean b => a -> Decision Bool OnBool a b
- Data.Mapping.Decision: singleNode :: (Ord v, Mapping k m) => a -> m v -> Decision k m a v
+ Data.Mapping.Decision: singleNode :: (Mapping k m, Ord (m Int), Ord a, Ord v) => a -> m v -> Decision k m a v
- Data.Mapping.Decision: test :: a -> AlgebraWrapper (a -> Bool) (Decision Bool OnBool a) Bool
+ Data.Mapping.Decision: test :: a -> Decision Bool OnBool a Bool
Files
- examples/View.hs +8/−8
- mappings.cabal +7/−4
- src/Data/Mapping.hs +80/−21
- src/Data/Mapping/Decision.hs +85/−16
- src/Data/Mapping/MapWithDefault.hs +13/−5
- src/Data/Mapping/Piecewise.hs +13/−4
- test/Data/Mapping/DecisionSpec.hs +24/−4
examples/View.hs view
@@ -9,37 +9,37 @@ main :: IO () main = do do- let x = test "x" :: AlgebraWrapper (String -> Bool) (Decision Bool OnBool String) Bool+ let x = test "x" :: Decision Bool OnBool String Bool let y = test "y" putStrLn " x" putStrLn "-----"- putStrLn . debugShow $ algebraUnwrap x+ putStrLn $ debugShow x putStrLn "" putStrLn " not x" putStrLn "---------"- putStrLn . debugShow $ algebraUnwrap (not x)+ putStrLn $ debugShow (not x) putStrLn "" putStrLn " x && y" putStrLn "----------"- putStrLn . debugShow $ algebraUnwrap (x && y)+ putStrLn $ debugShow (x && y) putStrLn "" putStrLn " y && x" putStrLn "----------"- putStrLn . debugShow $ algebraUnwrap (y && x)+ putStrLn $ debugShow (y && x) putStrLn "" putStrLn " x || y" putStrLn "----------"- putStrLn . debugShow $ algebraUnwrap (x || y)+ putStrLn $ debugShow (x || y) putStrLn "" putStrLn " y || x" putStrLn "----------"- putStrLn . debugShow $ algebraUnwrap (y || x)+ putStrLn $ debugShow (y || x) putStrLn "" do@@ -49,5 +49,5 @@ let l3 = (99,100,1):(100,1,2):[(n,n+1,n+2) | n <- [1..98]] let independent = all (\(i,j) -> not (test i && test j)) l2 let maximal = all (\(i,j,k) -> test i || test j || test k) l3- let AlgebraWrapper t = independent && maximal :: AlgebraWrapper (Int -> Bool) (Decision Bool OnBool Int) Bool+ let t = independent && maximal :: Decision Bool OnBool Int Bool putStrLn $ debugShow t
mappings.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: mappings-version: 0.1.0.0+version: 0.2.0.0 synopsis: Types which represent functions k -> v description: Please read README.md on github category: Data structures@@ -41,9 +41,10 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: base >=4.16 && <4.20- , cond ==0.4.*+ , cond >=0.5.1 && <0.6 , containers >=0.6.6 && <0.8 , formatting >=7.0.0 && <7.3+ , indexed-traversable >=0.1.1 && <0.2 , partialord >=0.0.2 && <0.1 default-language: GHC2021 @@ -58,9 +59,10 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.16 && <4.20- , cond ==0.4.*+ , cond >=0.5.1 && <0.6 , containers >=0.6.6 && <0.8 , formatting >=7.0.0 && <7.3+ , indexed-traversable >=0.1.1 && <0.2 , mappings , partialord >=0.0.2 && <0.1 default-language: GHC2021@@ -80,10 +82,11 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.16 && <4.20- , cond ==0.4.*+ , cond >=0.5.1 && <0.6 , containers >=0.6.6 && <0.8 , formatting >=7.0.0 && <7.3 , hspec ==2.11.*+ , indexed-traversable >=0.1.1 && <0.2 , mappings , partialord >=0.0.2 && <0.1 default-language: GHC2021
src/Data/Mapping.hs view
@@ -16,9 +16,11 @@ #endif import Prelude hiding (not, (&&), (||)) import Data.Algebra.Boolean (Boolean(..))+import Data.Foldable.WithIndex (FoldableWithIndex(..)) import Data.Function (on) import Data.Functor.Const (Const(..)) import Data.Functor.Identity (Identity(..))+import Data.Kind (Type) import Data.Monoid (All(..)) import Data.PartialOrd import Data.Set (Set)@@ -120,18 +122,36 @@ instance Neighbourly (Constant k) where neighbours = const S.empty -{--deriving via (AlgebraWrapper k (Constant k) v)- instance (Ord v, Semigroup v) => Semigroup (Constant k v)+-- Haven't been able to make deriving via work for this one+instance (Semigroup v) => Semigroup (Constant k v) where+ Constant x <> Constant y = Constant (x <> y) -deriving via (AlgebraWrapper k (Constant k) v)- instance (Ord v, Monoid v) => Monoid (Constant k v)+-- Haven't been able to make deriving via work for this one+instance (Monoid v) => Monoid (Constant k v) where+ mempty = Constant mempty -deriving via (AlgebraWrapper k (Constant k) v)- instance (Ord v, Num v) => Num (Constant k v)--}+-- Haven't been able to make deriving via work for this one+instance (Num v) => Num (Constant k v) where+ Constant x + Constant y = Constant (x + y)+ Constant x - Constant y = Constant (x - y)+ Constant x * Constant y = Constant (x * y)+ abs (Constant x) = Constant (abs x)+ negate (Constant x) = Constant (negate x)+ signum (Constant x) = Constant (signum x)+ fromInteger = Constant . fromInteger +-- Haven't been able to make deriving via work for this one+instance (Boolean v) => Boolean (Constant k v) where+ false = Constant false+ true = Constant true+ not (Constant x) = Constant (not x)+ Constant x && Constant y = Constant (x && y)+ Constant x || Constant y = Constant (x || y)+ xor (Constant x) (Constant y) = Constant (xor x y)+ Constant x <--> Constant y = Constant (x <--> y)+ Constant x --> Constant y = Constant (x --> y) + -- | Binary decisions, as functions defined on Bool data OnBool a = OnBool { onFalse :: a,@@ -141,6 +161,9 @@ instance Foldable OnBool where foldMap p (OnBool x y) = p x <> p y +instance FoldableWithIndex Bool OnBool where+ ifoldMap p (OnBool x y) = p False x <> p True y+ instance Traversable OnBool where traverse f (OnBool x y) = liftA2 OnBool (f x) (f y) @@ -161,11 +184,17 @@ | x == y = S.empty | otherwise = S.singleton (x, y) -{---- May work with a future version of cond+deriving via (AlgebraWrapper Bool OnBool a)+ instance (Ord a, Semigroup a) => Semigroup (OnBool a)++deriving via (AlgebraWrapper Bool OnBool a)+ instance (Ord a, Monoid a) => Monoid (OnBool a)++deriving via (AlgebraWrapper Bool OnBool a)+ instance (Ord a, Num a) => Num (OnBool a)+ deriving via (AlgebraWrapper Bool OnBool b) instance (Ord b, Boolean b) => Boolean (OnBool b)--} -- | Maps on Maybe@@ -177,6 +206,9 @@ instance Foldable m => Foldable (OnMaybe k m) where foldMap f (OnMaybe x a) = f x <> foldMap f a +instance FoldableWithIndex k m => FoldableWithIndex (Maybe k) (OnMaybe k m) where+ ifoldMap f (OnMaybe x a) = f Nothing x <> ifoldMap (f . Just) a+ instance Mapping k m => Mapping (Maybe k) (OnMaybe k m) where cst x = OnMaybe x $ cst x mmap p (OnMaybe x a) = OnMaybe (p x) (mmap p a)@@ -189,7 +221,19 @@ merge h (OnMaybe x a) (OnMaybe y b) = OnMaybe (h x y) (merge h a b) mergeA h (OnMaybe x a) (OnMaybe y b) = liftA2 OnMaybe (h x y) (mergeA h a b) +deriving via (AlgebraWrapper (Maybe k) (OnMaybe k m) a)+ instance (Mapping k m, Ord a, Semigroup a) => Semigroup (OnMaybe k m a) +deriving via (AlgebraWrapper (Maybe k) (OnMaybe k m) a)+ instance (Mapping k m, Ord a, Monoid a) => Monoid (OnMaybe k m a)++deriving via (AlgebraWrapper (Maybe k) (OnMaybe k m) a)+ instance (Mapping k m, Ord a, Num a) => Num (OnMaybe k m a)++deriving via (AlgebraWrapper (Maybe k) (OnMaybe k m) a)+ instance (Mapping k m, Ord a, Boolean a) => Boolean (OnMaybe k m a)++ -- | Maps on Either data OnEither k l m n v = OnEither { onLeft :: m v,@@ -199,6 +243,9 @@ instance (Foldable m, Foldable n) => Foldable (OnEither k l m n) where foldMap p (OnEither f g) = foldMap p f <> foldMap p g +instance (FoldableWithIndex k m, FoldableWithIndex l n) => FoldableWithIndex (Either k l) (OnEither k l m n) where+ ifoldMap p (OnEither f g) = ifoldMap (p . Left) f <> ifoldMap (p . Right) g+ instance (Mapping k m, Mapping l n) => Mapping (Either k l) (OnEither k l m n) where@@ -214,13 +261,19 @@ mergeA h (OnEither f1 g1) (OnEither f2 g2) = liftA2 OnEither (mergeA h f1 f2) (mergeA h g1 g2) merge h (OnEither f1 g1) (OnEither f2 g2) = OnEither (merge h f1 f2) (merge h g1 g2) -{---- May work with a future version of cond-deriving via (AlgebraWrapper (Either k l) (OnEither k l m n) b)- instance (Mapping k m, Mapping l n, Ord b, Boolean b) => Boolean (OnEither k l m n b)--}+deriving via (AlgebraWrapper (Either k l) (OnEither k l (m :: Type -> Type) n) a)+ instance (Mapping k m, Mapping l n, Ord a, Semigroup a) => Semigroup (OnEither k l m n a) +deriving via (AlgebraWrapper (Either k l) (OnEither k l (m :: Type -> Type) n) a)+ instance (Mapping k m, Mapping l n, Ord a, Monoid a) => Monoid (OnEither k l m n a) +deriving via (AlgebraWrapper (Either k l) (OnEither k l (m :: Type -> Type) n) a)+ instance (Mapping k m, Mapping l n, Ord a, Num a) => Num (OnEither k l m n a)++deriving via (AlgebraWrapper (Either k l) (OnEither k l (m :: Type -> Type) n) a)+ instance (Mapping k m, Mapping l n, Ord a, Boolean a) => Boolean (OnEither k l m n a)++ -- | Maps on pairs newtype OnPair k l m n v = OnPair { asComposite :: m (n v)@@ -241,11 +294,17 @@ mergeA h (OnPair f) (OnPair g) = OnPair <$> mergeA (mergeA h) f g merge h (OnPair f) (OnPair g) = OnPair $ merge (merge h) f g -{---- May work with a future version of cond-deriving via (AlgebraWrapper (k, l) (OnPair k l m n) b)- instance (Mapping k m, Mapping l n, Ord b, Boolean b) => Boolean (OnPair k l m n b)--}+deriving via (AlgebraWrapper (k, l) (OnPair k l (m :: Type -> Type) (n :: Type -> Type)) a)+ instance (Mapping k m, Mapping l n, Ord a, Semigroup a, forall v. Ord v => Ord (n v)) => Semigroup (OnPair k l m n a)++deriving via (AlgebraWrapper (k, l) (OnPair k l (m :: Type -> Type) (n :: Type -> Type)) a)+ instance (Mapping k m, Mapping l n, Ord a, Monoid a, forall v. Ord v => Ord (n v)) => Monoid (OnPair k l m n a)++deriving via (AlgebraWrapper (k, l) (OnPair k l (m :: Type -> Type) (n :: Type -> Type)) a)+ instance (Mapping k m, Mapping l n, Ord a, Num a, forall v. Ord v => Ord (n v)) => Num (OnPair k l m n a)++deriving via (AlgebraWrapper (k, l) (OnPair k l (m :: Type -> Type) (n :: Type -> Type)) b)+ instance (Mapping k m, Mapping l n, Ord b, Boolean b, forall v. Ord v => Ord (n v)) => Boolean (OnPair k l m n b) -- Is the first a subset of the second?
src/Data/Mapping/Decision.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP,+ DerivingVia, MultiParamTypeClasses, OverloadedStrings, RankNTypes,@@ -38,12 +39,15 @@ #else import Control.Applicative (liftA2) #endif+import Control.Monad ((<=<)) import Data.Algebra.Boolean (Boolean(..))+import Data.Bifunctor (first) import Data.Bijection (Bij) import qualified Data.Bijection as B import Data.Bits (complement) import Data.Bool (bool) import Data.Foldable (toList)+import Data.Foldable.WithIndex (FoldableWithIndex(..)) import Data.Functor.Identity (Identity(..)) import Data.IntSet (IntSet) import qualified Data.IntSet as IS@@ -54,6 +58,7 @@ import qualified Data.Set as S import Data.Map.Strict (Map) import qualified Data.Map.Strict as M+import qualified Data.Map.Merge.Strict as M import Data.Mapping.Util (insertIfAbsent) import Formatting ((%)) import qualified Formatting as F@@ -177,14 +182,51 @@ in (b, combine $ mmap (p b) m) in p Nothing . decisionRecurse f g --- | How many values are True in a binary decision diagram with integer leaves?-numberTrue :: Int -> Int -> Decision Bool OnBool Int Bool -> Integer-numberTrue x0 x1 = let+-- | How many values are true in a decision diagram with integer leaves?+numberTrueGeneral :: Mapping k m => (m Integer -> Integer) -> Int -> Int -> Decision k m Int Bool -> Integer+numberTrueGeneral g x0 x1 = let f a = if a then 1 else 0- g (OnBool u v) = u + v in generalCounts subtract x0 x1 f g +-- | How many values are True in a binary decision diagram with integer leaves?+numberTrue :: Int -> Int -> Decision Bool OnBool Int Bool -> Integer+numberTrue = numberTrueGeneral sum +-- | Assignments of variables that result in True+chunksTrue :: (Mapping k m, FoldableWithIndex k m, Ord k, Ord a) => Decision k m a Bool -> [Map a k]+chunksTrue = let+ f False = []+ f True = [M.empty]+ g a = ifoldMap (\x -> fmap (M.insert a x))+ in decisionRecurse f g++-- | All true values (may be a very long list even for reasonable Decisions)+listTrue :: forall k m a.+ (Mapping k m,+ FoldableWithIndex k m,+ Ord k,+ Ord a)+ => Set a+ -> Decision k m a Bool+ -> [Map a k]+listTrue s = let+ m = M.fromSet (const ()) s+ u = ifoldMap (\i _ -> [i]) $ cst @k @m ()+ fillIn = let+ onL = M.traverseMissing (\_ () -> u)+ onR = M.mapMissing (const (error "Expected a key"))+ onB = M.zipWithMatched (\_ () -> id)+ in M.mergeA onL onR onB+ in fillIn m <=< chunksTrue++-- | What is the best assignment of keys to values resulting in a+-- value on which `p` is `True`?+bestSuchThat :: (Mapping k m, Ord k, Ord a, Ord v) => (v -> Bool) -> (forall w. a -> m w -> Maybe (k, w)) -> Decision k m a v -> Maybe ([(a,k)], v)+bestSuchThat p q = let+ f x = if p x then Just ([], x) else Nothing+ g i = uncurry (\x -> fmap (first ((i,x):))) <=< q i+ in decisionRecurse f g+ -- | Build a sequence from key-value pairs; we take on trust that all -- values are represented once. fromKeyVals :: (Foldable f) => f (Int,a) -> Seq a@@ -201,7 +243,12 @@ emptyBuilder :: Builder o k m a v emptyBuilder = Builder M.empty M.empty M.empty -addLeaf :: (Ord o, Ord v) => v -> o -> Builder o k m a v -> Builder o k m a v+addLeaf :: (Ord o,+ Ord v)+ => v+ -> o+ -> Builder o k m a v+ -> Builder o k m a v addLeaf x y (Builder l m o) = let i = complement (M.size l) (j, s) = insertIfAbsent x i l@@ -210,7 +257,15 @@ Nothing -> Builder l m o' Just l' -> Builder l' m o' -addNode :: (Ord o, Ord (m Int), Ord a, Mapping k m) => a -> m o -> o -> Builder o k m a v -> Builder o k m a v+addNode :: (Ord o,+ Ord (m Int),+ Ord a,+ Mapping k m)+ => a+ -> m o+ -> o+ -> Builder o k m a v+ -> Builder o k m a v addNode r a y (Builder l m o) = let b = mmap (o M.!) a in case isConst b of@@ -248,27 +303,26 @@ buildDecision :: Ord o => o -> Builder o k m a v -> Decision k m a v buildDecision s b@(Builder _ _ o) = Decision (buildBase b) (o M.! s) -singleNode :: (Ord v, Mapping k m) => a -> m v -> Decision k m a v+-- | A decision tree based on a single decision+singleNode :: (Mapping k m, Ord (m Int), Ord a, Ord v) => a -> m v -> Decision k m a v singleNode r n = let- f b x = addLeaf x x b- Builder l _ o = foldl f emptyBuilder n- m = M.singleton (Node r $ mmap (o M.!) n) 0- in Decision (buildBase $ Builder l m o) 0+ f b x = addLeaf x (Just x) b+ d = addNode r (mmap Just n) Nothing $ foldl f emptyBuilder n+ in buildDecision Nothing d -- | A building block for BDD's - tests if a variable is true------ Again, would be nice to remove the AlgebraWrapper-genTest :: Boolean b => a -> AlgebraWrapper (a -> Bool) (Decision Bool OnBool a) b+genTest :: Boolean b => a -> Decision Bool OnBool a b genTest r = let l = Q.fromList [false, true] m = pure . Node r $ OnBool (-1) (-2) s = 0- in AlgebraWrapper $ Decision (Base l m) s+ in Decision (Base l m) s -- | Test if a variable is true (specialised to `Bool`)-test :: a -> AlgebraWrapper (a -> Bool) (Decision Bool OnBool a) Bool+test :: a -> Decision Bool OnBool a Bool test = genTest + -- | Rapidly take the conjunction of the inputs buildAll :: Mapping k m => Map a (m Bool) -> Decision k m a Bool buildAll d = let@@ -514,6 +568,19 @@ mergeA p (Decision b1 s1) (Decision b2 s2) = buildDecision (s1, s2) <$> baseMergeA p b1 b2 (S.singleton (s1, s2)) +deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)+ instance (Mapping k m, Ord (m Int), Ord a, Ord v, Semigroup v) => Semigroup (Decision k m a v)++deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)+ instance (Mapping k m, Ord (m Int), Ord a, Ord v, Monoid v) => Monoid (Decision k m a v)++deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)+ instance (Mapping k m, Ord (m Int), Ord a, Ord v, Num v) => Num (Decision k m a v)++deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)+ instance (Mapping k m, Ord (m Int), Ord a, Ord v, Boolean v) => Boolean (Decision k m a v)++ -- | Attempt to extend to a bijection checkBijection :: (Eq a, Eq v, Mapping k m) => Base k m a v -> Base k m a v -> Bij -> Maybe Bij checkBijection (Base l1 m1) (Base l2 m2) = let@@ -581,3 +648,5 @@ in foldMap g n in v |> (here <> there) in Q.index (foldl f Q.empty m) s++
src/Data/Mapping/MapWithDefault.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE+ CPP,+ DerivingVia+ #-} module Data.Mapping.MapWithDefault where @@ -6,6 +9,7 @@ #else import Control.Applicative (liftA2) #endif+import Data.Algebra.Boolean import Data.List (foldl', groupBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M@@ -75,7 +79,7 @@ in MapWithDefault c $ combine f g -- | This instance assumes that k is unbounded-+-- -- It would be possible to do something valid in greater generality (for -- example, a MaybeBounded class), which might be a good idea. instance (Enum k, Eq k) => Neighbourly (MapWithDefault k) where@@ -84,10 +88,14 @@ d l = zip ([a] <> l) (l <> [a]) in S.fromList . concatMap (d . fmap snd) . groupBy c $ M.toAscList f +deriving via (AlgebraWrapper k (MapWithDefault k) b)+ instance (Ord k, Ord b, Semigroup b) => Semigroup (MapWithDefault k b) +deriving via (AlgebraWrapper k (MapWithDefault k) b)+ instance (Ord k, Ord b, Monoid b) => Monoid (MapWithDefault k b) -{---- May work with a future version of cond deriving via (AlgebraWrapper k (MapWithDefault k) b)+ instance (Ord k, Ord b, Num b) => Num (MapWithDefault k b)++deriving via (AlgebraWrapper k (MapWithDefault k) b) instance (Ord k, Ord b, Boolean b) => Boolean (MapWithDefault k b)--}
src/Data/Mapping/Piecewise.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE+ CPP,+ DerivingVia+ #-} module Data.Mapping.Piecewise where @@ -7,6 +10,7 @@ import Control.Applicative (liftA2) #endif import Control.Applicative (liftA3)+import Data.Algebra.Boolean import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -135,9 +139,14 @@ v = values m in S.fromList $ zip v (tail v) +deriving via (AlgebraWrapper k (Piecewise k) b)+ instance (Ord k, Ord b, Semigroup b) => Semigroup (Piecewise k b) -{---- May work with a future version of cond deriving via (AlgebraWrapper k (Piecewise k) b)+ instance (Ord k, Ord b, Monoid b) => Monoid (Piecewise k b)++deriving via (AlgebraWrapper k (Piecewise k) b)+ instance (Ord k, Ord b, Num b) => Num (Piecewise k b)++deriving via (AlgebraWrapper k (Piecewise k) b) instance (Ord k, Ord b, Boolean b) => Boolean (Piecewise k b)--}
test/Data/Mapping/DecisionSpec.hs view
@@ -11,10 +11,10 @@ boolAct :: Ord a- => AlgebraWrapper (a -> Bool) (Decision Bool OnBool a) Bool+ => Decision Bool OnBool a Bool -> [a] -> Bool-boolAct (AlgebraWrapper a) s = act a (`S.member` S.fromList s)+boolAct a s = act a (`S.member` S.fromList s) spec :: Spec@@ -75,18 +75,38 @@ it "y || x true on {x,y}" $ do boolAct (y || x) ["x", "y"] `shouldBe` True + describe "Check of listTrue" $ do++ let x0y0 = M.fromList [("x", False), ("y", False)]+ let x0y1 = M.fromList [("x", False), ("y", True)]+ let x1y0 = M.fromList [("x", True), ("y", False)]+ let x1y1 = M.fromList [("x", True), ("y", True)]++ it "Should work on &&" $ do+ S.fromList (listTrue (S.fromList ["x", "y"]) (algebraUnwrap (x && y)))+ `shouldBe` S.fromList [x1y1]+ it "Should work on ||" $ do+ S.fromList (listTrue (S.fromList ["x", "y"]) (algebraUnwrap (x || y)))+ `shouldBe` S.fromList [x0y1, x1y0, x1y1]+ it "Should work on not (1)" $ do+ S.fromList (listTrue (S.fromList ["x", "y"]) (algebraUnwrap (not x)))+ `shouldBe` S.fromList [x0y0, x0y1]+ it "Should work on not (2)" $ do+ S.fromList (listTrue (S.fromList ["x", "y"]) (algebraUnwrap (not y)))+ `shouldBe` S.fromList [x0y0, x1y0]+ describe "Properties of independent sets in C_100" $ do let l2 = (100,1):[(n,n+1) | n <- [1..99]] let l3 = (99,100,1):(100,1,2):[(n,n+1,n+2) | n <- [1..98]] let independent = all (\(i,j) -> not (test i && test j)) l2 let maximal = all (\(i,j,k) -> test i || test j || test k) l3- let AlgebraWrapper t = independent && maximal+ let t = independent && maximal -- Mentioned in Knuth it "should have the right count" $ do numberTrue (1::Int) 100 t `shouldBe` 1630580875002- + describe "Decision trees for monomial divisibility" $ do let xy2 = M.fromList [("X", 1::Int), ("Y", 2)]