Changeset 11825

Timestamp:

19.06.2009 18:33:04 (9 months ago)

Author:

maeder

Message:

corrected map composition

Location:

trunk

Files:

• CASL/Morphism.hs (modified) (2 diffs)
• Common/Utils.hs (modified) (1 diff)
• CspCASL/Morphism.hs (modified) (4 diffs)
• HasCASL/Morphism.hs (modified) (3 diffs)
• HasCASL/SymbolMapAnalysis.hs (modified) (2 diffs)
• RelationalScheme/Sign.hs (modified) (3 diffs)

trunk/CASL/Morphism.hs

@@ -24 +24 @@
 import Common.Id
 import Common.Result
+import Common.Utils (composeMap)
 
 import Control.Exception (assert)
@@ -357 +358 @@
       oMap2 = op_map mor2
       pMap2 = pred_map mor2
-      sMap = if Map.null sMap2 then sMap1 else Set.fold ( \ i ->
-                               let j = mapSort sMap2 (mapSort sMap1 i) in
-                               if i == j then id else Map.insert i j)
-                Map.empty $ sortSet src
+      sMap = composeMap sMap1 sMap2
       oMap = if Map.null oMap2 then oMap1 else
                  Map.foldWithKey ( \ i t m ->

trunk/Common/Utils.hs

@@ -104 +104 @@
 
 -- | composition of arbitrary maps
-composeMap :: (Monad m, Ord a, Ord b, Ord c, Show b) =>
-                Map.Map a b -> Map.Map b c -> m (Map.Map a c)
-composeMap in1 in2 = foldM (\ m1 (x,y)  -> case Map.lookup y in2 of
-   Nothing -> fail $ "Item " ++ show y ++ " not found in target map"
-   Just z  -> return $ Map.insert x z m1) Map.empty $ Map.toList in1
+composeMap :: Ord a => Map.Map a a -> Map.Map a a -> Map.Map a a
+composeMap m1 m2 =
+    if Map.null m2 then m1 else Map.foldWithKey ( \ i j ->
+    let k = Map.findWithDefault j j m2 in
+    if i == k then Map.delete i else Map.insert i k) m2 m1
 
 -- | keep only minimal elements

trunk/CspCASL/Morphism.hs

@@ -29 +29 @@
 import qualified CASL.MapSentence as CASL_MapSen
 
-import Common.Doc
 import Common.DocUtils
 import Common.Id
 import Common.Result
+import Common.Utils (composeMap)
 
 import Control.Monad (unless)
@@ -82 +82 @@
     } deriving (Eq, Ord, Show)
 
--- | Compose two Maps. We use this for Composing the channel and
---   process maps of a CspAddMorphism.
-composeMaps :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c ->
-               Map.Map a c
-composeMaps m1 m2 =
-    Map.foldWithKey (\ i j -> case Map.lookup j m2 of
-                                Nothing -> error "SignCsp.composeMaps"
-                                Just k -> Map.insert i k) Map.empty m1
-
 -- | Compose two CspAddMorphisms
 composeCspAddMorphism :: CspAddMorphism -> CspAddMorphism
                       -> Result CspAddMorphism
 composeCspAddMorphism m1 m2 = return emptyCspAddMorphism
-  { channelMap = composeMaps (channelMap m1) $ channelMap m2
-  , processMap = composeMaps (processMap m1) $ processMap m2 }
+  { channelMap = composeMap (channelMap m1) $ channelMap m2
+  , processMap = composeMap (processMap m1) $ processMap m2 }
 
 -- | Calculate the inverse of a CspAddMorphism
@@ -128 +119 @@
 -- | Pretty printing for Csp morphisms
 instance Pretty CspAddMorphism where
-  pretty = text . show
+  pretty m = pretty $ Map.union
+             (Map.mapKeys makeChannelNameSymbol $ channelMap m)
+             $ Map.mapKeys makeProcNameSymbol $ processMap m
 
 -- | Instance for CspCASL morphism extension (used for Category)
@@ -136 +129 @@
       composeMorphismExtension = composeCspAddMorphism
       inverseMorphismExtension = inverseCspAddMorphism
-      isInclusionMorphismExtension _ = True -- missing! BUG
+      isInclusionMorphismExtension m =
+        Map.null (channelMap m) && Map.null (processMap m)
 
 -- Application of morhisms to sentences

trunk/HasCASL/Morphism.hs

@@ -29 +29 @@
 import Common.Id
 import Common.Result
+import Common.Utils (composeMap)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -92 +93 @@
 mapDataEntry :: IdMap -> TypeMap -> IdMap -> FunMap -> DataEntry -> DataEntry
 mapDataEntry jm tm im fm de@(DataEntry dm i k args rk alts) =
-    let tim = Map.intersection (compIdMap dm im) $ setToMap $ getDatatypeIds de
+    let tim = Map.intersection (composeMap dm im) $ setToMap $ getDatatypeIds de
         newargs = map (mapTypeArg jm tm im) args
     in DataEntry tim i k newargs rk $ Set.map
@@ -154 +155 @@
 ideMor e = mkMorphism e e
 
-compIdMap :: IdMap -> IdMap -> IdMap
-compIdMap im1 im2 = if Map.null im2 then im1 else Map.foldWithKey ( \ i j ->
-    let k = Map.findWithDefault j j im2 in
-    if i == k then Map.delete i else Map.insert i k) im2 im1
-
 compMor :: Morphism -> Morphism -> Result Morphism
 compMor m1 m2 =
      let  tm1 = typeIdMap m1
           tm2 = typeIdMap m2
-          im = compIdMap tm1 tm2
+          im = composeMap tm1 tm2
           cm1 = classIdMap m1
           cm2 = classIdMap m2
-          cm = compIdMap cm1 cm2
+          cm = composeMap cm1 cm2
           fm2 = funMap m2
           fm1 = funMap m1

trunk/HasCASL/SymbolMapAnalysis.hs

@@ -35 +35 @@
 import Common.ExtSign
 import Common.Result
+import Common.Utils (composeMap)
 import Common.Lib.State
 import qualified Data.Map as Map
@@ -127 +128 @@
 mapTypeDefn im td = case td of
     DatatypeDefn de@(DataEntry tm i k args rk alts) ->
-        DatatypeDefn (DataEntry (Map.intersection (compIdMap tm im) $
+        DatatypeDefn (DataEntry (Map.intersection (composeMap tm im) $
               setToMap $ getDatatypeIds de) i k args rk alts)
     AliasTypeDefn sc -> AliasTypeDefn $ mapType im sc

trunk/RelationalScheme/Sign.hs

@@ -129 +129 @@
           case Map.lookup ih $ column_map imorh of
             Just iM -> do
-                oM <- comp_c_map (col_map imaph) (col_map iM)
+                let oM = composeMap (col_map imaph) (col_map iM)
                 return (ih, RSTMap oM)
             Nothing -> fail "apply_comp_c_map"
@@ -142 +142 @@
 comp_rst_mor mor1 mor2 =
     do
-        t_map <- composeMap (table_map mor1) (table_map mor2)
+        let t_map = composeMap (table_map mor1) (table_map mor2)
         c_map <- mapM (\x -> apply_comp_c_map x mor1 mor2) $ map t_name $
             Set.toList $ tables $ domain $ mor1
@@ -153 +153 @@
                 ,   column_map = cm_map
                 }
-
-comp_c_map :: (Show b, Ord c, Ord b, Ord a, Monad m) =>
-               Map.Map a b -> Map.Map b c -> m (Map.Map a c)
-comp_c_map c1 c2 = composeMap c1 c2
 
 emptyRSSign :: RSTables