mappings 0.3.3.0 → 0.4.0.0

raw patch · 11 files changed

+1412/−1071 lines, 11 filesdep +transformersdep +trivial-constraintdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers, trivial-constraint

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +13/−22
• examples/View.hs +3/−3
• mappings.cabal +15/−10
• src/Data/Bijection.hs +0/−83
• src/Data/Mapping.hs +232/−113
• src/Data/Mapping/Decision.hs +829/−651
• src/Data/Mapping/MapWithDefault.hs +76/−18
• src/Data/Mapping/Piecewise.hs +109/−81
• src/Data/Mapping/Util.hs +0/−17
• test/Data/Mapping/DecisionSpec.hs +130/−73

@@ -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

@@ -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). 

@@ -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

@@ -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

@@ -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

@@ -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

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

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

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

@@ -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

@@ -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