diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## [0.4.0.0] - 2026-02-18 + +* Constraint polymorphism +* Rewrite of the `Data.Mapping.Decision` module + ## [0.3.1.0] - 2024-05-20 * Support for GHC 9.10 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,30 +1,21 @@ # Mappings -## What's it do? - -This package does two jobs: - -* It offers a general typeclass [`Mapping`](src/Data/Mapping.hs) for - types which represent functions `k -> v` (for fixed `k`, but - arbitrary ordered `v`). - - There are some fairly straightforward examples which build up - mappings where `k` is `Either`, or a pair, or `Maybe`, or `Bool`. - -* Three less trivial implementations are provided: - - * [Decision diagrams](src/Data/Mapping/Decision.hs), with nodes - which may themselves be an arbitrary `Mapping` (there is some - code for viewing these in the `examples` directory); +This package offers a general typeclass +[`Mapping`](src/Data/Mapping.hs) for data structures which represent +functions `k -> v` (possibly for fixed `k`, but arbitrary ordered +`v`). - * [Piecewise constant maps](src/Data/Mapping/Piecewise.hs) on an - ordered domain `k`; +There are some fairly straightforward examples: constant mappings, and +those which build up mappings where `k` is `Either`, or a pair, or +`Maybe`, or `Bool`. - * [Maps equipped with a default value](src/Data/Mapping/MapWithDefault.hs). +Three less trivial implementations are provided: +* [Decision diagrams](src/Data/Mapping/Decision.hs), with nodes + which may themselves be an arbitrary `Mapping`; -## Why did I bother? +* [Piecewise constant maps](src/Data/Mapping/Piecewise.hs) on an + ordered domain `k`; -The aim is to use decision diagrams with nodes that are piecewise -constant maps to store monomials for Grobner basis algorithms. +* [Maps equipped with a default value](src/Data/Mapping/MapWithDefault.hs). diff --git a/examples/View.hs b/examples/View.hs --- a/examples/View.hs +++ b/examples/View.hs @@ -43,10 +43,10 @@ putStrLn "" do - putStrLn " independent sets in C_100" + putStrLn " independent sets in C_10" putStrLn "-----------------------------" - 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 l2 = (10,1):[(n,n+1) | n <- [1..9]] + let l3 = (9,10,1):(10,1,2):[(n,n+1,n+2) | n <- [1..8]] 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 t = independent && maximal :: Decision Bool OnBool Int Bool diff --git a/mappings.cabal b/mappings.cabal --- a/mappings.cabal +++ b/mappings.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: mappings -version: 0.3.3.0 +version: 0.4.0.0 synopsis: Types which represent functions k -> v description: A typeclass and a number of implementations; please read README.md on github category: Data structures @@ -13,7 +13,7 @@ bug-reports: https://github.com/jcranch/mapping/issues author: James Cranch maintainer: j.d.cranch@sheffield.ac.uk -copyright: 2023-25 James Cranch +copyright: 2023-26 James Cranch license: BSD-3-Clause build-type: Simple extra-doc-files: @@ -26,7 +26,6 @@ library exposed-modules: - Data.Bijection Data.Mapping Data.Mapping.Decision Data.Mapping.MapWithDefault @@ -40,12 +39,14 @@ src ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: - base >=4.16 && <4.22 + base >=4.16 && <4.23 , cond >=0.5.1 && <0.6 - , containers >=0.6.5 && <0.8 + , containers >=0.6.5 && <0.9 , formatting >=7.0.0 && <7.3 , indexed-traversable >=0.1.1 && <0.2 , partialord >=0.0.2 && <0.2 + , transformers ==0.6.* + , trivial-constraint ==0.7.* default-language: GHC2021 executable view @@ -58,13 +59,15 @@ examples ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.16 && <4.22 + base >=4.16 && <4.23 , cond >=0.5.1 && <0.6 - , containers >=0.6.5 && <0.8 + , containers >=0.6.5 && <0.9 , formatting >=7.0.0 && <7.3 , indexed-traversable >=0.1.1 && <0.2 , mappings , partialord >=0.0.2 && <0.2 + , transformers ==0.6.* + , trivial-constraint ==0.7.* default-language: GHC2021 test-suite mapping @@ -83,12 +86,14 @@ build-tool-depends: hspec-discover:hspec-discover ==2.11.* build-depends: - base >=4.16 && <4.22 + base >=4.16 && <4.23 , cond >=0.5.1 && <0.6 - , containers >=0.6.5 && <0.8 + , containers >=0.6.5 && <0.9 , formatting >=7.0.0 && <7.3 , hspec ==2.11.* , indexed-traversable >=0.1.1 && <0.2 , mappings , partialord >=0.0.2 && <0.2 + , transformers ==0.6.* + , trivial-constraint ==0.7.* default-language: GHC2021 diff --git a/src/Data/Bijection.hs b/src/Data/Bijection.hs deleted file mode 100644 --- a/src/Data/Bijection.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.Bijection where - -#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) -#else -import Control.Applicative (liftA2) -#endif -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IM -import qualified Data.IntMap.Merge.Strict as IM - - -compatibleInsert :: (Eq a) => Int -> a -> IntMap a -> Maybe (IntMap a) -compatibleInsert x y = let - f (Just z) = if y == z then Just (Just y) else Nothing - f Nothing = Just (Just y) - in IM.alterF f x - -compatibleUnion :: (Eq a) => IntMap a -> IntMap a -> Maybe (IntMap a) -compatibleUnion = let - f _ x y = if x == y then Just x else Nothing - in IM.mergeA IM.preserveMissing IM.preserveMissing (IM.zipWithAMatched f) - -data Bij = Bij { - rightwards :: IntMap Int, - leftwards :: IntMap Int -} deriving (Eq, Ord) - -empty :: Bij -empty = Bij IM.empty IM.empty - -singleton :: Int -> Int -> Bij -singleton x y = Bij (IM.singleton x y) (IM.singleton y x) - -match :: Int -> Int -> Bij -> Maybe Bij -match x y (Bij r l) = liftA2 Bij (compatibleInsert x y r) (compatibleInsert y x l) - -combine :: Bij -> Bij -> Maybe Bij -combine (Bij r1 l1) (Bij r2 l2) = liftA2 Bij (compatibleUnion r1 r2) (compatibleUnion l1 l2) - -pop :: Bij -> Maybe ((Int, Int), Bij) -pop (Bij r l) = case IM.minViewWithKey r of - Nothing -> Nothing - Just ((i, j), r') -> Just ((i, j), Bij r' (IM.delete j l)) - --- | Don't check consistency, just take a union -unsafeUnion :: Bij -> Bij -> Bij -unsafeUnion (Bij r1 l1) (Bij r2 l2) = Bij (IM.union r1 r2) (IM.union l1 l2) - --- | Don't check consistency, just take a diff -unsafeDifference :: Bij -> Bij -> Bij -unsafeDifference (Bij r1 l1) (Bij r2 l2) = Bij (IM.difference r1 r2) (IM.difference l1 l2) - - --- | A newtype, just to get a partial monoidal structure representing consistent --- unions. -newtype MaybeBij = MaybeBij { - getMaybeBij :: Maybe Bij -} deriving (Eq, Ord) - -instance Semigroup MaybeBij where - MaybeBij Nothing <> _ = MaybeBij Nothing - _ <> MaybeBij Nothing = MaybeBij Nothing - MaybeBij (Just a) <> MaybeBij (Just b) = MaybeBij (combine a b) - -instance Monoid MaybeBij where - mempty = MaybeBij (Just empty) - -msingleton :: Int -> Int -> MaybeBij -msingleton i j = MaybeBij . Just $ singleton i j - - -closeBijection :: (Int -> Int -> Maybe Bij) -> Bij -> Maybe Bij -closeBijection f s = let - inner a n = case pop n of - Nothing -> Just a - Just ((i,j), n') -> case f i j of - Nothing -> Nothing - Just b -> case combine a b of - Nothing -> Nothing - Just a' -> inner a' (unsafeUnion n' (unsafeDifference b a)) - in inner s s diff --git a/src/Data/Mapping.hs b/src/Data/Mapping.hs --- a/src/Data/Mapping.hs +++ b/src/Data/Mapping.hs @@ -1,27 +1,23 @@ -{-# LANGUAGE - CPP, - DeriveFunctor, - DerivingVia, - FlexibleInstances, - FunctionalDependencies, - QuantifiedConstraints, - ScopedTypeVariables - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Mapping where -#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) -#else -import Control.Applicative (liftA2) -#endif import Prelude hiding (not, (&&), (||)) -import Data.Algebra.Boolean (Boolean(..)) +import Data.Algebra.Boolean (Boolean(..), AllB(..)) +import Data.Bool (bool) +import Data.Constraint.Trivial (Unconstrained) 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.Kind (Constraint, Type) import Data.PartialOrd import Data.Set (Set) import qualified Data.Set as S @@ -34,39 +30,86 @@ -- values that appear. Given that a value can be associated with a -- very large collection of keys, the only folds that normally make -- sense are those over idempotent monoids. -class Foldable m => Mapping k m | m -> k where +class (Foldable m, forall x. c x => c (m x)) => Mapping (c :: Type -> Constraint) (k :: Type) (m :: Type -> Type) | m -> k, m -> c where + + -- | Form a constant Mapping cst :: v -> m v + -- | Use a Mapping as a function act :: m v -> k -> v - isConst :: Ord v => m v -> Maybe v + -- | Is the Mapping a constant (and if so with what value)? + isConst :: c v => m v -> Maybe v - mtraverse :: (Applicative f, Ord v) => (u -> f v) -> m u -> f (m v) + -- | A constrained Traverse + mtraverse :: (Applicative f, c v) => (u -> f v) -> m u -> f (m v) - mmap :: Ord v => (u -> v) -> m u -> m v + -- | A constrained Functor + mmap :: c v => (u -> v) -> m u -> m v mmap p = runIdentity . mtraverse (Identity . p) - mergeA :: (Applicative f, Ord w) => (u -> v -> f w) -> m u -> m v -> f (m w) + -- | Merge two Mappings, valued in an applicative + mergeA :: (Applicative f, c w) => (u -> v -> f w) -> m u -> m v -> f (m w) - merge :: Ord w => (u -> v -> w) -> m u -> m v -> m w + -- | Merge two Mappings + merge :: c w => (u -> v -> w) -> m u -> m v -> m w merge p m n = let q x y = Identity $ p x y in runIdentity $ mergeA q m n + -- | Merge three Mappings + merge3 :: c x + => (u -> v -> w -> x) + -> m u -> m v -> m w -> m x --- | A simultaneous foldMap over two maps -pairMappings :: forall k m u v a. (Mapping k m, Monoid a) => (u -> v -> a) -> m u -> m v -> a -pairMappings p m n = let - q :: u -> v -> Const a Void - q x y = Const $ p x y - in getConst (mergeA q m n) + -- | Merge three Mappings + mergeA3 :: (Applicative f, c x) + => (u -> v -> w -> f x) + -> m u -> m v -> m w -> f (m x) + -- | A simultaneous foldMap over two maps; pairMappings is to + -- foldMap as mmerge is to mmap + pairMappings :: forall a u v. (Monoid a, c Void) => (u -> v -> a) -> m u -> m v -> a + pairMappings p m n = let + q :: u -> v -> Const a Void + q x y = Const $ p x y + in getConst (mergeA q m n) + + -- | A monad-like structure + bind :: (c u, c v, Ord u, c (Either v u)) => (u -> m v) -> m u -> m v + bind f m = let + start [] = error "bind: expected some values" + start [x] = f x + start (x:xs) = let + p y z = if y == x then Left z else Right y + in continue xs $ merge p m (f x) + continue [] _ = error "bind: expected more values" + continue [x] n = let + p (Left z) _ = z + p (Right _) z = z + in merge p n (f x) + continue (x:xs) n = let + p (Left z) _ = Left z + p (Right y) z = if y == x then Left z else Right y + in continue xs $ merge p n (f x) + in start . S.toList $ values m + + +-- | This commonly-used function is the reason why we have three-way +-- merges in the typeclass +boolBind :: (Mapping c k m, c v) => m v -> m v -> m Bool -> m v +boolBind = merge3 bool + + +values :: (Mapping c k m, Ord v) => m v -> Set v +values = foldMap S.singleton + + -- | What values can these two take simultaneously? -mutualValues :: (Ord u, Ord v, Mapping k m) => m u -> m v -> Set (u, v) +mutualValues :: (Ord u, Ord v, c Void, Mapping c k m) => m u -> m v -> Set (u, v) mutualValues = pairMappings $ curry S.singleton - -- | A class representing data structures which have a concept of neighbouring -- values class Neighbourly m where @@ -76,15 +119,15 @@ -- | A wrapper for representing pointwise algebraic structures on a Mapping -- -- Eventually would like to use this only for "deriving via" -newtype AlgebraWrapper k m a = AlgebraWrapper { algebraUnwrap :: m a } +newtype AlgebraWrapper (c :: Type -> Constraint) k m a = AlgebraWrapper { algebraUnwrap :: m a } -instance (Mapping k m, Ord a, Semigroup a) => Semigroup (AlgebraWrapper k m a) where +instance (Mapping c k m, c a, Semigroup a) => Semigroup (AlgebraWrapper c k m a) where (<>) = (AlgebraWrapper .) . merge (<>) `on` algebraUnwrap -instance (Mapping k m, Ord a, Monoid a) => Monoid (AlgebraWrapper k m a) where +instance (Mapping c k m, c a, Monoid a) => Monoid (AlgebraWrapper c k m a) where mempty = AlgebraWrapper $ cst mempty -instance (Mapping k m, Ord a, Num a) => Num (AlgebraWrapper k m a) where +instance (Mapping c k m, c a, Num a) => Num (AlgebraWrapper c k m a) where (+) = (AlgebraWrapper .) . merge (+) `on` algebraUnwrap (-) = (AlgebraWrapper .) . merge (-) `on` algebraUnwrap (*) = (AlgebraWrapper .) . merge (*) `on` algebraUnwrap @@ -93,7 +136,7 @@ negate = AlgebraWrapper . mmap negate . algebraUnwrap signum = AlgebraWrapper . mmap signum . algebraUnwrap -instance (Mapping k m, Ord a, Boolean a) => Boolean (AlgebraWrapper k m a) where +instance (Mapping c k m, c a, Boolean a) => Boolean (AlgebraWrapper c k m a) where true = AlgebraWrapper $ cst true false = AlgebraWrapper $ cst false not = AlgebraWrapper . mmap not . algebraUnwrap @@ -104,20 +147,26 @@ (<-->) = (AlgebraWrapper .) . merge (<-->) `on` algebraUnwrap + -- | Constant functions (on any domain) newtype Constant k v = Constant { constantValue :: v } + deriving (Eq, Ord) instance Foldable (Constant k) where foldMap f (Constant a) = f a -instance Mapping k (Constant k) where +instance Mapping Unconstrained k (Constant k) where cst = Constant act (Constant x) _ = x + isConst (Constant x) = Just x mmap f (Constant x) = Constant $ f x mtraverse f (Constant x) = Constant <$> f x - isConst (Constant x) = Just x merge f (Constant x) (Constant y) = Constant $ f x y + merge3 f (Constant x) (Constant y) (Constant z) = Constant $ f x y z mergeA f (Constant x) (Constant y) = Constant <$> f x y + mergeA3 f (Constant x) (Constant y) (Constant z) = Constant <$> f x y z + pairMappings f (Constant x) (Constant y) = f x y + bind f (Constant x) = f x instance Neighbourly (Constant k) where neighbours = const S.empty @@ -152,6 +201,7 @@ Constant x --> Constant y = Constant (x --> y) + -- | Binary decisions, as functions defined on Bool data OnBool a = OnBool { onFalse :: a, @@ -167,49 +217,57 @@ instance Traversable OnBool where traverse f (OnBool x y) = liftA2 OnBool (f x) (f y) -instance Mapping Bool OnBool where +instance Mapping Eq Bool OnBool where cst x = OnBool x x - mmap = fmap - mtraverse = traverse act (OnBool x _) False = x act (OnBool _ x) True = x isConst (OnBool x y) | x == y = Just x | otherwise = Nothing - mergeA h (OnBool x1 y1) (OnBool x2 y2) = liftA2 OnBool (h x1 x2) (h y1 y2) - merge h (OnBool x1 y1) (OnBool x2 y2) = OnBool (h x1 x2) (h y1 y2) + mmap = fmap + mtraverse = traverse + mergeA h (OnBool x1 y1) (OnBool x2 y2) = + liftA2 OnBool (h x1 x2) (h y1 y2) + merge h (OnBool x1 y1) (OnBool x2 y2) = + OnBool (h x1 x2) (h y1 y2) + mergeA3 h (OnBool x1 y1) (OnBool x2 y2) (OnBool x3 y3) = + liftA2 OnBool (h x1 x2 x3) (h y1 y2 y3) + merge3 h (OnBool x1 y1) (OnBool x2 y2) (OnBool x3 y3) = + OnBool (h x1 x2 x3) (h y1 y2 y3) + pairMappings p (OnBool x1 y1) (OnBool x2 y2) = p x1 x2 <> p y1 y2 + bind f (OnBool u v) = OnBool (onFalse (f u)) (onTrue (f v)) instance Neighbourly OnBool where neighbours (OnBool x y) | x == y = S.empty | otherwise = S.singleton (x, y) -deriving via (AlgebraWrapper Bool OnBool a) - instance (Ord a, Semigroup a) => Semigroup (OnBool a) +deriving via (AlgebraWrapper Eq Bool OnBool a) + instance (Eq a, Semigroup a) => Semigroup (OnBool a) -deriving via (AlgebraWrapper Bool OnBool a) - instance (Ord a, Monoid a) => Monoid (OnBool a) +deriving via (AlgebraWrapper Eq Bool OnBool a) + instance (Eq a, Monoid a) => Monoid (OnBool a) -deriving via (AlgebraWrapper Bool OnBool a) - instance (Ord a, Num a) => Num (OnBool a) +deriving via (AlgebraWrapper Eq Bool OnBool a) + instance (Eq a, Num a) => Num (OnBool a) -deriving via (AlgebraWrapper Bool OnBool b) - instance (Ord b, Boolean b) => Boolean (OnBool b) +deriving via (AlgebraWrapper Eq Bool OnBool b) + instance (Eq b, Boolean b) => Boolean (OnBool b) -- | Maps on Maybe -data OnMaybe k m v = OnMaybe { +data OnMaybe c k m v = OnMaybe { onNothing :: v, onJust :: m v -} +} deriving (Eq, Ord) -instance Foldable m => Foldable (OnMaybe k m) where +instance Foldable m => Foldable (OnMaybe c k m) where foldMap f (OnMaybe x a) = f x <> foldMap f a -instance FoldableWithIndex k m => FoldableWithIndex (Maybe k) (OnMaybe k m) where +instance FoldableWithIndex k m => FoldableWithIndex (Maybe k) (OnMaybe c 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 +instance (forall x. c x => Eq x, forall x. c x => c (OnMaybe c k m x), Mapping c k m) => Mapping c (Maybe k) (OnMaybe c k m) where cst x = OnMaybe x $ cst x mmap p (OnMaybe x a) = OnMaybe (p x) (mmap p a) mtraverse p (OnMaybe x a) = liftA2 OnMaybe (p x) (mtraverse p a) @@ -218,37 +276,48 @@ isConst (OnMaybe x a) = do y <- isConst a if x == y then Just x else Nothing - 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) + 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) + merge3 h (OnMaybe x a) (OnMaybe y b) (OnMaybe z c) = + OnMaybe (h x y z) (merge3 h a b c) + mergeA3 h (OnMaybe x a) (OnMaybe y b) (OnMaybe z c) = + liftA2 OnMaybe (h x y z) (mergeA3 h a b c) + pairMappings p (OnMaybe x a) (OnMaybe y b) = p x y <> pairMappings p a b + bind f (OnMaybe x m) = OnMaybe (onNothing (f x)) (bind (onJust . f) m) -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 c (Maybe k) (OnMaybe c k m) a) + instance (forall x. c x => Eq x, forall x. c x => c (OnMaybe c k m x), Mapping c k m, c a, Semigroup a) => Semigroup (OnMaybe c 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 c (Maybe k) (OnMaybe c k m) a) + instance (forall x. c x => Eq x, forall x. c x => c (OnMaybe c k m x), Mapping c k m, c a, Monoid a) => Monoid (OnMaybe c 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 c (Maybe k) (OnMaybe c k m) a) + instance (forall x. c x => Eq x, forall x. c x => c (OnMaybe c k m x), Mapping c k m, c a, Num a) => Num (OnMaybe c 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) +deriving via (AlgebraWrapper c (Maybe k) (OnMaybe c k m) a) + instance (forall x. c x => Eq x, forall x. c x => c (OnMaybe c k m x), Mapping c k m, c a, Boolean a) => Boolean (OnMaybe c k m a) -- | Maps on Either -data OnEither k l m n v = OnEither { +data OnEither (c :: Type -> Constraint) (k :: Type) (l :: Type) (m :: Type -> Type) (n :: Type -> Type) (v :: Type) = OnEither { onLeft :: m v, onRight :: n v } deriving (Eq, Ord) -instance (Foldable m, Foldable n) => Foldable (OnEither k l m n) where +instance (Foldable m, Foldable n) => Foldable (OnEither c 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 +instance (FoldableWithIndex k m, FoldableWithIndex l n) + => FoldableWithIndex (Either k l) (OnEither c 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 +instance (Mapping c k m, + Mapping c l n, + forall x. c x => Eq x, + forall x. c x => c (OnEither c k l m n x)) + => Mapping c (Either k l) (OnEither c k l m n) where cst x = OnEither (cst x) (cst x) mmap p (OnEither f g) = OnEither (mmap p f) (mmap p g) mtraverse p (OnEither f g) = liftA2 OnEither (mtraverse p f) (mtraverse p g) @@ -258,34 +327,83 @@ x <- isConst f y <- isConst g if x == y then Just x else Nothing - 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) + 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) + mergeA3 p (OnEither f1 g1) (OnEither f2 g2) (OnEither f3 g3) = + liftA2 OnEither (mergeA3 p f1 f2 f3) (mergeA3 p g1 g2 g3) + merge3 p (OnEither f1 g1) (OnEither f2 g2) (OnEither f3 g3) = + OnEither (merge3 p f1 f2 f3) (merge3 p g1 g2 g3) + pairMappings p (OnEither f1 g1) (OnEither f2 g2) = pairMappings p f1 f2 <> pairMappings p g1 g2 + bind f (OnEither u v) = OnEither (bind (onLeft . f) u) (bind (onRight . f) v) -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 c (Either k l) (OnEither c k l (m :: Type -> Type) n) a) + instance (Mapping c k m, + Mapping c l n, + c a, + forall x. c x => Eq x, + forall x. c x => c (OnEither c k l m n x), + Semigroup a) => Semigroup (OnEither c 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 c (Either k l) (OnEither c k l (m :: Type -> Type) n) a) + instance (Mapping c k m, + Mapping c l n, + c a, + forall x. c x => Eq x, + forall x. c x => c (OnEither c k l m n x), + Monoid a) => Monoid (OnEither c 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 c (Either k l) (OnEither c k l (m :: Type -> Type) n) a) + instance (Mapping c k m, + Mapping c l n, + c a, + forall x. c x => Eq x, + forall x. c x => c (OnEither c k l m n x), + Num a) => Num (OnEither c 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) +deriving via (AlgebraWrapper c (Either k l) (OnEither c k l (m :: Type -> Type) n) a) + instance (Mapping c k m, + Mapping c l n, + c a, + forall x. c x => Eq x, + forall x. c x => c (OnEither c k l m n x), + Boolean a) => Boolean (OnEither c k l m n a) +newtype Reconstrained (c :: Type -> Constraint) (d :: Type -> Constraint) (k :: Type) (m :: Type -> Type) (a :: Type) = Reconstrained { + preconstrained :: m a +} deriving (Eq, Ord, Foldable, FoldableWithIndex k, Neighbourly) + +instance (forall x. d x => c x, forall x. d x => d (Reconstrained c d k m x), Mapping c k m) => Mapping d k (Reconstrained c d k m) where + cst = Reconstrained . cst + act = act . preconstrained + isConst = isConst . preconstrained + mtraverse f = fmap Reconstrained . mtraverse f . preconstrained + mmap f = Reconstrained . mmap f . preconstrained + mergeA p (Reconstrained m) (Reconstrained n) = Reconstrained <$> mergeA p m n + merge p (Reconstrained m) (Reconstrained n) = Reconstrained $ merge p m n + mergeA3 p (Reconstrained m) (Reconstrained n) (Reconstrained o) = Reconstrained <$> mergeA3 p m n o + merge3 p (Reconstrained m) (Reconstrained n) (Reconstrained o) = Reconstrained $ merge3 p m n o + + -- | Maps on pairs -newtype OnPair k l m n v = OnPair { +newtype OnPair c k l m n v = OnPair { asComposite :: m (n v) } deriving (Eq, Ord) -instance (Foldable m, Foldable n) => Foldable (OnPair k l m n) where +instance (Foldable m, Foldable n) => Foldable (OnPair c k l m n) where foldMap p (OnPair f) = foldMap (foldMap p) f -instance (Mapping k m, - Mapping l n, - forall v. Ord v => Ord (n v)) - => Mapping (k, l) (OnPair k l m n) where +instance (FoldableWithIndex k m, FoldableWithIndex l n) => FoldableWithIndex (k,l) (OnPair c k l m n) where + ifoldMap p (OnPair f) = let + h x = ifoldMap (p . (x,)) + in ifoldMap h f + +instance (Mapping c k m, + Mapping c l n, + forall x. c x => c (OnPair c k l m n x)) + => Mapping c (k, l) (OnPair c k l m n) where cst x = OnPair . cst $ cst x mmap p (OnPair f) = OnPair (mmap (mmap p) f) mtraverse p (OnPair f) = OnPair <$> mtraverse (mtraverse p) f @@ -293,54 +411,55 @@ isConst (OnPair f) = isConst =<< isConst f mergeA h (OnPair f) (OnPair g) = OnPair <$> mergeA (mergeA h) f g merge h (OnPair f) (OnPair g) = OnPair $ merge (merge h) f g + merge3 p (OnPair f) (OnPair g) (OnPair h) = OnPair $ merge3 (merge3 p) f g h + mergeA3 p (OnPair f) (OnPair g) (OnPair h) = OnPair <$> mergeA3 (mergeA3 p) f g h + pairMappings p (OnPair f) (OnPair g) = pairMappings (pairMappings p) f g -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 (c :: Type -> Constraint) (k, l) (OnPair c k l (m :: Type -> Type) (n :: Type -> Type)) a) + instance (Mapping c k m, Mapping c l n, + forall x. c x => c (OnPair c k l m n x), c a, Semigroup a) => Semigroup (OnPair c 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 (c :: Type -> Constraint) (k, l) (OnPair c k l (m :: Type -> Type) (n :: Type -> Type)) a) + instance (Mapping c k m, Mapping c l n, + forall x. c x => c (OnPair c k l m n x), c a, Monoid a) => Monoid (OnPair c 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 (c :: Type -> Constraint) (k, l) (OnPair c k l (m :: Type -> Type) (n :: Type -> Type)) a) + instance (Mapping c k m, Mapping c l n, + forall x. c x => c (OnPair c k l m n x), c a, Num a) => Num (OnPair c 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) +deriving via (AlgebraWrapper (c :: Type -> Constraint) (k, l) (OnPair c k l (m :: Type -> Type) (n :: Type -> Type)) b) + instance (Mapping c k m, Mapping c l n, + forall x. c x => c (OnPair c k l m n x), c b, Boolean b) => Boolean (OnPair c k l m n b) --- Is the first a subset of the second? --- --- With a future version of cond, we should be able to generalise this -isSubset :: Mapping k m => m Bool -> m Bool -> Bool +-- | Is the first a subset of the second? +isSubset :: (Boolean b, c Void, Mapping c k m) => m b -> m b -> b isSubset m n = let - p True False = All False - p _ _ = All True - in getAll $ pairMappings p m n + p x y = AllB (x --> y) + in getAllB $ pairMappings p m n --- Are the two true on distinct values? --- --- Again, with a future version of cond, we should be able to generalise this -isDisjoint :: Mapping k m => m Bool -> m Bool -> Bool +-- | Are the two true on distinct values? +isDisjoint :: (Boolean b, c Void, Mapping c k m) => m b -> m b -> b isDisjoint m n = let - p True True = All False - p _ _ = All True - in getAll $ pairMappings p m n + p x y = AllB (not (x && y)) + in getAllB $ pairMappings p m n -- | A wrapper to allow defining `PartialOrd` instances on mappings whose keys -- have an `Ord` instance. -newtype OrdWrapper k m v = OrdWrapper { +newtype OrdWrapper c k m v = OrdWrapper { getOrdMapping :: m v } -instance (Mapping k m, Ord v) => PartialOrd (OrdWrapper k m v) where +instance (Mapping c k m, c Void, Ord v) => PartialOrd (OrdWrapper c k m v) where compare' (OrdWrapper u) (OrdWrapper v) = pairMappings fromCompare u v -- | A wrapper to allow defining `PartialOrd` instances on mappings whose keys -- have a `PartialOrd` instance. -newtype PartialOrdWrapper k m v = PartialOrdWrapper { +newtype PartialOrdWrapper c k m v = PartialOrdWrapper { getPartialOrdMapping :: m v } -instance (Mapping k m, PartialOrd v) => PartialOrd (PartialOrdWrapper k m v) where +instance (Mapping c k m, c Void, PartialOrd v) => PartialOrd (PartialOrdWrapper c k m v) where compare' (PartialOrdWrapper u) (PartialOrdWrapper v) = pairMappings compare' u v diff --git a/src/Data/Mapping/Decision.hs b/src/Data/Mapping/Decision.hs --- a/src/Data/Mapping/Decision.hs +++ b/src/Data/Mapping/Decision.hs @@ -1,652 +1,830 @@ -{-# LANGUAGE - CPP, - DerivingVia, - MultiParamTypeClasses, - OverloadedStrings, - RankNTypes, - StandaloneDeriving, - TupleSections - #-} - --- | Decision diagrams, parametric in the mapping type for the decisions. --- --- This is inspired by binary decision diagrams (as described in detail in --- Knuth's The Art of Computer Programming, volume 4A); these are the specific --- case where m is `BoolMapping` and v is `Bool`. Our algorithms are mostly --- straightforward generalisations of those considered there. --- - --- TODO --- * Format types of functions better --- * Decisions go upwards in order currently; should they go --- downwards, to coincide with lexicographical orderings on maps --- and hence maybe make smaller decision diagrams? --- We can use Down if necessary to amend this --- * Increase test coverage --- * Examples: --- - finding optima --- - finding random elements --- (as examples of the more general functions, already coded, I hope) --- * Separate out "Base" stuff into other modules? --- * Documentation --- --- MAYBE TO DO --- * Composition algorithm? --- * Optimisation by reordering -module Data.Mapping.Decision where - -#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) -#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 -import Data.Ord (comparing) -import Data.Sequence (Seq, (|>)) -import qualified Data.Sequence as Q -import Data.Set (Set) -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 - -import Data.Mapping - - --- | A node of a decision diagram: which value do we scrutinise, and what do we --- do with it? -data Node k m a = Node { - nodeDecision :: !a, - nodeBranch :: !(m Int) -} - -deriving instance (Eq a, Eq (m Int)) => Eq (Node k m a) - -deriving instance (Ord a, Ord (m Int)) => Ord (Node k m a) - - --- | A decision diagram (with no preferred starting point), containing --- leaves (representing final values of the decision process) indexed --- from -1 downwards, and nodes (representing the need to scrutinise a --- value) indexed from 0 upwards -data Base k m a v = Base { - leaves :: Seq v, - nodes :: Seq (Node k m a) -} - -baseLength :: Base k m a v -> Int -baseLength (Base l m) = Q.length l + Q.length m - --- | A decision diagram with a starting point -data Decision k m a v = Decision { - base :: !(Base k m a v), - start :: !Int -} - -decisionLength :: Decision k m a v -> Int -decisionLength = baseLength . base - --- | A value for every node of a base -data BaseMap v = BaseMap { - onLeaves :: Seq v, - onNodes :: Seq v -} - --- | Index a BaseMap -bindex :: BaseMap v -> Int -> v -bindex (BaseMap l m) x - | x < 0 = Q.index l $ complement x - | otherwise = Q.index m x - - --- | Close a set under an operation -closure :: (Int -> IntSet) -> IntSet -> IntSet -closure f = let - inner old new = case IS.minView new of - Nothing -> old - Just (x, new') -> let - old' = IS.insert x old - in inner old' (new' `IS.union` (f x `IS.difference` old')) - in inner IS.empty - - --- | A general kind of recursive function on a Base -baseRecurse :: (Ord c, - Mapping k m) - => (v -> c) - -- ^ What to do on a value - -> (a -> m c -> c) - -- ^ What do do on a node - -> Base k m a v - -- ^ Input base - -> BaseMap c -baseRecurse p q (Base l m) = let - l' = p <$> l - f v (Node x n) = v |> q x (mmap (bindex (BaseMap l' v)) n) - in BaseMap l' $ foldl f Q.empty m - --- | A general kind of recursive function on a Decision -decisionRecurse :: (Ord c, - Mapping k m) - => (v -> c) - -- ^ What to do on a value - -> (a -> m c -> c) - -- ^ What do do on a node - -> Decision k m a v - -- ^ Input decision - -> c -decisionRecurse p q (Decision b s) = bindex (baseRecurse p q b) s - - --- | A general counting function -generalCounts :: (Ord a, Ord n, Mapping k m) - => (a -> a -> Int) - -- ^ In the list of decisions, how far apart are these? - -> a - -- ^ The first possible decision - -> a - -- ^ The last possible decision - -> (v -> n) - -- ^ The count of a value - -> (m n -> n) - -- ^ How to combine counts at a node - -> Decision k m a v - -- ^ The input decision diagram - -> n - -- ^ The count -generalCounts d x0 x1 onVal combine = let - d' Nothing Nothing = 2 + d x0 x1 - d' Nothing (Just y) = 1 + d x0 y - d' (Just x) Nothing = 1 + d x x1 - d' (Just x) (Just y) = d x y - p x (y, a) = let - q 1 v = v - q n v = q (n-1) . combine $ cst v - in q (d' x y) a - f x = (Nothing, onVal x) - g a m = let - b = Just a - in (b, combine $ mmap (p b) m) - in p Nothing . decisionRecurse f g - --- | 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 - 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 -fromKeyVals = fmap snd . Q.sortBy (comparing fst) . Q.fromList . toList - - --- | A data structure for work-in-progress decision diagrams -data Builder o k m a v = Builder { - leavesMap :: Map v Int, - nodesMap :: Map (Node k m a) Int, - fromOld :: Map o Int -} - -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 x y (Builder l m o) = let - i = complement (M.size l) - (j, s) = insertIfAbsent x i l - o' = M.insert y j o - in case s of - 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 r a y (Builder l m o) = let - b = mmap (o M.!) a - in case isConst b of - Just j -> Builder l m (M.insert y j o) - Nothing -> let - i = M.size m - (j, s) = insertIfAbsent (Node r b) i m - o' = M.insert y j o - in case s of - Nothing -> Builder l m o' - Just m' -> Builder l m' o' - -makeBuilder :: (Mapping k m, - Ord o, - Ord (m Int), - Ord a, - Ord v) - => Map o v - -> Map o (a, m o) - -> Builder o k m a v -makeBuilder l m = let - b0 = emptyBuilder - makeL b i x = addLeaf x i b - b1 = M.foldlWithKey' makeL b0 l - makeN b i (r, o) = addNode r o i b - b2 = M.foldlWithKey' makeN b1 m - in b2 - -buildBase :: Builder o k m a v -> Base k m a v -buildBase (Builder l m _) = let - l' = fromKeyVals . fmap (\(x,i) -> (complement i,x)) $ M.toList l - m' = fromKeyVals . fmap (\(x,i) -> (i,x)) $ M.toList m - in Base l' m' - -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) - --- | 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 (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 -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 Decision (Base l m) s - --- | Test if a variable is true (specialised to `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 - l = Q.fromList [true, false] - s = M.size d - m = Q.fromList $ do - (i,(r,n)) <- zip [0..] (M.toDescList d) - pure (Node r (mmap (bool (-2) (i-1)) n)) - in Decision (Base l m) (s-1) - --- | Rapidly take the disjunction of the inputs -buildAny :: Mapping k m => Map a (m Bool) -> Decision k m a Bool -buildAny d = let - l = Q.fromList [false, true] - s = M.size d - m = Q.fromList $ do - (i,(r,n)) <- zip [0..] (M.toDescList d) - pure (Node r (mmap (bool (i-1) (-2)) n)) - in Decision (Base l m) (s-1) - - --- | Traverse bases -baseTraverse :: (Applicative f, Ord a, Ord (m Int), Ord w, Mapping k m) => (v -> f w) -> Base k m a v -> f (Builder Int k m a w) -baseTraverse p (Base l m) = let - t0 = pure emptyBuilder - - t1 = let - f b i x = liftA2 (\b' px' -> addLeaf px' (complement i) b') b (p x) - in Q.foldlWithIndex f t0 l - - t2 = let - f b i (Node r d) = addNode r d i <$> b - in Q.foldlWithIndex f t1 m - - in t2 - - --- | Map bases -baseMap :: (Ord a, Ord (m Int), Ord w, Mapping k m) => (v -> w) -> Base k m a v -> Builder Int k m a w -baseMap p = runIdentity . baseTraverse (Identity . p) - - --- | A more general map for `Base`, where the shape of nodes can change -baseTransform :: (Ord a, Ord (n Int), Mapping l n, Ord w) - => (v -> w) - -> (forall x. a -> m x -> n x) - -> Base k m a v - -> IntSet - -> Builder Int l n a w -baseTransform p q (Base l m) = let - - close aL aN s = case IS.maxView s of - Nothing -> makeBuilder aL aN - Just (i, s') -> if i < 0 - then let - x = p (Q.index l $ complement i) - in close (M.insert i x aL) aN s' - else let - Node r n = Q.index m i - o = q r n - s'' = IS.union s' . IS.fromList $ toList o - in close aL (M.insert i (r, o) aN) s'' - - in close M.empty M.empty - - --- | A more general map for `Decision`, where the shape of nodes can change -decisionTransform :: (Mapping l n, - Ord (n Int), - Ord a, - Ord w) - => (v -> w) - -> (forall x. a -> m x -> n x) - -> Decision k m a v - -> Decision l n a w -decisionTransform p q (Decision b s) = let - in buildDecision s $ baseTransform p q b (IS.singleton s) - - --- | Fill in some values of a map --- > act (restrict h d) f = let --- > f' x = case h x of --- > Just y -> y --- > Nothing -> f x --- > in act d f' -restrict :: (Ord (m Int), Ord v, Ord a, Mapping k m) => (a -> Maybe k) -> Decision k m a v -> Decision k m a v -restrict f = let - g x m = case f x of - Nothing -> m - Just c -> cst (act m c) - in decisionTransform id g - - --- | A general function for merging bases -baseGenMerge :: (Ord a, Ord w, Ord (o Int), Mapping l o) - => (u -> v -> w) - -> (forall x . Ord x => a -> m x -> o x) - -> (forall y . Ord y => a -> n y -> o y) - -> (forall x y. (Ord x, Ord y) => a -> m x -> n y -> o (x, y)) - -> Base h m a u -> Base k n a v -> Set (Int, Int) -> Builder (Int, Int) l o a w -baseGenMerge pLL pNL pLN pNN (Base l1 m1) (Base l2 m2) = let - - close aLL aNL aLN aNN s = case S.maxView s of - Nothing -> make aLL aNL aLN aNN - Just ((i1, i2), s') -> case (i1 < 0, i2 < 0) of - ( True, True) -> let - x = pLL (Q.index l1 $ complement i1) (Q.index l2 $ complement i2) - in close (M.insert (i1, i2) x aLL) aNL aLN aNN s' - ( True, False) -> let - Node r2 n2 = Q.index m2 i2 - o = mmap (i1,) $ pLN r2 n2 - s'' = S.union s' . S.fromList $ toList o - in close aLL aNL (M.insert (i1, i2) (r2, o) aLN) aNN s'' - (False, True) -> let - Node r1 n1 = Q.index m1 i1 - o = mmap (,i2) $ pNL r1 n1 - s'' = S.union s' . S.fromList $ toList o - in close aLL (M.insert (i1, i2) (r1, o) aNL) aLN aNN s'' - (False, False) -> let - Node r1 n1 = Q.index m1 i1 - Node r2 n2 = Q.index m2 i2 - (r, o) = case compare r1 r2 of - LT -> (r1, mmap (,i2) $ pNL r1 n1) - GT -> (r2, mmap (i1,) $ pLN r2 n2) - EQ -> (r1, pNN r1 n1 n2) - s'' = S.union s' . S.fromList $ toList o - in close aLL aNL aLN (M.insert (i1, i2) (r, o) aNN) s'' - - make aLL aNL aLN aNN = let - - b0 = emptyBuilder - - makeL b (i, j) x = addLeaf x (i, j) b - b1 = M.foldlWithKey' makeL b0 aLL - - makeN b (i, j) (r, o) = addNode r o (i, j) b - b2 = M.foldlWithKey' makeN b1 aNL - b3 = M.foldlWithKey' makeN b2 aLN - b4 = M.foldlWithKey' makeN b3 aNN - in b4 - - in close M.empty M.empty M.empty M.empty - - --- | Merge two bases in an applicative functor -baseMergeA :: (Applicative f, Ord a, Ord w, Ord (m Int), Mapping k m) - => (u -> v -> f w) - -> Base k m a u -> Base k m a v -> Set (Int, Int) -> f (Builder (Int, Int) k m a w) -baseMergeA p (Base l1 m1) (Base l2 m2) = let - - close aLL aNL aLN aNN s = case S.maxView s of - Nothing -> make aLL aNL aLN aNN - Just ((i1, i2), s') -> case (i1 < 0, i2 < 0) of - ( True, True) -> let - x = p (Q.index l1 $ complement i1) (Q.index l2 $ complement i2) - in close (M.insert (i1, i2) x aLL) aNL aLN aNN s' - ( True, False) -> let - Node r2 n2 = Q.index m2 i2 - o = mmap (i1,) n2 - s'' = S.union s' . S.fromList $ toList o - in close aLL aNL (M.insert (i1, i2) (r2, o) aLN) aNN s'' - (False, True) -> let - Node r1 n1 = Q.index m1 i1 - o = mmap (,i2) n1 - s'' = S.union s' . S.fromList $ toList o - in close aLL (M.insert (i1, i2) (r1, o) aNL) aLN aNN s'' - (False, False) -> let - Node r1 n1 = Q.index m1 i1 - Node r2 n2 = Q.index m2 i2 - (r,o) = case compare r1 r2 of - LT -> (r1, mmap (,i2) n1) - GT -> (r2, mmap (i1,) n2) - EQ -> (r1, merge (,) n1 n2) - s'' = S.union s' . S.fromList $ toList o - in close aLL aNL aLN (M.insert (i1, i2) (r, o) aNN) s'' - - make aLL aNL aLN aNN = let - - b0 = pure emptyBuilder - - makeL b (i, j) = liftA2 (\b' x'-> addLeaf x' (i, j) b') b - b1 = M.foldlWithKey' makeL b0 aLL - - makeN b (i, j) (r, o) = addNode r o (i, j) <$> b - b2 = M.foldlWithKey' makeN b1 aNL - b3 = M.foldlWithKey' makeN b2 aLN - b4 = M.foldlWithKey' makeN b3 aNN - in b4 - - in close M.empty M.empty M.empty M.empty - - --- | Merge two bases -baseMerge :: (Ord a, Ord w, Ord (m Int), Mapping k m) - => (u -> v -> w) - -> Base k m a u -> Base k m a v -> Set (Int, Int) -> Builder (Int, Int) k m a w -baseMerge p b1 b2 = let - p' x y = Identity $ p x y - in runIdentity . baseMergeA p' b1 b2 - - --- | Folds over *all* the leaves; not something you want to do to an --- arbitrary base -instance Foldable (Base k m a) where - foldMap p = foldMap p . leaves - -instance Foldable m => Foldable (Decision k m a) where - foldMap p (Decision (Base l m) s) = let - inner x old new = case IS.minView new of - Nothing -> x - Just (i, new') -> if i < 0 - then inner (x <> p (Q.index l (complement i))) (IS.insert i old) new' - else let - old' = IS.insert i old - extra = IS.difference (IS.fromList . toList . nodeBranch $ Q.index m i) old' - in inner x old' (IS.union new' extra) - in inner mempty IS.empty $ IS.singleton s - -instance (Ord a, Ord (m Int), Mapping k m) => Mapping (a -> k) (Decision k m a) where - - cst x = Decision (Base (Q.singleton x) Q.empty) (-1) - - act (Decision (Base l n) s) f = let - inner i - | i < 0 = Q.index l $ complement i - | otherwise = let - Node a m = Q.index n i - in inner . act m $ f a - in inner s - - -- We assume the diagram is optimised, so it is constant only if it starts - -- with a leaf. - isConst (Decision (Base l _) s) - | s < 0 = Just . Q.index l $ complement s - | otherwise = Nothing - - mtraverse p (Decision (Base l m) s) = buildDecision s <$> baseTraverse p (Base l m) - - mmap p (Decision b s) = buildDecision s $ baseMap p b - - merge p (Decision b1 s1) (Decision b2 s2) = buildDecision (s1, s2) $ baseMerge p b1 b2 (S.singleton (s1, s2)) - - 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 - consequences i j = case (i < 0, j < 0) of - (True, True) -> if Q.index l1 (complement i) == Q.index l2 (complement j) - then Just B.empty - else Nothing - (False, False) -> let - Node r1 o1 = Q.index m1 i - Node r2 o2 = Q.index m2 j - in if r1 == r2 - then B.getMaybeBij $ pairMappings B.msingleton o1 o2 - else Nothing - _ -> Nothing - in B.closeBijection consequences - --- | Are these Decisions isomorphic? -findBijection :: (Eq a, Eq v, Mapping k m) => Decision k m a v -> Decision k m a v -> Maybe Bij -findBijection (Decision b1 s1) (Decision b2 s2) = checkBijection b1 b2 (B.singleton s1 s2) - -instance (Eq a, Eq v, Mapping k m) => Eq (Decision k m a v) where - u == v = case findBijection u v of - Just _ -> True - Nothing -> False - - --- | A ludicrously short definition! -instance (Ord a, Ord v, Ord (m Int), Mapping k m) => Ord (Decision k m a v) where - compare = pairMappings compare - - --- | Output the structure of a Decision -debugShow :: (Show a, Show v, Show (m Int)) => Decision k m a v -> String -debugShow (Decision (Base l m) s) = let - - p = 1 + max (1 + length (show (Q.length l))) (length (show (1 + Q.length m))) - - prefix i = ((if i == s then "->" else " ") <>) - - leafLine t i x = let - j = complement i - in prefix j (F.formatToString (F.left p ' ' % ": " % F.shown % "\n") j x) <> t - - nodeLine i (Node r n) t = - prefix i (F.formatToString (F.left p ' ' % ": " % F.shown % "; " % F.shown % "\n") i r n) <> t - - in Q.foldlWithIndex leafLine (Q.foldrWithIndex nodeLine "" m) l - - -instance (Mapping k m, - Neighbourly m, - Ord a, - Ord (m Int)) - => Neighbourly (Decision k m a) where - neighbours (Decision (Base l m) s) = let - f v (Node _ n) = let - here = let - b = Base l m - e (i, j) = S.filter (uncurry (/=)) $ mutualValues (Decision b i) (Decision b j) - in foldMap e $ neighbours n - there = let - g i - | i < 0 = mempty - | otherwise = Q.index v i - in foldMap g n - in v |> (here <> there) - in Q.index (foldl f Q.empty m) s - +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Decision diagrams, parametric in the mapping type for the decisions. +-- +-- This is inspired by binary decision diagrams (as described in +-- detail in Knuth's The Art of Computer Programming, volume 4A); +-- these are the specific case where m is `OnBool` and v is +-- `Bool`. Our algorithms are mostly straightforward generalisations +-- of those considered there. +-- +-- Some examples of how to use this code can be seen in +-- `examples/View.hs` and in `test/Data/Mapping/DecisionSpec.hs`. +-- +-- Broadly speaking, there are two ways of using the code: +-- +-- * It can be used directly as a `Mapping`. This is convenient, but +-- possibly wasteful: every operation builds a separate cache. +-- +-- * Instead, one can (with a tiny bit more effort) use a layer of +-- functions which return in the State monad, enabling the user to +-- progressively build a shared cache. These functions mostly have +-- names ending in 'S' (for 'State'). +-- +-- Under the surface, the first layer mostly uses the second layer. + +module Data.Mapping.Decision ( + Serial(..), + Node(..), + Cache(..), + leafS, + branchS, + Decision(..), + runOnEmptyCache, + mapS, + traverseS, + mergeS, + mergeAS, + mergeS3, + trueAssignments, + generalCount, + foldingCount, + foldingCountTrue, + genTestS, + genTest, + testS, + test, + decisionS, + decision, + decideAllS, + decideAll, + decideAnyS, + decideAny, + debugShowCache, + recoverCache, + debugShow, + restrictS, + restrict, + ) where + +import Prelude hiding ((||)) +import Control.Monad ((<=<)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict ( + State, StateT, + evalState, evalStateT, execState, + get, modify, state) +import Data.Algebra.Boolean (Boolean(..)) +import Data.Foldable (traverse_) +import Data.Foldable.WithIndex (FoldableWithIndex(..)) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity(..)) +import qualified Data.IntMap.Strict as IM +import Data.Kind (Type) +import Data.Monoid (All(..), Ap(..), Sum(..)) +import qualified Data.Set as S +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import GHC.Exts (reallyUnsafePtrEquality#) + +import Data.Mapping + + +-- | Data structures with serial number; within the same data +-- structure we expect serial numbers to be unique. +data Serial a = Serial { + serial :: !Int, + content :: a +} + +instance Eq (Serial a) where + Serial i _ == Serial j _ = i == j + +-- | Rapid comparison, but it's meaningless: the order depends on the +-- order of discovery +instance Ord (Serial a) where + compare (Serial i _) (Serial j _) = compare i j + + +-- | A general-purpose monadic memoising function, which caches +-- partial results in an IntMap +memoComputeM :: Monad m + => (a -> Int) + -> (forall s. (a -> StateT s m b) -> a -> StateT s m b) + -> a + -> m b +memoComputeM s r = let + + go x = let + i = s x + inner m = case IM.lookup i m of + Just y -> pure y + Nothing -> do + y <- r go x + modify (IM.insert i y) + pure y + in inner =<< get + + in flip evalStateT IM.empty . go + +-- | A slightly-less general-purpose memoising function, caching +-- partial results in an IntMap. +memoCompute :: (a -> Int) + -> (forall s. (a -> State s b) -> a -> State s b) + -> a + -> b +memoCompute s r = runIdentity . memoComputeM s r + + +-- | The raw material of a decision tree. +data Node (k :: Type) (m :: Type -> Type) (a :: Type) (v :: Type) = + Leaf v | + Branch a (m (Serial (Node k m a v))) + +deriving instance (Eq (m (Serial (Node k m a v))), Eq a, Eq v) => Eq (Node k m a v) + +deriving instance (Ord (m (Serial (Node k m a v))), Ord a, Ord v) => Ord (Node k m a v) + +-- | A data structure for consistently assigning serial numbers +newtype Cache a = Cache (Map a (Serial a)) + +-- | Store something in a cache +stash :: Ord a => a -> State (Cache a) (Serial a) +stash x = let + f (Cache m) = let + g Nothing = let + s = Serial (M.size m) x + in (s, Just s) + g (Just s) = (s, Just s) + in Cache <$> M.alterF g x m + in state f + +-- | Create a leaf +leafS :: (forall x. Ord x => Ord (m x), Ord a, Ord v) + => v + -> State (Cache (Node k m a v)) (Serial (Node k m a v)) +leafS = stash . Leaf + +-- | Create a branch +branchS :: (Mapping Eq k m, + Ord a, + Ord v, + forall x. Ord x => Ord (m x)) + => a + -> m (Serial (Node k m a v)) + -> State (Cache (Node k m a v)) (Serial (Node k m a v)) +branchS a n = case isConst n of + Just s -> pure s + Nothing -> stash (Branch a n) + + +-- | Decision trees +-- +-- Notes: +-- +-- 1. The FoldableWithIndex instance can produce very large outputs +-- even with a modest-sized decision diagram. +-- +-- 2. The traverse and mergeA methods are very inefficient, and can +-- visit nodes an exponential number of times (see documentation for +-- `traverseS`), but the mmap, foldMap and merge methods visit each +-- node only once. +-- +-- 3. If you know two Decisions have been built from the same cache, +-- then comparing their serial numbers is a better equality test than +-- the more generic one provided. +newtype Decision k m a v = Decision { + startDecision :: Serial (Node k m a v) +} + + +-- | a Serial-specialised memoCompute +recurseMap :: (v -> x) + -> (forall z s. (z -> State s x) -> a -> m z -> State s x) + -> Serial (Node k m a v) + -> x +recurseMap p q = let + r f s = case content s of + Leaf v -> pure (p v) + Branch a m -> q f a m + in memoCompute serial r + +-- | a Serial-specialised memoComputeM +recurseMapM :: Monad n + => (v -> n x) + -> (forall z s. (z -> StateT s n x) -> a -> m z -> StateT s n x) + -> Serial (Node k m a v) + -> n x +recurseMapM p q = let + r f s = case content s of + Leaf v -> lift (p v) + Branch a m -> q f a m + in memoComputeM serial r + + +-- | Run a state-based computation to make a decision tree +runOnEmptyCache :: State (Cache (Node k m a v)) (Serial (Node k m a v)) + -> Decision k m a v +runOnEmptyCache r = Decision . evalState r $ Cache M.empty + + +-- | A function Int -> Int -> Int which is injective on nonnegative +-- integers +pairIntegers :: Int -> Int -> Int +pairIntegers i j = (((i+j)*(i+j+1)) `div` 2) + j + + +-- | A function Int -> Int -> Int -> Int which is injective on nonnegative +-- integers +tripleIntegers :: Int -> Int -> Int -> Int +tripleIntegers i j k = (((i+j+k)*(i+j+k+1)*(i+j+k+2)) `div` 6) + pairIntegers i j + + +instance Foldable m => Foldable (Decision k m a) where + + foldMap f = let + p g _ = getAp . foldMap (Ap . g) + in recurseMap f p . startDecision + + +-- | A state-based mmap +mapS :: forall k m a u v. + (Mapping Eq k m, Ord a, Ord v, + forall x. Ord x => Ord (m x)) + => (u -> v) + -> Serial (Node k m a u) + -> State (Cache (Node k m a v)) (Serial (Node k m a v)) +mapS f = let + q :: forall z s. + (z -> StateT s (State (Cache (Node k m a v))) (Serial (Node k m a v))) + -> a + -> m z + -> StateT s (State (Cache (Node k m a v))) (Serial (Node k m a v)) + q r a = lift . branchS a <=< mtraverse r + in recurseMapM (leafS . f) q + + +-- | A state-based mtraverse. +-- +-- It's far from clear whether it's possible or not to do a general +-- traverse fast in this setting. This algorithm is slow (it may visit +-- nodes an exponential number of times). +traverseS :: forall k m a u v f. + (Mapping Eq k m, Ord a, Ord v, Applicative f, + forall x. Ord x => Ord (m x)) + => (u -> f v) + -> Serial (Node k m a u) + -> f (State (Cache (Node k m a v)) (Serial (Node k m a v))) +traverseS p = let + inner :: Serial (Node k m a u) + -> f (State (Cache (Node k m a v)) (Serial (Node k m a v))) + inner s = case content s of + Leaf v -> leafS <$> p v + Branch a m -> fmap (branchS a =<<) . getCompose $ mtraverse (Compose . inner) m + in inner + + +-- | A state-based merge +mergeS :: forall k m a u v w. + (Mapping Eq k m, Ord a, Ord w, + forall x. Ord x => Ord (m x)) + => (u -> v -> w) + -> Serial (Node k m a u) + -> Serial (Node k m a v) + -> State (Cache (Node k m a w)) (Serial (Node k m a w)) +mergeS f = let + + pairSerial (Serial i _, Serial j _) = pairIntegers i j + + calculate :: forall s. + ((Serial (Node k m a u), Serial (Node k m a v)) + -> StateT s (State (Cache (Node k m a w))) (Serial (Node k m a w))) + -> (Serial (Node k m a u), Serial (Node k m a v)) + -> StateT s (State (Cache (Node k m a w))) (Serial (Node k m a w)) + calculate r (s,t) = case (content s, content t) of + (Leaf u, Leaf v) -> lift . leafS $ f u v + (Leaf _, Branch b n) -> lift . branchS b =<< mtraverse (r . (s,)) n + (Branch a m, Leaf _) -> lift . branchS a =<< mtraverse (r . (,t)) m + (Branch a m, Branch b n) -> case compare a b of + LT -> lift . branchS a =<< mtraverse (r . (,t)) m + GT -> lift . branchS b =<< mtraverse (r . (s,)) n + EQ -> lift . branchS a =<< mergeA (curry r) m n + + in curry $ memoComputeM pairSerial calculate + + +-- | A state-based mergeA. +-- +-- Just as for traverseS, this setting makes it seem unlikely that an +-- efficient algorithm will be possible. +mergeAS :: forall k m a u v w f. + (Mapping Eq k m, Ord a, Ord w, Applicative f, + forall x. Ord x => Ord (m x)) + => (u -> v -> f w) + -> Serial (Node k m a u) + -> Serial (Node k m a v) + -> f (State (Cache (Node k m a w)) (Serial (Node k m a w))) +mergeAS f = let + inner :: Serial (Node k m a u) + -> Serial (Node k m a v) + -> f (State (Cache (Node k m a w)) (Serial (Node k m a w))) + inner s t = case (content s, content t) of + (Leaf u, Leaf v) -> leafS <$> f u v + (Leaf _, Branch b n) -> + fmap (branchS b =<<) . getCompose $ mtraverse (Compose . inner s) n + (Branch a m, Leaf _) -> + fmap (branchS a =<<) . getCompose $ mtraverse (Compose . flip inner t) m + (Branch a m, Branch b n) -> case compare a b of + LT -> fmap (branchS a =<<) . getCompose $ mtraverse (Compose . flip inner t) m + GT -> fmap (branchS b =<<) . getCompose $ mtraverse (Compose . inner s) n + EQ -> fmap (branchS a =<<) . getCompose $ mergeA (\c -> Compose . inner c) m n + in inner + + +-- | A state-based merge3. +mergeS3 :: forall k m a u v w x. + (Mapping Eq k m, Ord a, Ord x, + forall y. Ord y => Ord (m y)) + => (u -> v -> w -> x) + -> Serial (Node k m a u) + -> Serial (Node k m a v) + -> Serial (Node k m a w) + -> State (Cache (Node k m a x)) (Serial (Node k m a x)) +mergeS3 f = let + + tripleSerial (Serial i _, Serial j _, Serial k _) = tripleIntegers i j k + + calculate :: forall s. + ( (Serial (Node k m a u), Serial (Node k m a v), Serial (Node k m a w)) + -> StateT s (State (Cache (Node k m a x))) (Serial (Node k m a x))) + -> (Serial (Node k m a u), Serial (Node k m a v), Serial (Node k m a w)) + -> StateT s (State (Cache (Node k m a x))) (Serial (Node k m a x)) + calculate q (r,s,t) = case (content r, content s, content t) of + (Leaf u, Leaf v, Leaf w) -> lift . leafS $ f u v w + (Leaf _, Leaf _, Branch c o) -> lift . branchS c =<< mtraverse (q . (r,s,)) o + (Leaf _, Branch b n, Leaf _) -> lift . branchS b =<< mtraverse (q . (r,,t)) n + (Branch a m, Leaf _, Leaf _) -> lift . branchS a =<< mtraverse (q . (,s,t)) m + (Branch a m, Branch b n, Leaf _) -> case compare a b of + LT -> lift . branchS a =<< mtraverse (q . (,s,t)) m + GT -> lift . branchS b =<< mtraverse (q . (r,,t)) n + EQ -> lift . branchS a =<< mergeA (\x y -> q (x,y,t)) m n + (Branch a m, Leaf _, Branch c o) -> case compare a c of + LT -> lift . branchS a =<< mtraverse (q . (,s,t)) m + GT -> lift . branchS c =<< mtraverse (q . (r,s,)) o + EQ -> lift . branchS a =<< mergeA (\x z -> q (x,s,z)) m o + (Leaf _, Branch b n, Branch c o) -> case compare b c of + LT -> lift . branchS b =<< mtraverse (q . (r,,t)) n + GT -> lift . branchS c =<< mtraverse (q . (r,s,)) o + EQ -> lift . branchS b =<< mergeA (\y z -> q (r,y,z)) n o + (Branch a m, Branch b n, Branch c o) -> case compare a b of + LT -> case compare a c of + LT -> lift . branchS a =<< mtraverse (q . (,s,t)) m + GT -> lift . branchS c =<< mtraverse (q . (r,s,)) o + EQ -> lift . branchS a =<< mergeA (\x z -> q (x,s,z)) m o + GT -> case compare b c of + LT -> lift . branchS b =<< mtraverse (q . (r,,t)) n + GT -> lift . branchS c =<< mtraverse (q . (r,s,)) o + EQ -> lift . branchS b =<< mergeA (\y z -> q (r,y,z)) n o + EQ -> case compare a c of + GT -> lift . branchS c =<< mtraverse (q . (r,s,)) o + LT -> lift . branchS a =<< mergeA (\x y -> q (x,y,t)) m n + EQ -> lift . branchS a =<< mergeA3 (\x y z -> q (x,y,z)) m n o + + start :: Serial (Node k m a u) + -> Serial (Node k m a v) + -> Serial (Node k m a w) + -> State (Cache (Node k m a x)) (Serial (Node k m a x)) + start r s t = memoComputeM tripleSerial calculate (r,s,t) + + in start + + +instance (Mapping Eq k m, + Ord a, + Eq v, + forall x. Ord x => Ord (m x)) + => Eq (Decision k m a v) where + + a == b = case reallyUnsafePtrEquality# a b of + 1# -> True + _ -> getAll (pairMappings (\x y -> All (x == y)) a b) + + +instance (Mapping Eq k m, + Ord a, + Ord v, + forall x. Ord x => Ord (m x)) + => Ord (Decision k m a v) where + compare = pairMappings compare + + +instance (Mapping Eq k m, + Ord a, + forall x. Ord x => Ord (m x)) + => Mapping Ord (a -> k) (Decision k m a) where + + cst x = let + n = Leaf x + s = Serial 0 n + in Decision s + + isConst (Decision (Serial _ (Leaf x))) = Just x + isConst (Decision (Serial _ (Branch _ _))) = Nothing + + act = let + inner (Leaf x) _ = x + inner (Branch a m) f = inner (content (act m (f a))) f + in inner . content . startDecision + + mmap p = runOnEmptyCache . mapS p . startDecision + + mtraverse p = fmap runOnEmptyCache . traverseS p . startDecision + + merge p (Decision a) (Decision b) = runOnEmptyCache $ mergeS p a b + + mergeA p (Decision a) (Decision b) = runOnEmptyCache <$> mergeAS p a b + + merge3 p (Decision a) (Decision b) (Decision c) = runOnEmptyCache $ mergeS3 p a b c + + mergeA3 = error "mergeA3 on Decision: not yet implemented" + + pairMappings f = let + + pairSerial (Serial i _, Serial j _) = pairIntegers i j + + calculate r (s,t) = case (content s, content t) of + (Leaf u, Leaf v) -> pure $ f u v + (Leaf _, Branch _ n) -> getAp $ foldMap (Ap . r . (s,)) n + (Branch _ m, Leaf _) -> getAp $ foldMap (Ap . r . (,t)) m + (Branch a m, Branch b n) -> case compare a b of + LT -> getAp $ foldMap (Ap . r . (,t)) m + GT -> getAp $ foldMap (Ap . r . (s,)) n + EQ -> getAp $ pairMappings (curry (Ap . r)) m n + + go s t = memoCompute pairSerial calculate (startDecision s, startDecision t) + + in go + + +instance (Ord a, Mapping Eq k m, Neighbourly m) => Neighbourly (Decision k m a) where + + neighbours = let + + serial (Left (Serial i _)) = pairIntegers i 0 + serial (Right (Serial i _, Serial j _)) = pairIntegers i (j+1) + + -- find neighbours in a node + p r (Left s) = case content s of + Leaf _ -> pure S.empty + Branch _ m -> do + now <- getAp . foldMap (Ap . r . Right) $ neighbours m + later <- getAp $ foldMap (Ap . r . Left) m + pure (now <> later) + -- find common values in two nodes + p r (Right (s,t)) = case (content s, content t) of + (Leaf u, Leaf v) -> pure $ if u == v then S.empty else S.singleton (u,v) + (Leaf _, Branch _ n) -> getAp $ foldMap (Ap . r . Right . (s,)) n + (Branch _ m, Leaf _) -> getAp $ foldMap (Ap . r . Right . (,t)) m + (Branch a m, Branch b n) -> case compare a b of + LT -> getAp $ foldMap (Ap . r . Right . (,t)) m + GT -> getAp $ foldMap (Ap . r . Right . (s,)) n + EQ -> let + q x y = Ap . r $ Right (x,y) + in getAp $ pairMappings q m n + + in memoCompute serial p . Left . startDecision + + +instance (Ord a, FoldableWithIndex k m, Mapping Eq k m) + => FoldableWithIndex (Map a k) (Decision k m a) where + + ifoldMap f = let + inner m (Leaf x) = f m x + inner m (Branch a n) = let + g k = inner (M.insert a k m) . content + in ifoldMap g n + in inner M.empty . content . startDecision + + +-- | Find all assignments of variables that pass the test +-- +-- Even for modest-sized decision diagrams, this can produce some very +-- large outputs! +satisfyingAssignments :: (Ord a, FoldableWithIndex k m) + => (v -> Bool) + -> Decision k m a v + -> [Map a k] +satisfyingAssignments t = let + p x = [M.empty | t x] + q f a = let + h k = Ap . fmap (fmap (M.insert a k)) . f + in getAp . ifoldMap h + in recurseMap p q . startDecision + + +-- | Find all assignments that return True +-- +-- Again, this can produce very large outputs even with modest-sized +-- inputs. +trueAssignments :: (Ord a, FoldableWithIndex k m) + => Decision k m a Bool + -> [Map a k] +trueAssignments = satisfyingAssignments id + + +-- | A general algorithm for counts of a decision tree +generalCount :: (Mapping Eq k m) + => (a -> Int) + -- ^ The serial number of a decision + -> Int + -- ^ The number of decisions + -> (v -> n) + -- ^ The count of a value + -> (forall f z. Applicative f => (z -> f n) -> m z -> f n) + -- ^ How to combine counts at a node + -> Decision k m a v + -- ^ The input decision diagram + -> n + -- ^ The count +generalCount s n c d = let + + step i (j,x) + | i+1 == j = x + | otherwise = step i (j-1, runIdentity $ d Identity (cst x)) + + p v = (n, c v) + + q f a = let + i = s a + in fmap (i,) . d (fmap (step i) . f) + + in step (-1) . recurseMap p q . startDecision + + +-- | A more specialised summing count +foldingCount :: (Mapping Eq k m, Num n) + => (a -> Int) + -- ^ The serial number of a decision + -> Int + -- ^ The number of decisions + -> (v -> n) + -- ^ The count of a value + -> Decision k m a v + -- ^ The input decision diagram + -> n + -- ^ The count +foldingCount s n c = let + q f = fmap getSum . getAp . foldMap (Ap . fmap Sum . f) + in generalCount s n c q + + +-- | Even more specialised: just counts true values +foldingCountTrue :: (Mapping Eq k m, Num n) + => (a -> Int) + -- ^ The serial number of a decision + -> Int + -- ^ The number of decisions + -> Decision k m a Bool + -- ^ The input decision diagram + -> n + -- ^ The count +foldingCountTrue s n = foldingCount s n (\x -> if x then 1 else 0) + + +-- | Create a test for a variable (valued in any Boolean) +genTestS :: (Ord a, Ord b, Boolean b) + => a + -> State (Cache (Node Bool OnBool a b)) (Serial (Node Bool OnBool a b)) +genTestS x = do + n0 <- leafS false + n1 <- leafS true + branchS x $ OnBool n0 n1 + +-- | Tests if a variable is true (valued in any Boolean) +genTest :: (Ord a, Ord b, Boolean b) + => a -> Decision Bool OnBool a b +genTest = runOnEmptyCache . genTestS + + +-- | Test if a variable is true (specialised to `Bool`) +testS :: (Ord a) + => a + -> State (Cache (Node Bool OnBool a Bool)) (Serial (Node Bool OnBool a Bool)) +testS = genTestS + +-- | Test if a variable is true (specialised to `Bool`) +test :: (Ord a) => a -> Decision Bool OnBool a Bool +test = genTest + + +-- | Make a single decision +decisionS :: (Mapping Eq k m, + Ord a, + Ord v, + forall x. Ord x => Ord (m x)) + => a + -> m v + -> State (Cache (Node k m a v)) (Serial (Node k m a v)) +decisionS a m = branchS a =<< mtraverse leafS m + + +-- | A single decision +decision :: (Mapping Eq k m, Ord a, Ord v, + forall x. Ord x => Ord (m x)) + => a + -> m v + -> Decision k m a v +decision a = runOnEmptyCache . decisionS a + + +-- | Build a test imposing conditions which must be true for all +-- variables in the map +decideAllS :: forall k m a. + (Mapping Eq k m, Ord a, + forall x. Ord x => Ord (m x)) + => Map a (m Bool) + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) +decideAllS = let + + begin :: [(a, m Bool)] + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) + begin [] = leafS True + begin l = do + f <- leafS False + t <- leafS True + continue f t l + + continue :: Serial (Node k m a Bool) + -> Serial (Node k m a Bool) + -> [(a, m Bool)] + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) + continue _ u [] = pure u + continue f u ((a,m):xs) = do + v <- branchS a (mmap (\i -> if i then u else f) m) + continue f v xs + + in begin . M.toDescList + + +-- | A test imposing conditions which must be true for all variables +-- in the map +decideAll :: (Mapping Eq k m, Ord a, + forall x. Ord x => Ord (m x)) + => Map a (m Bool) -> Decision k m a Bool +decideAll = runOnEmptyCache . decideAllS + + +-- | Build a test imposing conditions which must be true for at least +-- one variable in the map +decideAnyS :: forall k m a. + (Mapping Eq k m, Ord a, + forall x. Ord x => Ord (m x)) + => Map a (m Bool) + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) +decideAnyS = let + + begin :: [(a, m Bool)] + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) + begin [] = leafS False + begin l = do + t <- leafS True + f <- leafS False + continue t f l + + continue :: Serial (Node k m a Bool) + -> Serial (Node k m a Bool) + -> [(a, m Bool)] + -> State (Cache (Node k m a Bool)) (Serial (Node k m a Bool)) + continue _ u [] = pure u + continue t u ((a,m):xs) = do + v <- branchS a (mmap (\i -> if i then t else u) m) + continue t v xs + + in begin . M.toDescList + + +-- | A test imposing conditions which must be true for at least one +-- variable in the map +decideAny :: (Mapping Eq k m, Ord a, + forall x. Ord x => Ord (m x)) => Map a (m Bool) -> Decision k m a Bool +decideAny = runOnEmptyCache . decideAnyS + + +-- | Display the structure of a cache +debugShowCache :: (Mapping Eq k m, Show a, Show v, Show (m Int)) + => Cache (Node k m a v) + -> [String] +debugShowCache (Cache c) = let + + entries = IM.fromList [(serial s,content s) | s <- M.elems c] + + padding = length (show (M.size c - 1)) + + makeLine (n, s) = let + lspace = replicate (padding - length (show n)) ' ' + rest = case s of + Leaf v -> "Leaf " <> showsPrec 9 v "" + Branch a m -> "Branch " <> showsPrec 9 a "" <> " " <> showsPrec 11 (mmap serial m) "" + in lspace <> show n <> ": " <> rest + + in makeLine <$> IM.assocs entries + + +-- | Provided for debugging purposes only: if you find yourself +-- wanting this, that's a sign you should be using the State-valued +-- functionality instead. +recoverCache :: (Mapping Eq k m, Ord a, Ord v, + forall x. Ord x => Ord (m x)) + => Serial (Node k m a v) + -> Cache (Node k m a v) +recoverCache = let + inner s@(Serial _ n) = do + m <- get + case M.lookup n m of + Just _ -> pure () + Nothing -> do + case n of + Leaf _ -> pure () + Branch _ a -> traverse_ inner a + modify (M.insert n s) + in Cache . flip execState M.empty . inner + + +-- | Display the structure of a Decision +debugShow :: (Mapping Eq k m, + Ord a, + Ord v, + Show a, + Show v, + Show (m Int), + forall x. Ord x => Ord (m x)) + => Decision k m a v + -> String +debugShow (Decision x@(Serial s _)) = let + prefix i = ((if i == s then "* " else " ") <>) + in unlines [prefix i l | (i,l) <- zip [0..] (debugShowCache (recoverCache x))] + + +-- | Build a simplified decision, filling in some values in advance +restrictS :: forall k m a v. + (Mapping Eq k m, Ord a, Ord v, + forall x. Ord x => Ord (m x)) + => (a -> Maybe k) + -> Serial (Node k m a v) + -> State (Cache (Node k m a v)) (Serial (Node k m a v)) +restrictS f = let + q :: forall s z. + (z -> StateT s (State (Cache (Node k m a v))) (Serial (Node k m a v))) + -> a + -> m z + -> StateT s (State (Cache (Node k m a v))) (Serial (Node k m a v)) + q r a m = case f a of + Just b -> r $ act m b + Nothing -> lift . branchS a =<< mtraverse r m + in recurseMapM leafS q + + +-- | Simplify a Decision by filling in some values in advance +-- > act (restrict h d) f = let +-- > f' x = case h x of +-- > Just y -> y +-- > Nothing -> f x +-- > in act d f' +restrict :: (Mapping Eq k m, Ord a, Ord v, + forall x. Ord x => Ord (m x)) + => (a -> Maybe k) + -> Decision k m a v + -> Decision k m a v +restrict f = runOnEmptyCache . restrictS f . startDecision + + +deriving via (AlgebraWrapper Ord (a -> k) (Decision k m a) v) + instance (Mapping Eq k m, + Ord a, + Ord v, + Semigroup v, + forall x. Ord x => Ord (m x)) + => Semigroup (Decision k m a v) + +deriving via (AlgebraWrapper Ord (a -> k) (Decision k m a) v) + instance (Mapping Eq k m, + Ord a, + Ord v, + Monoid v, + forall x. Ord x => Ord (m x)) + => Monoid (Decision k m a v) + +deriving via (AlgebraWrapper Ord (a -> k) (Decision k m a) v) + instance (Mapping Eq k m, + Ord a, + Ord v, + Num v, + forall x. Ord x => Ord (m x)) + => Num (Decision k m a v) + +deriving via (AlgebraWrapper Ord (a -> k) (Decision k m a) v) + instance (Mapping Eq k m, + Ord a, + Ord v, + Boolean v, + forall x. Ord x => Ord (m x)) + => Boolean (Decision k m a v) diff --git a/src/Data/Mapping/MapWithDefault.hs b/src/Data/Mapping/MapWithDefault.hs --- a/src/Data/Mapping/MapWithDefault.hs +++ b/src/Data/Mapping/MapWithDefault.hs @@ -8,6 +8,7 @@ import Control.Applicative (Applicative(..)) import Data.Algebra.Boolean import Data.Foldable (Foldable(..)) +import Data.Functor.Const (Const(..)) import Data.List (groupBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -16,6 +17,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as S import Data.Mapping.Util +import Data.Void (Void) -- | Mappings constant except on an enumerated set of values @@ -41,41 +43,97 @@ instance Foldable (MapWithDefault k) where foldMap p (MapWithDefault a f) = p a <> foldMap p f -instance Ord k => Mapping k (MapWithDefault k) where +instance Ord k => Mapping Eq k (MapWithDefault k) where + cst x = MapWithDefault x M.empty + mmap p (MapWithDefault a f) = let b = p a q x = let y = p x in if b == y then Nothing else Just y in MapWithDefault b $ M.mapMaybe q f + mtraverse p (MapWithDefault a f) = let b = p a e x y = if x == y then Nothing else Just y g _ x = liftA2 e b (p x) in liftA2 MapWithDefault b $ M.traverseMaybeWithKey g f + act (MapWithDefault a f) x = fromMaybe a (M.lookup x f) + isConst (MapWithDefault a f) = if M.null f then Just a else Nothing - mergeA h (MapWithDefault a f) (MapWithDefault b g) = let + + mergeA p (MapWithDefault a f) (MapWithDefault b g) = let e x y = if x == y then Just x else Nothing - c = h a b - l = M.traverseMissing (\_ x -> h x b) - r = M.traverseMissing (\_ y -> h a y) - h' _ x y = liftA2 e c $ h x y - t = M.zipWithMaybeAMatched h' + c = p a b + p' x y = liftA2 e c $ p x y + l = M.traverseMaybeMissing (\_ x -> p' x b) + r = M.traverseMaybeMissing (\_ y -> p' a y) + t = M.zipWithMaybeAMatched (const p') combine = M.mergeA l r t in liftA2 MapWithDefault c $ combine f g - merge h (MapWithDefault a f) (MapWithDefault b g) = let - c = h a b - l = M.mapMissing (\_ x -> h x b) - r = M.mapMissing (\_ y -> h a y) - h' _ x y = let - z = h x y + + merge p (MapWithDefault a f) (MapWithDefault b g) = let + c = p a b + p' x y = let + z = p x y in if z == c then Nothing else Just z - t = M.zipWithMaybeMatched h' + l = M.mapMaybeMissing (\_ x -> p' x b) + r = M.mapMaybeMissing (\_ y -> p' a y) + t = M.zipWithMaybeMatched (const p') combine = M.merge l r t in MapWithDefault c $ combine f g + merge3 p (MapWithDefault a f) (MapWithDefault b g) (MapWithDefault c h) = let + d = p a b c + l1 = M.mapMissing (const (,b)) + r1 = M.mapMissing (const (a,)) + t1 = M.zipWithMatched (const (,)) + combine1 = M.merge l1 r1 t1 + p' (x,y) z = let + v = p x y z + in if v == d then Nothing else Just v + l2 = M.mapMaybeMissing (\_ (x,y) -> p' (x,y) c) + r2 = M.mapMaybeMissing (\_ z -> p' (a,b) z) + t2 = M.zipWithMaybeMatched (const p') + combine2 = M.merge l2 r2 t2 + in MapWithDefault d $ combine2 (combine1 f g) h + + mergeA3 p (MapWithDefault a f) (MapWithDefault b g) (MapWithDefault c h) = let + d = p a b c + e x y + | x == y = Nothing + | otherwise = Just y + l1 = M.mapMissing (const (,b)) + r1 = M.mapMissing (const (a,)) + t1 = M.zipWithMatched (const (,)) + combine1 = M.merge l1 r1 t1 + p' (x,y) z = liftA2 e d $ p x y z + l2 = M.traverseMaybeMissing (\_ (x,y) -> p' (x,y) c) + r2 = M.traverseMaybeMissing (\_ z -> p' (a,b) z) + t2 = M.zipWithMaybeAMatched (const p') + combine2 = M.mergeA l2 r2 t2 + in liftA2 MapWithDefault d $ combine2 (combine1 f g) h + + pairMappings :: forall a b m. Monoid m => (a -> b -> m) -> MapWithDefault k a -> MapWithDefault k b -> m + pairMappings p (MapWithDefault a f) (MapWithDefault b g) = let + t = M.zipWithAMatched (\_ x y -> Const $ p x y) + l = M.traverseMissing (\_ x -> Const $ p x b) + r = M.traverseMissing (\_ y -> Const $ p a y) + combine = M.mergeA l r t + in p a b <> getConst (combine f g :: Const m (Map k Void)) + + bind f (MapWithDefault a m) = let + MapWithDefault b n = f a + g k x + | y == b = Nothing + | otherwise = Just y where + y = act (f x) k + h k x _ = g k x + combine = M.merge (M.mapMaybeMissing g) M.preserveMissing (M.zipWithMaybeMatched h) + in MapWithDefault b $ combine m n + -- | This instance assumes that k is unbounded -- -- It would be possible to do something valid in greater generality (for @@ -86,14 +144,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) +deriving via (AlgebraWrapper Eq k (MapWithDefault k) b) instance (Ord k, Ord b, Semigroup b) => Semigroup (MapWithDefault k b) -deriving via (AlgebraWrapper k (MapWithDefault k) b) +deriving via (AlgebraWrapper Eq k (MapWithDefault k) b) instance (Ord k, Ord b, Monoid b) => Monoid (MapWithDefault k b) -deriving via (AlgebraWrapper k (MapWithDefault k) b) +deriving via (AlgebraWrapper Eq k (MapWithDefault k) b) instance (Ord k, Ord b, Num b) => Num (MapWithDefault k b) -deriving via (AlgebraWrapper k (MapWithDefault k) b) +deriving via (AlgebraWrapper Eq k (MapWithDefault k) b) instance (Ord k, Ord b, Boolean b) => Boolean (MapWithDefault k b) diff --git a/src/Data/Mapping/Piecewise.hs b/src/Data/Mapping/Piecewise.hs --- a/src/Data/Mapping/Piecewise.hs +++ b/src/Data/Mapping/Piecewise.hs @@ -1,16 +1,10 @@ -{-# LANGUAGE - CPP, - DerivingVia - #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} module Data.Mapping.Piecewise where -#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) -#else -import Control.Applicative (liftA2) -#endif -import Control.Applicative (liftA3) import Data.Algebra.Boolean +import Data.Foldable (toList) import qualified Data.Map.Internal as MI import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -84,18 +78,88 @@ lessThanOrEqual :: Enum k => k -> Piecewise k Bool lessThanOrEqual = lessThan . succ --- | All values, in order of increasing key -values :: Piecewise k v -> [v] -values (Piecewise x m) = x : M.elems m - instance (Eq k) => Functor (Piecewise k) where fmap p (Piecewise a f) = fromAscListUnsafe (p a) (fmap p <$> M.toList f) instance Foldable (Piecewise k) where foldMap f (Piecewise a m) = f a <> foldMap f m -instance Ord k => Mapping k (Piecewise k) where +innerMerge :: Ord k => (x -> y -> z) -> x -> y -> [(k,x)] -> [(k,y)] -> [(k,z)] +innerMerge p = let + go x _ [] v = fmap (p x) <$> v + go _ y u [] = fmap (flip p y) <$> u + go x y u@((a,x'):u') v@((b,y'):v') = case compare a b of + LT -> (a,p x' y):go x' y u' v + GT -> (b,p x y'):go x y' u v' + EQ -> (a,p x' y'):go x' y' u' v' + in go + + +innerMergeA :: (Ord k, Applicative f) + => (x -> y -> f z) + -> x -> y + -> [(k,x)] -> [(k,y)] -> f [(k,z)] +innerMergeA p = let + go x _ [] v = traverse (traverse (p x)) v + go _ y u [] = traverse (traverse (flip p y)) u + go x y u@((a,x'):u') v@((b,y'):v') = case compare a b of + LT -> liftA2 (:) ((a,) <$> p x' y) (go x' y u' v) + GT -> liftA2 (:) ((b,) <$> p x y') (go x y' u v') + EQ -> liftA2 (:) ((a,) <$> p x' y') (go x' y' u' v') + in go + + +innerMerge3 :: Ord k + => (x -> y -> z -> w) + -> x -> y -> z + -> [(k,x)] -> [(k,y)] -> [(k,z)] -> [(k,w)] +innerMerge3 p = let + go x y z [] v w = innerMerge (p x) y z v w + go x y z u [] w = innerMerge (\i -> p i y) x z u w + go x y z u v [] = innerMerge (\i j -> p i j z) x y u v + go x y z u@((a,x'):u') v@((b,y'):v') w@((c,z'):w') = case compare a b of + LT -> case compare a c of + LT -> (a,p x' y z):go x' y z u' v w + GT -> (c,p x y z'):go x y z' u v w' + EQ -> (a,p x' y z'):go x' y z' u' v w' + GT -> case compare b c of + LT -> (b,p x y' z):go x y' z u v' w + GT -> (c,p x y z'):go x y z' u v w' + EQ -> (b,p x y' z'):go x y' z' u v' w' + EQ -> case compare a c of + LT -> (a,p x' y' z):go x' y' z u' v' w + GT -> (c,p x y z'):go x y z' u v w' + EQ -> (a,p x' y' z'):go x' y' z' u' v' w' + in go + + +innerMergeA3 :: (Applicative f, Ord k) + => (x -> y -> z -> f w) + -> x -> y -> z + -> [(k,x)] -> [(k,y)] -> [(k,z)] -> f [(k,w)] +innerMergeA3 p = let + go x y z [] v w = innerMergeA (p x) y z v w + go x y z u [] w = innerMergeA (\i -> p i y) x z u w + go x y z u v [] = innerMergeA (\i j -> p i j z) x y u v + go x y z u@((a,x'):u') v@((b,y'):v') w@((c,z'):w') = case compare a b of + LT -> case compare a c of + LT -> liftA2 (:) ((a,) <$> p x' y z) (go x' y z u' v w) + GT -> liftA2 (:) ((c,) <$> p x y z') (go x y z' u v w') + EQ -> liftA2 (:) ((a,) <$> p x' y z') (go x' y z' u' v w') + GT -> case compare b c of + LT -> liftA2 (:) ((b,) <$> p x y' z) (go x y' z u v' w) + GT -> liftA2 (:) ((c,) <$> p x y z') (go x y z' u v w') + EQ -> liftA2 (:) ((b,) <$> p x y' z') (go x y' z' u v' w') + EQ -> case compare a c of + LT -> liftA2 (:) ((a,) <$> p x' y' z) (go x' y' z u' v' w) + GT -> liftA2 (:) ((c,) <$> p x y z') (go x y z' u v w') + EQ -> liftA2 (:) ((a,) <$> p x' y' z') (go x' y' z' u' v' w') + in go + + +instance Ord k => Mapping Eq k (Piecewise k) where + cst x = Piecewise x M.empty act (Piecewise a f) x = case M.lookupLE x f of @@ -104,84 +168,59 @@ isConst (Piecewise a f) = if M.null f then Just a else Nothing - mmap = fmap - - mtraverse p (Piecewise a f) = liftA2 fromAscList (p a) (traverse (traverse p) $ M.toList f) + mmap p (Piecewise a f) = fromAscList (p a) . fmap (fmap p) $ M.toList f - merge p = let + mtraverse p (Piecewise a f) = liftA2 fromAscList (p a) . traverse (traverse p) $ M.toList f - inner a b c r@((x,a'):r') s@((y,b'):s') = case compare x y of - LT -> let - c' = p a' b - in if c' == c then inner a' b c r' s else (x,c'):inner a' b c' r' s - GT -> let - c' = p a b' - in if c' == c then inner a b' c r s' else (y,c'):inner a b' c' r s' - EQ -> let - c' = p a' b' - in if c' == c then inner a' b' c r' s' else (x,c'):inner a' b' c' r' s' - inner a _ c [] ((y,b'):s') = let - c' = p a b' - in if c' == c then inner a b' c [] s' else (y,c'):inner a b' c' [] s' - inner _ b c ((x,a'):r') [] = let - c' = p a' b - in if c' == c then inner a' b c r' [] else (x,c'):inner a' b c' r' [] - inner _ _ _ [] [] = [] + merge p (Piecewise a f) (Piecewise b g) = + fromAscList (p a b) $ innerMerge p a b (M.toList f) (M.toList g) - run (Piecewise a f) (Piecewise b g) = let - c = p a b - l = inner a b c (M.toList f) (M.toList g) - in Piecewise c $ M.fromList l + mergeA p (Piecewise a f) (Piecewise b g) = + liftA2 fromAscList (p a b) $ innerMergeA p a b (M.toList f) (M.toList g) - in run + merge3 p (Piecewise a f) (Piecewise b g) (Piecewise c h) = + fromAscList (p a b c) $ innerMerge3 p a b c (M.toList f) (M.toList g) (M.toList h) - mergeA p = let + mergeA3 p (Piecewise a f) (Piecewise b g) (Piecewise c h) = + liftA2 fromAscList (p a b c) $ innerMergeA3 p a b c (M.toList f) (M.toList g) (M.toList h) - maybePrepend x u v l - | u == v = l - | otherwise = (x,v):l + pairMappings p = let - inner a b c r@((x,a'):r') s@((y,b'):s') = case compare x y of - LT -> let - c' = p a' b - in liftA3 (maybePrepend x) c c' $ inner a' b c' r' s - GT -> let - c' = p a b' - in liftA3 (maybePrepend y) c c' $ inner a b' c' r s' - EQ -> let - c' = p a' b' - in liftA3 (maybePrepend x) c c' $ inner a' b' c' r' s' - inner a _ c [] ((y,b'):s') = let - c' = p a b' - in liftA3 (maybePrepend y) c c' $ inner a b' c' [] s' - inner _ b c ((x,a'):r') [] = let - c' = p a' b - in liftA3 (maybePrepend x) c c' $ inner a' b c' r' [] - inner _ _ _ [] [] = pure [] + inner z a b r@((x,a'):r') s@((y,b'):s') = case compare x y of + LT -> inner (z <> p a' b) a' b r' s + GT -> inner (z <> p a b') a b' r s' + EQ -> inner (z <> p a' b') a' b' r' s' + inner z a _ [] s = z <> foldMap (p a . snd) s + inner z _ b r [] = z <> foldMap (flip p b . snd) r - run (Piecewise a f) (Piecewise b g) = let - c = p a b - l = inner a b c (M.toList f) (M.toList g) - in liftA2 Piecewise c (M.fromList <$> l) + run (Piecewise a f) (Piecewise b g) = inner (p a b) a b (M.toList f) (M.toList g) in run + bind f (Piecewise a m) = let + inner p [] = p + inner p ((k,q):l) = let + (p', _) = splitPiecewise k p + (_ , q') = splitPiecewise k q + in gluePiecewise p' k $ inner q' l + in inner (f a) (fmap f <$> M.toList m) + instance Neighbourly (Piecewise k) where neighbours m = let pairs (x:r@(y:_)) = (x,y):pairs r pairs _ = [] - in S.fromList . pairs $ values m + in S.fromList . pairs $ toList m -deriving via (AlgebraWrapper k (Piecewise k) b) +deriving via (AlgebraWrapper Eq k (Piecewise k) b) instance (Ord k, Ord b, Semigroup b) => Semigroup (Piecewise k b) -deriving via (AlgebraWrapper k (Piecewise k) b) +deriving via (AlgebraWrapper Eq k (Piecewise k) b) instance (Ord k, Ord b, Monoid b) => Monoid (Piecewise k b) -deriving via (AlgebraWrapper k (Piecewise k) b) +deriving via (AlgebraWrapper Eq k (Piecewise k) b) instance (Ord k, Ord b, Num b) => Num (Piecewise k b) -deriving via (AlgebraWrapper k (Piecewise k) b) +deriving via (AlgebraWrapper Eq k (Piecewise k) b) instance (Ord k, Ord b, Boolean b) => Boolean (Piecewise k b) -- | Alter keys according to a function, assumed to be monotone (not checked) @@ -217,14 +256,3 @@ gluePiecewise p@(Piecewise a m) k (Piecewise c n) = let b = rightEnd p in Piecewise a (if b == c then MI.link2 m n else MI.link k c m n) - --- | This is almost a monad (with `cst` as `pure`) except that we need --- an `Eq` instance on the values. -mjoin :: (Ord k, Eq w) => (v -> Piecewise k w) -> Piecewise k v -> Piecewise k w -mjoin f (Piecewise a m) = let - inner p [] = p - inner p ((k,q):l) = let - (p', _) = splitPiecewise k p - (_ , q') = splitPiecewise k q - in gluePiecewise p' k $ inner q' l - in inner (f a) (fmap f <$> M.toList m) diff --git a/src/Data/Mapping/Util.hs b/src/Data/Mapping/Util.hs --- a/src/Data/Mapping/Util.hs +++ b/src/Data/Mapping/Util.hs @@ -1,25 +1,8 @@ module Data.Mapping.Util where -import Data.Functor.Compose (Compose(..)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M - --- | inserts key with value only if absent, returns map if changed -insertIfAbsent :: Ord k => k -> v -> Map k v -> (v, Maybe (Map k v)) -insertIfAbsent k v = let - f (Just x) = (x, Nothing) - f Nothing = (v, Just (Just v)) - in getCompose . M.alterF (Compose . f) k - - -- | For use in maps where we don't want to store default values nonDefault :: Eq a => a -> a -> Maybe a nonDefault d x | d == x = Nothing | otherwise = Just x - - --- | Helper function (not exported) -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating f x y = f x == f y diff --git a/test/Data/Mapping/DecisionSpec.hs b/test/Data/Mapping/DecisionSpec.hs --- a/test/Data/Mapping/DecisionSpec.hs +++ b/test/Data/Mapping/DecisionSpec.hs @@ -1,13 +1,15 @@ module Data.Mapping.DecisionSpec where import Prelude hiding ((&&), (||), not, all) -import qualified Data.Map as M +import Data.Foldable (foldlM) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import qualified Data.Set as S import Test.Hspec import Data.Algebra.Boolean ((&&), (||), not, all) import Data.Mapping import Data.Mapping.Decision -import Data.Mapping.Piecewise +import Data.Mapping.Piecewise (Piecewise, greaterThanOrEqual, fromAscList) boolAct :: Ord a @@ -17,104 +19,159 @@ boolAct a s = act a (`S.member` S.fromList s) +completeAssignments :: Ord a => [a] -> Map a Bool -> [Map a Bool] +completeAssignments [] m = pure m +completeAssignments (v:vs) m = let + l = case M.lookup v m of + Just _ -> pure m + Nothing -> [M.insert v False m, M.insert v True m] + in completeAssignments vs =<< l + + spec :: Spec spec = do - let x = test "x" - let y = test "y" + describe "Boolean algebra" $ do - describe "Basic tests of act" $ do + let x = test "x" + let y = test "y" - it "x false on {}" $ do - boolAct x [] `shouldBe` False - it "x true on {x}" $ do - boolAct x ["x"] `shouldBe` True + describe "Basic tests of act" $ do - describe "Basic tests of mmap" $ do + it "x false on {}" $ do + boolAct x [] `shouldBe` False + it "x true on {x}" $ do + boolAct x ["x"] `shouldBe` True - it "not x true on {}" $ do - boolAct (not x) [] `shouldBe` True - it "not x false on {x}" $ do - boolAct (not x) ["x"] `shouldBe` False + describe "Basic tests of mmap" $ do - describe "Basic tests of merge" $ do + it "not x true on {}" $ do + boolAct (not x) [] `shouldBe` True + it "not x false on {x}" $ do + boolAct (not x) ["x"] `shouldBe` False - it "x && y true on {}" $ do - boolAct (x && y) [] `shouldBe` False - it "x && y true on {x}" $ do - boolAct (x && y) ["x"] `shouldBe` False - it "x && y true on {y}" $ do - boolAct (x && y) ["y"] `shouldBe` False - it "x && y true on {x,y}" $ do - boolAct (x && y) ["x", "y"] `shouldBe` True + describe "Basic tests of merge" $ do - it "x || y true on {}" $ do - boolAct (x || y) [] `shouldBe` False - it "x || y true on {x}" $ do - boolAct (x || y) ["x"] `shouldBe` True - it "x || y true on {y}" $ do - boolAct (x || y) ["y"] `shouldBe` True - it "x || y true on {x,y}" $ do - boolAct (x || y) ["x", "y"] `shouldBe` True + it "x && y true on {}" $ do + boolAct (x && y) [] `shouldBe` False + it "x && y true on {x}" $ do + boolAct (x && y) ["x"] `shouldBe` False + it "x && y true on {y}" $ do + boolAct (x && y) ["y"] `shouldBe` False + it "x && y true on {x,y}" $ do + boolAct (x && y) ["x", "y"] `shouldBe` True - it "y && x true on {}" $ do - boolAct (y && x) [] `shouldBe` False - it "y && x true on {x}" $ do - boolAct (y && x) ["x"] `shouldBe` False - it "y && x true on {y}" $ do - boolAct (y && x) ["y"] `shouldBe` False - it "y && x true on {x,y}" $ do - boolAct (y && x) ["x", "y"] `shouldBe` True + it "x || y true on {}" $ do + boolAct (x || y) [] `shouldBe` False + it "x || y true on {x}" $ do + boolAct (x || y) ["x"] `shouldBe` True + it "x || y true on {y}" $ do + boolAct (x || y) ["y"] `shouldBe` True + it "x || y true on {x,y}" $ do + boolAct (x || y) ["x", "y"] `shouldBe` True - it "y || x true on {}" $ do - boolAct (y || x) [] `shouldBe` False - it "y || x true on {x}" $ do - boolAct (y || x) ["x"] `shouldBe` True - it "y || x true on {y}" $ do - boolAct (y || x) ["y"] `shouldBe` True - it "y || x true on {x,y}" $ do - boolAct (y || x) ["x", "y"] `shouldBe` True + it "y && x true on {}" $ do + boolAct (y && x) [] `shouldBe` False + it "y && x true on {x}" $ do + boolAct (y && x) ["x"] `shouldBe` False + it "y && x true on {y}" $ do + boolAct (y && x) ["y"] `shouldBe` False + it "y && x true on {x,y}" $ do + boolAct (y && x) ["x", "y"] `shouldBe` True - describe "Check of listTrue" $ do + it "y || x true on {}" $ do + boolAct (y || x) [] `shouldBe` False + it "y || x true on {x}" $ do + boolAct (y || x) ["x"] `shouldBe` True + it "y || x true on {y}" $ do + boolAct (y || x) ["y"] `shouldBe` True + it "y || x true on {x,y}" $ do + boolAct (y || x) ["x", "y"] `shouldBe` True - 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)] + describe "Check of trueAssignments" $ do - it "Should work on &&" $ do - S.fromList (listTrue (S.fromList ["x", "y"]) (x && y)) - `shouldBe` S.fromList [x1y1] - it "Should work on ||" $ do - S.fromList (listTrue (S.fromList ["x", "y"]) (x || y)) - `shouldBe` S.fromList [x0y1, x1y0, x1y1] - it "Should work on not (1)" $ do - S.fromList (listTrue (S.fromList ["x", "y"]) (not x)) - `shouldBe` S.fromList [x0y0, x0y1] - it "Should work on not (2)" $ do - S.fromList (listTrue (S.fromList ["x", "y"]) (not y)) - `shouldBe` S.fromList [x0y0, x1y0] + 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)] - describe "Properties of independent sets in C_100" $ do + it "Should work on &&" $ do + S.fromList (completeAssignments ["x","y"] =<< trueAssignments (x && y)) + `shouldBe` S.fromList [x1y1] + it "Should work on ||" $ do + S.fromList (completeAssignments ["x","y"] =<< trueAssignments (x || y)) + `shouldBe` S.fromList [x0y1, x1y0, x1y1] + it "Should work on not (1)" $ do + S.fromList (completeAssignments ["x","y"] =<< trueAssignments (not x)) + `shouldBe` S.fromList [x0y0, x0y1] + it "Should work on not (2)" $ do + S.fromList (completeAssignments ["x","y"] =<< trueAssignments (not y)) + `shouldBe` S.fromList [x0y0, x1y0] - 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]] + describe "Independent maximal sets in C_100 (mapping style)" $ do + + -- We build a decision tree representing all maximal subsets of + -- {0,...,99} (regarded cyclically) with no consecutive elements. + let l2 = (99,0):[(n,n+1) | n <- [0..98]] + let l3 = (98,99,0):(99,0,1):[(n,n+1,n+2) | n <- [0..97]] 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 t = independent && maximal + let a = independent && maximal -- Mentioned in Knuth it "should have the right count" $ do - numberTrue (1::Int) 100 t `shouldBe` 1630580875002 + foldingCountTrue id 100 a `shouldBe` (1630580875002 :: Int) + describe "Independent maximal sets in C_100 (state style)" $ do + + -- As above, but using the state-based functionality + + let l2 = (99,0):[(n,n+1) | n <- [0..98]] + let l3 = (98,99,0):(99,0,1):[(n,n+1,n+2) | n <- [0..97]] + let { addIndependent m (i,j) = do + x <- testS i + y <- testS j + z <- mergeS (&&) x y + w <- mapS not z + mergeS (&&) m w } + let { addMaximal m (i,j,k) = do + x <- testS i + y <- testS j + z <- testS k + u <- mergeS (||) x y + v <- mergeS (||) u z + mergeS (&&) m v } + let { a = runOnEmptyCache $ do + t <- leafS True + independent <- foldlM addIndependent t l2 + foldlM addMaximal independent l3 } + + it "should have the right count" $ do + foldingCountTrue id 100 a `shouldBe` (1630580875002 :: Int) + + describe "Test of neighbours" $ do + + let m1 = decision "x" $ fromAscList 1 [(37,2),(74,3)] + let m2 = decision "y" $ fromAscList 10 [(24,20),(83,30)] + let m = m1 + m2 :: Decision Int (Piecewise Int) String Int + it "should calculate neighbours correctly" $ do + neighbours m `shouldBe` S.fromList [ + (11,12),(12,13),(21,22),(22,23),(31,32),(32,33), + (11,21),(21,31),(12,22),(22,32),(13,23),(23,33)] + describe "Decision trees for monomial divisibility" $ do - let xy2 = M.fromList [("X", 1::Int), ("Y", 2)] - let x2y = M.fromList [("X", 2), ("Y", 1)] - let xyz = M.fromList [("X", 1), ("Y", 1), ("Z", 1)] + -- We build a decision tree which associates, to each monomial, + -- the largest-numbered monomial that divides it (or 0 if no such + -- exists). + let xy2 = M.fromList [("X", 1::Int), ("Y", 2)] -- monomial 1 + let x2y = M.fromList [("X", 2), ("Y", 1)] -- monomial 2 + let xyz = M.fromList [("X", 1), ("Y", 1), ("Z", 1)] -- monomial 3 let monomials = M.fromList [(xy2, 1::Int), (x2y, 2), (xyz, 3)] let f i b = if b then i else 0 - let d = M.foldlWithKey' (\t m i -> merge max t (mmap (f i) . buildAll $ fmap greaterThanOrEqual m)) (cst 0) monomials + let { d = M.foldlWithKey' (\t m i -> merge max t (mmap (f i) $ decideAll (greaterThanOrEqual <$> m))) + (cst 0) + monomials :: Decision Int (Piecewise Int) String Int } let mapAct m = act d (\a -> M.findWithDefault 0 a $ M.fromList m) it "should get the right monomial for w^2y^4" $ do