{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Zsyntax.ReactionList where
import Data.Set (Set)
import qualified Data.Set as S (map,fromList)
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.MultiSet (MultiSet, isSubsetOf)
data CtrlType = Regular | SupersetClosed deriving (Eq, Ord, Show)
data CtrlSetCtxt af = CSC
{ _cscType :: CtrlType
, _cscCtxt :: MultiSet af
} deriving (Eq, Ord, Show)
newtype CtrlSet af = CS
{ unCS :: Set (CtrlSetCtxt af)
} deriving (Eq, Ord, Semigroup, Monoid, Show)
fromCSCtxts :: (Foldable f, Ord af) => f (CtrlSetCtxt af) -> CtrlSet af
fromCSCtxts = CS . S.fromList . toList
toCtxtList :: CtrlSet af -> [CtrlSetCtxt af]
toCtxtList = toList . unCS
respectsCC :: Ord af => MultiSet af -> CtrlSetCtxt af -> Bool
respectsCC ms (CSC Regular ctxt) = ms /= ctxt
respectsCC ms (CSC SupersetClosed ctxt) = not (ctxt `isSubsetOf` ms)
msRespectsCS :: Ord af => MultiSet af -> CtrlSet af -> Bool
msRespectsCS ms = and . S.map (respectsCC ms) . unCS
newtype RList eb cs = RL
{ unRL :: [(eb, cs)]
} deriving (Eq, Ord, Semigroup, Monoid, Show)
justCS :: Monoid eb => cs -> RList eb cs
justCS cs = RL [(mempty, cs)]
extend :: Semigroup eb => eb -> RList eb cs -> RList eb cs
extend base = RL . map (first (base <>)) . unRL
respectsRList :: Semigroup eb => (eb -> cs -> Bool) -> eb -> RList eb cs -> Bool
respectsRList resp base = and . fmap (uncurry resp . first (base <>)) . unRL