INblobs-0.1.1: src/INRule.hs

{-| Module     : INRule
    Maitainer  : jmvilaca@di.uminho.pt

    
-}

module INRule 
    ( INRule
    , Mapping
    , MappingElement 
    , initial

    , getName,    setName
    , getLHS,     setLHS
    , getRHS,     setRHS
    , getMapping, setMapping
    , construct
   
    , updateLHS
    , updateRHS
    , updateMapping
    , copyLHS2RHS
    , copyLHSInterface2RHS
 
    , addMapping
    , showsMapping
    , isInterfaceNode
    ) where

import Network hiding (getName, setName) 
import Ports
import InfoKind
import Common
import qualified Data.IntMap as IntMap (empty)
import SpecialSymbols

import Data.List


data INRule g n e = INRule 
   { ruleName :: String                 -- ^ the name of the rule
   , ruleLHS  :: Network g n e  -- ^ the rule LHS network 
   , ruleRHS  :: Network g n e  -- ^ the rule RHS network 
   , ruleMaps :: Mapping                -- ^ mappings between the LHS and RHS
   } deriving (Show)

-- | @(n_i, n_j)@ means that node n_i in the LHS of the rule corresponds to node n_j in the RHS
-- @n_i@ and @n_j@ have to be interface nodes
type MappingElement = (NodeNr, NodeNr)
type Mapping = [MappingElement] 

showsMapping :: Mapping -> ShowS
showsMapping [] = showString "{}"
showsMapping (x:xs) =
	showChar '{' . showsE x . showl xs
  where showl []     = showChar '}'
	showl (x:xs) = showChar ',' . showsE x . showl xs
	showsE (from,to) = shows from . showString " |-> " . shows to

initial :: (InfoKind e g, InfoKind n g) => g -> n -> e -> INRule g n e
initial g n e =
   INRule { ruleName = "Rule 1"
           , ruleLHS  = Network.empty g n e 
           , ruleRHS  = Network.empty g n e
           , ruleMaps = []
   }

-- Set's e Get's
getName :: INRule g n e -> String
getName = ruleName

getLHS :: INRule g n e -> Network g n e
getLHS = ruleLHS 

getRHS :: INRule g n e -> Network g n e
getRHS = ruleRHS

getMapping :: INRule g n e -> Mapping
getMapping = ruleMaps

setName :: String -> INRule g n e -> INRule g n e
setName newRuleName rule = rule { ruleName = newRuleName}

setLHS :: Network g n e -> INRule g n e -> INRule g n e
setLHS newRuleLHS rule = rule { ruleLHS = newRuleLHS}

setRHS :: Network g n e -> INRule g n e -> INRule g n e
setRHS newRuleRHS rule = rule { ruleRHS = newRuleRHS}

setMapping :: Mapping -> INRule g n e -> INRule g n e
setMapping newRuleMaps rule = rule { ruleMaps = newRuleMaps}

construct :: String                   -- ^ rule name
             -> Network g n e -- ^ lhs
             -> Network g n e -- ^ rhs
             -> Mapping               -- ^ correspondences between 
                                      -- lhs and rhs interface
             -> INRule g n e
construct theRuleName lhs rhs mapping =
    INRule { ruleName = theRuleName
           , ruleLHS  = lhs 
           , ruleRHS  = rhs
           , ruleMaps = mapping
           }

-- update LHS and RHS networks and mapping

updateLHS :: (Network g n e -> Network g n e)
             -> INRule g n e -> INRule g n e
updateLHS networkFun rule = rule { ruleLHS = networkFun $ ruleLHS rule }

updateRHS :: (Network g n e -> Network g n e)
             -> INRule g n e -> INRule g n e
updateRHS networkFun rule = rule { ruleRHS = networkFun $ ruleRHS rule }

updateMapping :: (Mapping -> Mapping)
                  -> INRule g n e -> INRule g n e
updateMapping mapFun rule = rule { ruleMaps = mapFun $ ruleMaps rule }

copyLHS2RHS :: INRule g n e -> INRule g n e
copyLHS2RHS rule = 
   rule { ruleRHS  = lhs
        , ruleMaps = map (diag . fst) . filter isInterfaceNode $ getNodeAssocs lhs
        }
   where lhs = ruleLHS rule

copyLHSInterface2RHS :: INRule g n e -> INRule g n e
copyLHSInterface2RHS rule = 
   rule { ruleRHS  = setNodeAssocs lhs' . emptyNodesAndEdges $ ruleRHS rule                      
        , ruleMaps = map (diag . fst) $ lhs'
        }
   where lhs' = filter isInterfaceNode . getNodeAssocs $ ruleLHS rule
         emptyNodesAndEdges net = net { networkNodes = IntMap.empty
                                      , networkEdges = IntMap.empty }
                         
-- operations on Mappings
addMapping :: MappingElement -> Mapping -> Mapping
addMapping = insert  

-- auxiliar functions
isInterfaceNode :: (NodeNr, Node n) -> Bool
isInterfaceNode (_, node) = getShape node == interName
	where (interName, interDef) = interfaceSymbol