Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

fragmentation is now possible!

  • Loading branch information...
commit cf51d5380d4cbf8dfec3f65d6eb535e108f26424 1 parent c8d51f7
@rhz authored
View
48 Frag.hs
@@ -0,0 +1,48 @@
+module Main where
+
+import qualified KappaParser as KP
+import qualified Env as E
+import qualified Mixture as M
+import qualified Rule as R
+import qualified Fragmentation as F
+import qualified PlainKappa as K
+import Utils
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import System.Environment (getArgs)
+import Data.List (intercalate, nubBy)
+
+main :: IO ()
+main = do inputFilename : nStr : _ <- getArgs
+ m <- KP.parseFromFile inputFilename
+
+ let env = E.createEnv m
+ rules = [ R.evalRule env rule | (_, rule) <- KP.rules m ]
+ obss = [ (M.evalKExpr env True obs, name) | KP.KExprWithName name obs <- KP.obss m ]
+
+ odes = take (read nStr) $ F.fragment rules (map fst obss)
+ fragments = map fst odes ++ (snd =<< snd =<< odes)
+
+ names = reverse $ addFrags 1 (reverse obss) fragments -- reverse forth and back
+ addFrags _ obss [] = obss
+ addFrags n obss (obs:todo)
+ | (obs', name):_ <- filter (F.ccIso obs . fst) obss = addFrags n ((obs, name):obss) todo -- reuse name
+ | otherwise = addFrags (n+1) ((obs, "F" ++ show n):obss) todo -- assign a name
+
+ mapM_ (printFrag env) (nubBy ((==) `on` snd) names)
+ putStrLn ""
+ mapM_ (printODE (Map.fromList names)) odes
+ where
+ printFrag :: E.Env -> (F.Obs, String) -> IO ()
+ printFrag env (obs, name) = putStrLn $ name ++ " := " ++ M.toKappa env obs
+
+ printODE :: Map.Map F.Obs String -> (F.Obs, F.ODE) -> IO ()
+ printODE names (obs, ode) = putStrLn $ names Map.! obs ++ " = " ++ odeRhs
+ where
+ odeRhs | null ode = "0"
+ | otherwise = intercalate " + " (map showODET ode)
+
+ showODET :: F.ODET -> String
+ showODET (rate, obss) = K.showAExpr rate ++ " " ++ intercalate " " (map (names Map.!) obss)
+
View
104 Fragmentation.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE TupleSections #-}
+
+module Fragmentation where
+
+import qualified Data.Vector as Vec
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import qualified KappaParser as KP
+import qualified Mixture as M
+import qualified Rule as R
+import Matching
+import Utils
+
+type Obs = M.Mixture
+type ODET = (R.Rate, [Obs]) -- ODE term
+type ODE = [ODET]
+type ODES = [(Obs, ODE)] -- ODE system, that is [( Obs, [(R.Rate, [Obs])] )]
+
+-- TODO check if the first two tests are any good for performance
+-- the first probably is, but the second one I'm not that sure
+ccIso :: M.Mixture -> M.Mixture -> Bool
+ccIso m1 m2 = agentCount m1 == agentCount m2 -- same amount of agents
+ && typeCount m1 == typeCount m2 -- same 'typing map'
+ && (agentCount m1 == 0 || any (match Set.empty Set.empty) anchors)
+ where
+ agentCount = Vec.length . M.agents
+ typeCount = frequencies . map M.agentName . agentList
+ agentList = Vec.toList . M.agents
+
+ anchors = return . (0, ) <$> M.agentIds m2
+
+ -- This function assumes the given m1 and m2 are connected components, it doesn't check if that's true.
+ -- That's why we return True when we don't have anything else in the todo list,
+ -- because that means we have visited all agents in both m1 and m2
+ match :: Set.Set M.AgentId -> Set.Set M.AgentId -> [(M.AgentId, M.AgentId)] -> Bool
+ match visited1 visited2 [] = True
+ match visited1 visited2 ((id1, id2) : todo)
+ | Set.member id1 visited1 && Set.member id2 visited2 = match visited1 visited2 todo -- TODO should I check that all nbs are visited?
+ | Set.member id1 visited1 = error "Fragmentation.ccIso.match: id1 visited but not id2"
+ | Set.member id2 visited2 = error "Fragmentation.ccIso.match: id2 visited but not id1"
+ | a1 == a2 = match (Set.insert id1 visited1) (Set.insert id2 visited2) (todo ++ nbs)
+ | otherwise = False
+ where
+ nbs = do (sId, (M.Site{ M.bindingState = M.Bound}, M.Site{ M.bindingState = M.Bound })) <- indexedList $ Vec.zip (M.interface a1) (M.interface a2)
+ let (nb1, _) = M.follow m1 (id1, sId) ? "Fragmentation.ccIso.match: disconnected graph (1)"
+ (nb2, _) = M.follow m2 (id2, sId) ? "Fragmentation.ccIso.match: disconnected graph (2)"
+ return (nb1, nb2)
+ -- nbsVisited = all (visited1 `Set.member`) (map fst nbs) && all (visited2 `Set.member`) (map snd nbs)
+
+ a1 = M.agents m1 Vec.!? id1 ? "Fragmentation.ccIso.match: agent id not found"
+ a2 = M.agents m2 Vec.!? id2 ? "Fragmentation.ccIso.match: agent id not found"
+
+
+fragment :: [R.Rule] -> [Obs] -> ODES
+fragment rules obss = fragment' obss []
+ where
+ fragment' :: [Obs] -> [Obs] -> ODES
+ fragment' [] _ = []
+ fragment' (obs:todo) visited
+ | any (ccIso obs) visited = fragment' todo visited
+ | otherwise = (obs, ode) : fragment' (todo ++ newFragments) (obs : visited)
+ where
+ ode = getODE obs =<< rules
+ newFragments = snd =<< ode
+
+ getODE :: Obs -> R.Rule -> ODE
+ getODE obs rule = lhsTerms ++ rhsTerms
+ where
+ (msitesLhs, msitesRhs) = R.modifiedSites rule
+ minglueingsLhs = minimalGlueings obs (R.lhs rule)
+ minglueingsRhs = minimalGlueings obs (R.rhs rule)
+
+ -- you have to filter out the minimal glueings that don't intersect in the pullback with the set of modified sites
+ -- when you glue on the left, the new observable is just the minimal glueing
+ -- when you glue on the right, the new observable is the inverse of the rule applied to the minimal glueing
+
+ lhsRelevantMG = filter (isRelevant msitesLhs (R.lhs rule)) minglueingsLhs
+ rhsRelevantMG = filter (isRelevant msitesRhs (R.rhs rule)) minglueingsRhs
+
+ isRelevant :: [M.Endpoint] -> M.Mixture -> (M.Mixture, Injection, Injection, M.Mixture) -> Bool
+ isRelevant msites m2 (m0, _, m2Inj, _) = any inPullback msites
+ where
+ inPullback (aId, sId) = agentInPullback && s0 `siteMatch` s2 -- TODO why should I check if s2 matches s0?
+ where id0 = m2Inj Map.! aId
+ s0 = M.interface (M.agents m0 Vec.! id0) Vec.! sId
+ s2 = M.interface (M.agents m2 Vec.! aId) Vec.! sId
+ agentInPullback = id0 < Vec.length (M.agents m0)
+
+ lhsTerms = (neg $ R.rate rule, ) <$> M.split <$> codomain <$> lhsRelevantMG
+ rhsTerms = ( R.rate rule, ) <$> M.split <$> invert rule <$> rhsRelevantMG
+
+ codomain (_, _, _, m3) = m3
+
+ invert :: R.Rule -> (M.Mixture, Injection, Injection, M.Mixture) -> M.Mixture
+ invert rule (_, _, rhsInj, m3) = R.apply invertedScript rhsInj m3
+ where invertedScript = R.actionScript (R.rhs rule) (R.lhs rule)
+
+
+neg :: KP.AExpr -> KP.AExpr
+neg (KP.Integer n) = KP.Integer (negate n)
+neg (KP.Float n) = KP.Float (negate n)
+neg x = KP.Duo KP.Mult (KP.Integer (-1)) x
+
View
28 KappaParser.hs
@@ -108,7 +108,8 @@ createChain first@(Agent fname fintf) second@(Agent sname sintf) last@(Agent lna
error $ "KappaParser.createChain: all agents in a chain must have the same sites in their interface"
| firstLink /= firstLink' =
error $ "KappaParser.createChain: first and second agents in chain must be bound by sites '" ++ rightSite ++ "' and '" ++ leftSite ++ "', respectively"
- | otherwise = first : take n agentsInChain ++ [last]
+ | otherwise =
+ first : take n agentsInChain ++ [last]
where
agentsInChain = iterate nextAgentInChain second
n = (lastLink - firstLink) `quot` step
@@ -135,17 +136,15 @@ createChain first@(Agent fname fintf) second@(Agent sname sintf) last@(Agent lna
hasSameSites :: Interface -> Interface -> Bool
hasSameSites i1 i2 = map siteName i1 == map siteName i2
-kexpr :: Parser KExpr
-kexpr = reverse . unpackChains [] [] <$> commaSep1 (liftM Right agent <|> liftM Left ellipsis) <?> "kappa expression"
- where
- ellipsis = reserved "..."
+unpackChains :: KExpr -> [Either () Agent] -> KExpr
+unpackChains acc [] = reverse acc
+unpackChains acc ((Right a1):(Right a2):(Left ()):(Right a3):xs) = unpackChains (reverse (createChain a1 a2 a3) ++ acc) xs
+unpackChains acc ((Right a):xs) = unpackChains (a:acc) xs
+unpackChains acc xs = error $ "malformed chain expression"
- unpackChains :: KExpr -> KExpr -> [Either () Agent] -> KExpr
- unpackChains acc [b2,b1] [] = b1:b2:acc
- unpackChains acc [b2,b1] ((Right a):xs) = unpackChains (b1:acc) [a,b2] xs
- unpackChains acc buf ((Right a):xs) = unpackChains acc (a:buf) xs
- unpackChains acc [b2,b1] ((Left _):(Right a):xs) = unpackChains (reverse (createChain b1 b2 a) ++ acc) [] xs
- unpackChains _ _ _ = error "malformed chain expression"
+kexpr :: Parser KExpr
+kexpr = unpackChains [] <$> commaSep1 (liftM Right agent <|> liftM Left ellipsis) <?> "kappa expression"
+ where ellipsis = reserved "..."
rule :: Parser Rule
rule = do lhs <- kexpr
@@ -310,11 +309,8 @@ obsP = do reserved "obs:"
varP :: Parser Var
varP = do name <- identifier
reservedOp "="
- ke <- kexpr
- if null ke
- then do ae <- aexpr
- return (name, Right ae)
- else return (name, Left ke)
+ expr <- liftM Left kexpr <|> liftM Right aexpr
+ return (name, expr)
energyShape :: Parser Shape
energyShape = do expr <- kexpr
View
141 Matching.hs
@@ -7,7 +7,6 @@ import Data.List (nub, partition, (\\))
import qualified Mixture as M
import qualified Env as E
-import qualified Types as T -- debug
import Utils
-- The idea here is to find all possible non-isomorphic superpositions of two or more kappa terms
@@ -17,28 +16,22 @@ type Matching = [(M.AgentId, M.AgentId)]
-- Match
-agentMatch :: M.Agent -> M.Agent -> Bool
-agentMatch a1 a2 = M.agentName a1 == M.agentName a2 &&
- Vec.all siteMatch (Vec.zip (M.interface a1) (M.interface a2))
+siteMatch :: M.Site -> M.Site -> Bool
+siteMatch s1 s2 = M.internalState s1 `intMatch` M.internalState s2
+ && M.bindingState s1 `lnkMatch` M.bindingState s2
where
- siteMatch :: (M.Site, M.Site) -> Bool
- siteMatch (s1, s2) = M.internalState s1 `intMatch` M.internalState s2 &&
- M.bindingState s1 `lnkMatch` M.bindingState s2
- where
- intMatch :: Maybe M.InternalStateId -> Maybe M.InternalStateId -> Bool
- intMatch Nothing Nothing = True
- intMatch (Just int1) (Just int2) | int1 == int2 = True
- | otherwise = False
- intMatch Nothing (Just _) = True
- intMatch (Just _) Nothing = False
-
- lnkMatch :: M.BindingState -> M.BindingState -> Bool
- lnkMatch M.Free M.Free = True
- lnkMatch M.Bound M.Bound = True
- lnkMatch M.SemiLink M.SemiLink = True
- lnkMatch M.SemiLink M.Bound = True
- lnkMatch M.Unspecified _ = True
- lnkMatch _ _ = False
+ intMatch :: Maybe M.InternalStateId -> Maybe M.InternalStateId -> Bool
+ intMatch Nothing _ = True
+ intMatch i1 i2 = i1 == i2
+
+ lnkMatch :: M.BindingState -> M.BindingState -> Bool
+ lnkMatch M.Unspecified _ = True
+ lnkMatch M.SemiLink M.Bound = True
+ lnkMatch b1 b2 = b1 == b2
+
+agentMatch :: M.Agent -> M.Agent -> Bool
+agentMatch a1 a2 = M.agentName a1 == M.agentName a2 -- same name
+ && Vec.and (Vec.zipWith siteMatch (M.interface a1) (M.interface a2)) -- and same interface
superpose :: M.Mixture -> M.Mixture -> [Matching]
superpose e1 e2 = fst <$> foldM match ([], M.agentsWithId e2) (M.agentsWithId e1) -- TODO verify links
@@ -220,102 +213,100 @@ intersections m1 m2 = nub $ do (agents, graph, m1Matching, m2Matching, _, _, _)
insertLink sId ep = M.addLink ep (id3, sId)
-type AgentMap = Map.Map M.AgentId M.AgentId
---data LinkInfo = T1 | T2 | T12 | None
+type Injection = Map.Map M.AgentId M.AgentId
data LinkInfo = T1 | T2 | None
--- TODO this should be :: [M.Mixture] -> [(M.Mixture, [AgentMap], M.Mixture)]
-minimalGlueings :: M.Mixture -> M.Mixture -> [(M.Mixture, AgentMap, AgentMap, M.Mixture)]
+-- TODO this should be :: [M.Mixture] -> [(M.Mixture, [Injection], M.Mixture)]
+minimalGlueings :: M.Mixture -> M.Mixture -> [(M.Mixture, Injection, Injection, M.Mixture)]
minimalGlueings m1 m2 =
do (m0, m1Matchings, m2Matchings) <- intersections m1 m2
- (m3, m1AgentMap , m2AgentMap ) <- refine m0 m1Matchings m2Matchings
- let (m3' , m1AgentMap') = addAndExtend m1 (m3 , m1AgentMap)
- (m3'', m2AgentMap') = addAndExtend m2 (m3', m2AgentMap)
- return (m0, m1AgentMap', m2AgentMap', m3'')
+ (m3, m1Inj, m2Inj) <- refine m0 m1Matchings m2Matchings
+ let (m3' , m1Inj') = addAndExtend m1 (m3 , m1Inj)
+ (m3'', m2Inj') = addAndExtend m2 (m3', m2Inj)
+ return (m0, m1Inj', m2Inj', m3'')
where
- refine :: M.Mixture -> Matching -> Matching -> [(M.Mixture, AgentMap, AgentMap)]
- refine m0 m1Matchings m2Matchings = foldM refineAgent (m0, m1AgentMap, m2AgentMap) (M.agentIds m0)
+ refine :: M.Mixture -> Matching -> Matching -> [(M.Mixture, Injection, Injection)]
+ refine m0 m1Matchings m2Matchings = foldM refineAgent (m0, m1Inj, m2Inj) (M.agentIds m0)
where
- m1AgentMap = Map.fromList m1Matchings
- m2AgentMap = Map.fromList m2Matchings
+ m1Inj = Map.fromList m1Matchings
+ m2Inj = Map.fromList m2Matchings
bwdMap = Map.fromList [ (id3, (id1, id2)) | [(id1, id3), (id2, _)] <- groupWith snd (m1Matchings ++ m2Matchings) ]
- refineAgent :: (M.Mixture, AgentMap, AgentMap) -> M.AgentId -> [(M.Mixture, AgentMap, AgentMap)]
+ refineAgent :: (M.Mixture, Injection, Injection) -> M.AgentId -> [(M.Mixture, Injection, Injection)]
refineAgent mg id3 = foldM refineSite' mg (M.siteIds a1) -- note that M.siteIds a1 == M.siteIds a2 == M.siteIds a3
where
(id1, id2) = bwdMap Map.! id3
a1 = M.agents m1 Vec.! id1
a2 = M.agents m2 Vec.! id2
- refineSite' :: (M.Mixture, AgentMap, AgentMap) -> M.SiteId -> [(M.Mixture, AgentMap, AgentMap)]
- refineSite' (m3, m1AgentMap, m2AgentMap) sId =
+ refineSite' :: (M.Mixture, Injection, Injection) -> M.SiteId -> [(M.Mixture, Injection, Injection)]
+ refineSite' (m3, m1Inj, m2Inj) sId =
do s3' <- toList $ siteUnify s1 s2
let a3' = a3{ M.interface = M.interface a3 Vec.// [(sId, s3')] }
m3' = m3{ M.agents = M.agents m3 Vec.// [(id3, a3')] }
+ -- TODO isn't there a better way to express this?
case linkInfo s1 s2 s3 of
- T1 -> let (m3'', m1AgentMap') = extend m1 [(id1, id3, sId)] (m3', m1AgentMap) in return (m3'', m1AgentMap', m2AgentMap)
- T2 -> let (m3'', m2AgentMap') = extend m2 [(id2, id3, sId)] (m3', m2AgentMap) in return (m3'', m1AgentMap, m2AgentMap')
- --T12 -> [] -- TODO is this the best way to handle the semilink creation when two sites are bound to different ends? probably I should not create the semilink in the first place
- None -> return (m3', m1AgentMap, m2AgentMap)
+ T1 -> let (m3'', m1Inj') = extend m1 [(id1, id3, sId)] (m3', m1Inj) in return (m3'', m1Inj', m2Inj)
+ T2 -> let (m3'', m2Inj') = extend m2 [(id2, id3, sId)] (m3', m2Inj) in return (m3'', m1Inj, m2Inj')
+ None -> return (m3', m1Inj, m2Inj)
where
a3 = M.agents m3 Vec.! id3
s1 = M.interface a1 Vec.! sId
s2 = M.interface a2 Vec.! sId
s3 = M.interface a3 Vec.! sId
- toList Nothing = []
+ toList Nothing = []
toList (Just x) = [x]
- addAndExtend :: M.Mixture -> (M.Mixture, AgentMap) -> (M.Mixture, AgentMap)
- addAndExtend m1 (m3, agentMap)
- | null remainingAgents = (m3, agentMap)
- | otherwise = extend m1 sites (m3', agentMap')
+ linkInfo :: M.Site -> M.Site -> M.Site -> LinkInfo
+ linkInfo s1 s2 s3
+ | M.isBound s1 && not (M.isBound s2) && not (M.isBound s3) = T1
+ | not (M.isBound s1) && M.isBound s2 && not (M.isBound s3) = T2
+ | otherwise = None
+
+ addAndExtend :: M.Mixture -> (M.Mixture, Injection) -> (M.Mixture, Injection)
+ addAndExtend m1 (m3, inj)
+ | null remainingAgents = (m3, inj)
+ | otherwise = addAndExtend m1 $ extend m1 sites (m3', inj')
where
- remainingAgents = M.agentIds m1 \\ Map.keys agentMap
- id1 = head remainingAgents
- id3 = Vec.length (M.agents m3)
- a1 = M.agents m1 Vec.! id1
- m3' = m3{ M.agents = Vec.snoc (M.agents m3) a1 } -- TODO beware!! Vec.snoc here!! possible memory leak!!
- agentMap' = Map.insert id1 id3 agentMap
+ remainingAgents = M.agentIds m1 \\ Map.keys inj
+ id1 = head remainingAgents
+ id3 = Vec.length (M.agents m3)
+ a1 = M.agents m1 Vec.! id1
+ m3' = m3{ M.agents = Vec.snoc (M.agents m3) a1 } -- TODO beware!! Vec.snoc here!! possible memory leak!!
+ inj' = Map.insert id1 id3 inj
sites = do (sId, M.Site{ M.bindingState = M.Bound }) <- M.sitesWithId a1
return (id1, id3, sId)
-extend :: M.Mixture -> [(M.AgentId, M.AgentId, M.SiteId)] -> (M.Mixture, AgentMap) -> (M.Mixture, AgentMap)
-extend m1 [] (m3, agentMap) = (m3, agentMap)
-extend m1 ((id1, id3, sId):sites) (m3, agentMap)
- | nbId1 `Map.member` agentMap = extend m1 sites (M.bind (id3, sId) (nbId3, nbSiteId) m3 , agentMap )
- | otherwise = extend m1 (sites ++ sites') (M.bind (id3, sId) (nbId3, nbSiteId) m3', agentMap')
+extend :: M.Mixture -> [(M.AgentId, M.AgentId, M.SiteId)] -> (M.Mixture, Injection) -> (M.Mixture, Injection)
+extend m1 [] (m3, inj) = (m3, inj)
+extend m1 ((id1, id3, sId):sites) (m3, inj)
+ | nbId1 `Map.member` inj = extend m1 sites (M.bind (id3, sId) (nbId3, nbSiteId) m3 , inj )
+ | otherwise = extend m1 (sites ++ sites') (M.bind (id3, sId) (nbId3, nbSiteId) m3', inj')
where
(nbId1, nbSiteId) = M.follow m1 (id1, sId) ? "Matching.extend: missing link"
- nbId3 = Map.findWithDefault nbId3' nbId1 agentMap
+ nbId3 = Map.findWithDefault nbId3' nbId1 inj
nbId3' = Vec.length (M.agents m3)
-- add neighbour
- nb1 = M.agents m1 Vec.! nbId1
- m3' = m3{ M.agents = Vec.snoc (M.agents m3) nb1 }
- agentMap' = Map.insert nbId1 nbId3 agentMap
+ nb1 = M.agents m1 Vec.! nbId1
+ m3' = m3{ M.agents = Vec.snoc (M.agents m3) nb1 } -- Beware! Vec.snoc here! possible memory leak!!
+ inj' = Map.insert nbId1 nbId3 inj
-- collect new sites from nb1
sites' = do (nbSiteId', M.Site{ M.bindingState = M.Bound }) <- M.sitesWithId nb1
guard $ nbSiteId /= nbSiteId'
return (nbId1, nbId3, nbSiteId')
-linkInfo :: M.Site -> M.Site -> M.Site -> LinkInfo
-linkInfo s1 s2 s3
- | M.isBound s1 && not (M.isBound s2) && not (M.isBound s3) = T1
- | not (M.isBound s1) && M.isBound s2 && not (M.isBound s3) = T2
--- | M.isBound s1 && M.isBound s2 && not (M.isBound s3) = T12
- | otherwise = None
-
{-
where
- extend :: M.Mixture -> Matching -> Matching -> [(M.Mixture, (AgentMap, AgentMap))]
- extend m3 m1Matchings m2Matchings = extend' m3 m1AgentMap m2AgentMap sitesInM3
+ extend :: M.Mixture -> Matching -> Matching -> [(M.Mixture, (Injection, Injection))]
+ extend m3 m1Matchings m2Matchings = extend' m3 m1Inj m2Inj sitesInM3
where
- m1AgentMap = Map.fromList m1Matchings
- m2AgentMap = Map.fromList m2Matchings
+ m1Inj = Map.fromList m1Matchings
+ m2Inj = Map.fromList m2Matchings
bwdMap = Map.fromList [ (id3, (id1, id2)) | [((id1, id3), (id2, _))] <- groupWith snd (m1Matchings ++ m2Matchings) ]
sitesInM3 = do (id3, a3) <- M.agentsWithId m3
@@ -328,9 +319,9 @@ linkInfo s1 s2 s3
(s3', linkInfo) <- refineSite s1 s2 s3 -- this should be a Maybe
return (id3, (sId, (s3', linkInfo)))
- --extend' :: [(M.AgentId, (M.SiteId, (M.Site, LinkInfo)))] -> [(M.Mixture, (AgentMap, AgentMap))]
- refineAndExtend m3 m1AgentMap m2AgentMap [] = ...
- refineAndExtend m3 m1AgentMap m2AgentMap sitesInM3 = foldr extendSite
+ --extend' :: [(M.AgentId, (M.SiteId, (M.Site, LinkInfo)))] -> [(M.Mixture, (Injection, Injection))]
+ refineAndExtend m3 m1Inj m2Inj [] = ...
+ refineAndExtend m3 m1Inj m2Inj sitesInM3 = foldr extendSite
where m3' = m3{ M.agents = M.agents m3 Vec.// refinedAgents }
refinedAgents = do (id3, sitesInA3) <- fst . head |.| map snd <$> groupWith fst sitesInM3
View
85 Mixture.hs
@@ -15,11 +15,11 @@ import Utils
-- Sites
type InternalStateId = Int
data BindingState = Free | SemiLink | Bound | Unspecified -- WLD = Unspecified
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
data Site = Site { internalState :: Maybe InternalStateId
, bindingState :: BindingState
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
type SiteId = Int
type Interface = Vec.Vector Site -- indexed by SiteId
@@ -28,7 +28,7 @@ type Interface = Vec.Vector Site -- indexed by SiteId
data Agent = Agent { agentName :: E.AgentNameId
, interface :: Interface
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
foldInterface :: (SiteId -> Site -> a -> a) -> a -> Agent -> a
foldInterface f acc = Vec.ifoldr f acc . interface
@@ -85,7 +85,7 @@ type Graph = Map.Map Endpoint Endpoint
data Mixture = Mixture { agents :: Agents
, graph :: Graph
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
empty :: Mixture
empty = Mixture{ agents = Vec.empty
@@ -101,36 +101,40 @@ agentsWithId = indexedList . agents
data Link = Link AgentId SiteId
| Closed
type LinkMap = Map.Map KP.BondLabel Link
+data Context = Ctxt { freshId :: !AgentId
+ , linkMap :: !LinkMap
+ }
-addAgent :: E.Env -> Bool -> ([Agent], Graph, LinkMap, AgentId) -> KP.Agent -> ([Agent], Graph, LinkMap, AgentId)
-addAgent env isPattern (!mix, !graph, !linkMap, !agentId) (KP.Agent agentName intf) = (agent:mix, graph', linkMap', agentId+1)
+evalAgent :: E.Env -> Bool -> ([Agent], Graph, LinkMap, AgentId) -> KP.Agent -> ([Agent], Graph, LinkMap, AgentId)
+evalAgent env isPattern (!mix, !graph, !linkMap, !agentId) (KP.Agent agentName intf) = (agent:mix, graph', linkMap', agentId+1)
where
agent = Agent{ agentName = agentNameId
, interface = interface
}
- agentNameId = E.idOfAgent env agentName ? "Mixture.addAgent: " ++ missingAgent agentName
+ agentNameId = E.idOfAgent env agentName ? "Mixture.evalAgent: agent '" ++ agentName ++ "' is not mentioned in contact map"
+ missingSite siteName = "site '" ++ siteName ++ "' in agent '" ++ agentName ++ "' is not mentioned in contact map"
interface = emptyInterface env agentNameId Vec.// sites
sites = map getSite intf
getSite (KP.Site siteName int lnk) = (siteId, Site { internalState = internalStateId int
, bindingState = bindingState lnk
})
- where siteId = E.idOfSite env (agentNameId, siteName) ? "Mixture.addAgent: " ++ missingSite agentName siteName
+ where siteId = E.idOfSite env (agentNameId, siteName) ? "Mixture.evalAgent: " ++ missingSite siteName
internalStateId "" | isPattern = Nothing
| otherwise = Just (E.defaultInternalState env (agentNameId, siteId))
internalStateId intState = Just int
- where int = E.idOfIntState env (agentNameId, siteId, intState) ? "Mixture.addAgent: " ++ missingIntState agentName siteName intState
+ where int = E.idOfIntState env (agentNameId, siteId, intState) ? "Mixture.evalAgent: internal state '" ++ intState ++ "' in agent '" ++ agentName ++ "' and site '" ++ siteName ++ "' is not mentioned in contact map"
bindingState KP.Free = Free
bindingState (KP.Bound _) = Bound
bindingState KP.SemiLink | isPattern = SemiLink
- | otherwise = error "Mixture.addAgent: only patterns are allowed to have semi links"
+ | otherwise = error "Mixture.evalAgent: only patterns are allowed to have semi links"
bindingState KP.Unspecified | isPattern = Unspecified
- | otherwise = error "Mixture.addAgent: only patterns are allowed to have unspecified binding states"
+ | otherwise = error "Mixture.evalAgent: only patterns are allowed to have unspecified binding states"
links = do (KP.Site siteName _ (KP.Bound bondLabel)) <- intf
- let siteId = E.idOfSite env (agentNameId, siteName) ? "Mixture.addAgent: " ++ missingSite agentName siteName
+ let siteId = E.idOfSite env (agentNameId, siteName) ? "Mixture.evalAgent: " ++ missingSite siteName
return (siteId, bondLabel)
(graph', linkMap') = foldl' updateGraph (graph, linkMap) links
@@ -139,16 +143,16 @@ addAgent env isPattern (!mix, !graph, !linkMap, !agentId) (KP.Agent agentName in
case Map.lookup bondLabel linkMap of
Nothing -> ( graph, Map.insert bondLabel (Link agentId siteId) linkMap)
Just (Link b j) -> (addLink (agentId, siteId) (b, j) graph, Map.insert bondLabel Closed linkMap)
- Just Closed -> error $ "Mixture.addAgent: bond label " ++ show bondLabel ++ " is binding more than two sites"
+ Just Closed -> error $ "Mixture.evalAgent: bond label " ++ show bondLabel ++ " is binding more than two sites"
evalKExpr :: E.Env -> Bool -> KP.KExpr -> Mixture
evalKExpr env isPattern kexpr
| not $ null incompleteBonds = error $ "Mixture.evalKExpr: incomplete bond(s) " ++ show incompleteBonds
- | otherwise = Mixture { agents = Vec.fromList $ reverse agents
+ | otherwise = Mixture { agents = Vec.fromList $ reverse agents -- TODO I can probably save this reverse if I leave out the reverse in KP.unpackChains
, graph = graph
}
- where (agents, graph, linkMap, _) = foldl' (addAgent env isPattern) ([], Map.empty, Map.empty, 0) kexpr
+ where (agents, graph, linkMap, _) = foldl' (evalAgent env isPattern) ([], Map.empty, Map.empty, 0) kexpr
incompleteBonds = map fst $ filter (not . isClosed . snd) (Map.toList linkMap)
isClosed Closed = True
isClosed _ = False
@@ -165,12 +169,12 @@ removeLink ep1 ep2 = Map.delete ep1 . Map.delete ep2
setLnkInMix :: BindingState -> Endpoint -> Mixture -> Mixture
setLnkInMix lnk (aId, sId) mix = mix{ agents = agents mix Vec.// [(aId, a')] }
- where a = agents mix Vec.!? aId ? "Mixture.setLnk: agent id not found"
+ where a = agents mix Vec.!? aId ? "Mixture.setLnk: agent id not found"
a' = setLnk lnk a sId
setIntInMix :: Maybe InternalStateId -> Endpoint -> Mixture -> Mixture
setIntInMix int (aId, sId) mix = mix{ agents = agents mix Vec.// [(aId, a')] }
- where a = agents mix Vec.!? aId ? "Mixture.setLnk: agent id not found"
+ where a = agents mix Vec.!? aId ? "Mixture.setLnk: agent id not found"
a' = setInt int a sId
bind :: Endpoint -> Endpoint -> Mixture -> Mixture
@@ -226,18 +230,45 @@ valid mix@(Mixture{ graph = graph }) = all isInMix (Map.toList graph) && Vec.all
isInGraph ep1 = (Map.lookup ep1 graph >>= flip Map.lookup graph) == Just ep1
--- Error reporting
-missingAgent :: KP.AgentName -> String
-missingAgent agentName =
- "agent '" ++ agentName ++ "' is not mentioned in contact map"
+-- Connected components
+type AgentIdSet = Set.Set AgentId
-missingSite :: KP.AgentName -> KP.SiteName -> String
-missingSite agentName siteName =
- "site '" ++ siteName ++ "' in agent '" ++ agentName ++ "' is not mentioned in contact map"
+-- Returns the list with all the agents that are in the same component as agentId
+component :: Mixture -> AgentId -> AgentIdSet
+component Mixture{ agents = agents, graph = graph } agentId = explore [agentId] Set.empty
+ where explore :: [AgentId] -> AgentIdSet -> AgentIdSet
+ explore [] visited = visited
+ explore (aId:todo) visited
+ | Set.member aId visited = explore todo visited -- skip this agent
+ | otherwise = explore (todo ++ nbs) (Set.insert aId visited)
+ where
+ nbs = do (sId, Site{ bindingState = Bound }) <- sitesWithId (agents Vec.!? aId ? "Mixture.component: agent id '" ++ show aId ++ "' not found")
+ return . fst $ graph Map.! (aId, sId)
+
+components :: Mixture -> [AgentIdSet]
+components mix = components' [] (Set.fromList $ agentIds mix)
+ where components' acc ids
+ | Set.null ids = acc
+ | otherwise = components' (cc:acc) (ids Set.\\ cc)
+ where cc = component mix (Set.findMin ids)
+
+split :: Mixture -> [Mixture]
+split mix = map (inducedSSG mix . Set.elems) (components mix)
+
+-- SSG = site-subgraph
+inducedSSG :: Mixture -> [AgentId] -> Mixture
+inducedSSG mix ids = foldr (setLnkInMix SemiLink) mix' semilinks
+ where mix' = Mixture{ agents = agents', graph = graph' }
+ agents' = Vec.backpermute (agents mix) (Vec.fromList ids)
+
+ amap = zipmap ids [0..] -- map the original agent ids onto their new ids
+ (graph', semilinks) = Map.foldrWithKey updateId (Map.empty, []) (graph mix)
+ updateId (a, i) (b, j) (graph, semilinks)
+ | Map.member a amap && Map.member b amap = (Map.insert (amap Map.! a, i) (amap Map.! b, j) graph, semilinks)
+ | Map.member a amap = (graph, (amap Map.! a, i) : semilinks)
+ | Map.member b amap = (graph, (amap Map.! b, j) : semilinks)
+ | otherwise = (graph, semilinks)
-missingIntState :: KP.AgentName -> KP.SiteName -> KP.InternalState -> String
-missingIntState agentName siteName intState =
- "internal state '" ++ intState ++ "' in agent '" ++ agentName ++ "' and site '" ++ siteName ++ "' is not mentioned in contact map"
{- Old code
View
7 README.md
@@ -16,3 +16,10 @@ Usage: `./MinimalGlueings inputfile.ka`
The input file must contain two Kappa expressions separated by a semicolon.
The program will generate one DOT file with all minimal glueings in textual representation plus one DOT file for each minimal glueing detailing agent mappings in a graphical way.
+
+## Additional Tools
+### Frag
+
+Compile: `ghc --make -O Frag`
+
+Usage: `./MinimalGlueings inputfile.ka n` where `n` is the maximum number of differential equations to print (there can be a infinite number of them, that's why).
View
141 Rule.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE TupleSections #-}
+
+module Rule where
+
+import qualified Data.Vector as Vec
+import qualified Data.Map as Map
+import Data.Maybe (catMaybes)
+
+import qualified KappaParser as KP
+import qualified Mixture as M
+import qualified Env as E
+import Utils
+import PlainKappa (showAExpr)
+
+type Injection = Map.Map M.AgentId M.AgentId -- TODO should this be here or in Matching or elsewhere?
+
+data Action = Mod M.Endpoint M.InternalStateId
+ | Bnd M.Endpoint M.Endpoint
+ | Brk M.Endpoint
+ | Add M.Agent
+ | Del M.AgentId
+ deriving (Show, Eq)
+
+type Rate = KP.Rate
+data Rule = Rule { lhs :: M.Mixture
+ , rhs :: M.Mixture
+ , rate :: Rate
+ , isReversible :: Bool
+ --, action :: [Action]
+ }
+ deriving (Show, Eq)
+
+evalRule :: E.Env -> KP.Rule -> Rule
+evalRule env (KP.Rule isReversible lhs rhs rate) =
+ Rule { lhs = M.evalKExpr env True lhs
+ , rhs = M.evalKExpr env True rhs
+ , rate = rate
+ , isReversible = isReversible
+ }
+
+
+-- I adhere to the simpler convention
+largestPrefix' :: M.Mixture -> M.Mixture -> Int
+largestPrefix' lhs rhs = fromMaybe (Vec.length zippedAgents) (Vec.findIndex isDiff zippedAgents)
+ where zippedAgents = Vec.zip (M.agents lhs) (M.agents rhs)
+ isDiff (l, r) = M.agentName l /= M.agentName r
+
+largestPrefix :: Rule -> Int
+largestPrefix rule = largestPrefix' (lhs rule) (rhs rule)
+
+
+data RuleEndpoint = Lhs M.Endpoint
+ | Rhs M.Endpoint
+ | Common M.Endpoint
+
+modifiedSites :: Rule -> ([M.Endpoint], [M.Endpoint])
+modifiedSites rule = (concatMap diff common ++ concatMap add deleted, concatMap diff common ++ concatMap add added)
+ where
+ prefixId = largestPrefix rule
+ l = M.agents $ lhs rule
+ r = M.agents $ rhs rule
+ common = Vec.toList . Vec.take prefixId . Vec.indexed $ Vec.zip l r
+ deleted = Vec.toList . Vec.drop prefixId $ Vec.indexed l
+ added = Vec.toList . Vec.drop prefixId $ Vec.indexed r
+
+ add :: (M.AgentId, M.Agent) -> [M.Endpoint]
+ add (id, agent) = (id, ) <$> M.siteIds agent
+
+ diff :: (M.AgentId, (M.Agent, M.Agent)) -> [M.Endpoint]
+ diff (id, (aLhs, aRhs)) = (id, ) <$> Vec.toList sIds
+ where sIds = Vec.findIndices (uncurry (/=)) (Vec.zip (M.interface aLhs) (M.interface aRhs))
+
+
+actionScript :: M.Mixture -> M.Mixture -> [Action]
+actionScript lhs rhs = map Add added ++ removeDups [] (concatMap diff common) ++ map Del deletedIds
+ where
+ prefixId = largestPrefix' lhs rhs
+ l = M.agents lhs
+ r = M.agents rhs
+ common = Vec.toList . Vec.take prefixId . Vec.indexed $ Vec.zip l r
+ added = Vec.toList $ Vec.drop prefixId r
+ deletedIds = [prefixId..Vec.length l - 1]
+
+ diff :: (M.AgentId, (M.Agent, M.Agent)) -> [Action]
+ diff (aId, (al, ar)) = intActions ++ lnkActions
+ where
+ intActions = concatMap (uncurry intDiff) sites
+ lnkActions = concatMap (uncurry lnkDiff) sites
+ sites = indexedList $ Vec.zip (M.interface al) (M.interface ar)
+
+ intDiff sId (M.Site{ M.internalState = Just x }, M.Site{ M.internalState = Just y })
+ | x == y = []
+ | otherwise = [Mod (aId, sId) y]
+ intDiff sId (M.Site{ M.internalState = Nothing }, M.Site{ M.internalState = Just x }) = [Mod (aId, sId) x]
+ intDiff _ _ = [] -- DCDW!
+
+ lnkDiff sId (M.Site{ M.bindingState = M.Bound }, M.Site{ M.bindingState = M.Bound })
+ | nbl == nbr = []
+ | otherwise = [break sId, bind sId] -- link permutation!
+ where
+ nbl = M.follow lhs (aId, sId) ? "Rule.actionScript: oops"
+ nbr = M.follow rhs (aId, sId) ? "Rule.actionScript: oops"
+ lnkDiff sId (M.Site{ M.bindingState = M.SemiLink }, M.Site{ M.bindingState = M.Bound }) = [break sId, bind sId]
+ lnkDiff sId (M.Site{ M.bindingState = M.Bound }, M.Site{ M.bindingState = M.SemiLink }) = error "Rule.actionScript: bound -> semilink"
+ lnkDiff sId (M.Site{ M.bindingState = M.Bound }, M.Site{ M.bindingState = M.Free }) = [break sId]
+ lnkDiff sId (M.Site{ M.bindingState = M.Free }, M.Site{ M.bindingState = M.Bound }) = [bind sId]
+ lnkDiff sId (M.Site{ M.bindingState = M.Unspecified }, M.Site{ M.bindingState = M.Bound }) = [break sId, bind sId]
+ lnkDiff sId (M.Site{ M.bindingState = M.Unspecified }, M.Site{ M.bindingState = M.SemiLink }) = error "Rule.actionScript: unspecified -> semilink"
+ lnkDiff sId (M.Site{ M.bindingState = M.Unspecified }, M.Site{ M.bindingState = M.Free }) = [break sId]
+ lnkDiff _ _ = [] -- DCDW
+
+ break sId = Brk (aId, sId)
+ bind sId = Bnd (aId, sId) nb
+ where nb = M.follow rhs (aId, sId) ? "Rule.actionScript: no link for " ++ show (aId, sId)
+
+ removeDups acc [] = acc
+ removeDups acc (x@(Bnd (a, i) (b, j)) : xs) = removeDups (x:acc) (filter (/= Bnd (b, j) (a, i)) xs)
+ removeDups acc (x@(Brk (a, i)) : xs) = removeDups (x:acc) xs'
+ where xs' | Just (b, j) <- M.follow lhs (a, i) = filter (/= Brk (b, j)) xs
+ | otherwise = xs
+ removeDups acc (x:xs) = removeDups (x:acc) xs
+
+-- TODO How should I handle binding to new agents?
+apply :: [Action] -> Injection -> M.Mixture -> M.Mixture
+apply [] _ mix = mix
+apply (Mod (aId, sId) x : actions) inj mix = apply actions inj $ M.setIntInMix (Just x) (inj !? aId ? "error 1", sId) mix
+apply (Bnd (a, i) (b, j) : actions) inj mix = apply actions inj $ M.bind (inj !? a ? "error 2", i) (inj !? b ? "error 3: " ++ show (a, i) ++ " binds " ++ show (b, j) ++ " in " ++ show mix ++ " (emb: " ++ show inj ++ ")", j) mix
+apply (Brk (a, i) : actions) inj mix = apply actions inj $ M.unbind (inj !? a ? "error 4", i) mix
+apply (Add agent : actions) inj mix = apply actions inj mix{ M.agents = M.agents mix `Vec.snoc` agent } -- Beware! Vec.snoc = memory leak!!
+apply (Del aId : actions) inj mix = apply actions inj mix'{ M.agents = prefix Vec.++ Vec.tail suffix }
+ where
+ sites = map fst $ filter (M.isBound . snd) (indexedList . M.interface $ M.agents mix Vec.! aId')
+ aId' = inj !? aId ? "error 5"
+ mix' = foldr unbind mix sites
+ unbind sId mix = M.unbind (aId', sId) mix
+ (prefix, suffix) = Vec.splitAt aId' (M.agents mix')
+
+
+toKappa :: E.Env -> Rule -> String
+toKappa env rule = M.toKappa env (lhs rule) ++ " -> " ++ M.toKappa env (rhs rule) ++ " @ " ++ showAExpr (rate rule)
+
View
10 Utils.hs
@@ -1,9 +1,9 @@
module Utils( fromMaybe
, foldl', sortWith, groupWith
- , (?), updateVec
+ , (?), (!?), updateVec
, foldM, liftM, join, guard, joinMaybes, select, (<$>)
, zipmap, mapKeys, reverseMap
- , (|.|)
+ , (|.|), on
, frequencies, repeatedElems
, infinity, cartesianProduct, combinationsOf, combinations
, indexedList
@@ -15,6 +15,7 @@ import Data.Maybe (fromMaybe, fromJust)
import Control.Monad
import Data.List (foldl', group, sort, find)
import Data.Tuple (swap)
+import Data.Function (on)
import Data.Functor ((<$>))
import GHC.Exts (sortWith, groupWith)
@@ -23,6 +24,11 @@ infixr 1 ?
(?) :: Maybe a -> String -> a
x ? s = fromMaybe (error s) x
+-- maybe I should generalise this into a Lookupable class
+infixr 9 !?
+(!?) :: Ord k => Map.Map k v -> k -> Maybe v
+m !? k = Map.lookup k m
+
updateVec :: Vec.Vector a -> [(Int, a)] -> String -> Vec.Vector a
updateVec vec vals fnName = if all (< len) indices
then Vec.unsafeUpd vec vals -- is Vec.force needed here?
Please sign in to comment.
Something went wrong with that request. Please try again.