darcs - INblobs

1 {-| Module : INRule

2 Maitainer : jmvilaca@di.uminho.pt

5 -}

7 module INRule

8 ( INRule

9 , Mapping

10 , MappingElement

11 , initial

13 , getName, setName

14 , getLHS, setLHS

15 , getRHS, setRHS

16 , getMapping, setMapping

17 , construct

19 , updateLHS

20 , updateRHS

21 , updateMapping

22 , copyLHS2RHS

23 , copyLHSInterface2RHS

25 , addMapping

26 , showsMapping

27 , isInterfaceNode

28 ) where

30 import Network hiding (getName, setName)

31 import Ports

32 import InfoKind

33 import Common

34 import qualified Data.IntMap as IntMap (empty)

35 import SpecialSymbols

37 import Data.List

40 data INRule g n e = INRule

41 { ruleName :: String -- ^ the name of the rule

42 , ruleLHS :: Network g n e -- ^ the rule LHS network

43 , ruleRHS :: Network g n e -- ^ the rule RHS network

44 , ruleMaps :: Mapping -- ^ mappings between the LHS and RHS

45 } deriving (Show)

47 -- | @(n_i, n_j)@ means that node n_i in the LHS of the rule corresponds to node n_j in the RHS

48 -- @n_i@ and @n_j@ have to be interface nodes

49 type MappingElement = (NodeNr, NodeNr)

50 type Mapping = [MappingElement]

52 showsMapping :: Mapping -> ShowS

53 showsMapping [] = showString "{}"

54 showsMapping (x:xs) =

55 showChar '{' . showsE x . showl xs

56 where showl [] = showChar '}'

57 showl (x:xs) = showChar ',' . showsE x . showl xs

58 showsE (from,to) = shows from . showString " |-> " . shows to

60 initial :: (InfoKind e g, InfoKind n g) => g -> n -> e -> INRule g n e

61 initial g n e =

62 INRule { ruleName = "Rule 1"

63 , ruleLHS = Network.empty g n e

64 , ruleRHS = Network.empty g n e

65 , ruleMaps = []

66 }

68 -- Set's e Get's

69 getName :: INRule g n e -> String

70 getName = ruleName

72 getLHS :: INRule g n e -> Network g n e

73 getLHS = ruleLHS

75 getRHS :: INRule g n e -> Network g n e

76 getRHS = ruleRHS

78 getMapping :: INRule g n e -> Mapping

79 getMapping = ruleMaps

81 setName :: String -> INRule g n e -> INRule g n e

82 setName newRuleName rule = rule { ruleName = newRuleName}

84 setLHS :: Network g n e -> INRule g n e -> INRule g n e

85 setLHS newRuleLHS rule = rule { ruleLHS = newRuleLHS}

87 setRHS :: Network g n e -> INRule g n e -> INRule g n e

88 setRHS newRuleRHS rule = rule { ruleRHS = newRuleRHS}

90 setMapping :: Mapping -> INRule g n e -> INRule g n e

91 setMapping newRuleMaps rule = rule { ruleMaps = newRuleMaps}

93 construct :: String -- ^ rule name

94 -> Network g n e -- ^ lhs

95 -> Network g n e -- ^ rhs

96 -> Mapping -- ^ correspondences between

97 -- lhs and rhs interface

98 -> INRule g n e

99 construct theRuleName lhs rhs mapping =

100 INRule { ruleName = theRuleName

101 , ruleLHS = lhs

102 , ruleRHS = rhs

103 , ruleMaps = mapping

104 }

105

106 -- update LHS and RHS networks and mapping

107

108 updateLHS :: (Network g n e -> Network g n e)

109 -> INRule g n e -> INRule g n e

110 updateLHS networkFun rule = rule { ruleLHS = networkFun $ ruleLHS rule }

111

112 updateRHS :: (Network g n e -> Network g n e)

113 -> INRule g n e -> INRule g n e

114 updateRHS networkFun rule = rule { ruleRHS = networkFun $ ruleRHS rule }

115

116 updateMapping :: (Mapping -> Mapping)

117 -> INRule g n e -> INRule g n e

118 updateMapping mapFun rule = rule { ruleMaps = mapFun $ ruleMaps rule }

119

120 copyLHS2RHS :: INRule g n e -> INRule g n e

121 copyLHS2RHS rule =

122 rule { ruleRHS = lhs

123 , ruleMaps = map (diag . fst) . filter isInterfaceNode $ getNodeAssocs lhs

124 }

125 where lhs = ruleLHS rule

126

127 copyLHSInterface2RHS :: INRule g n e -> INRule g n e

128 copyLHSInterface2RHS rule =

129 rule { ruleRHS = setNodeAssocs lhs' . emptyNodesAndEdges $ ruleRHS rule

130 , ruleMaps = map (diag . fst) $ lhs'

131 }

132 where lhs' = filter isInterfaceNode . getNodeAssocs $ ruleLHS rule

133 emptyNodesAndEdges net = net { networkNodes = IntMap.empty

134 , networkEdges = IntMap.empty }

135

136 -- operations on Mappings

137 addMapping :: MappingElement -> Mapping -> Mapping

138 addMapping = insert

139

140 -- auxiliar functions

141 isInterfaceNode :: (NodeNr, Node n) -> Bool

142 isInterfaceNode (_, node) = getShape node == interName

143 where (interName, interDef) = interfaceSymbol

144