packages feed

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 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)]