Commits

Doug Burke committed 633122b

GraphMatch: removed internal use of LookupMap (requires containers 0.5)

Comments (0)

Files changed (4)

   Ord instances for a number of containers; removed some un-needed
   constraints.
 
+  Bumped the minimum containers requirement to 0.5.
+
 0.7.0.2:
 
   Swish.QName.LName now requires all characters to be ASCII. This

src/Swish/GraphMatch.hs

 import Data.Function (on)
 import Data.Hashable (combine)
 import Data.List (foldl', sortBy, groupBy, partition)
-import Data.LookupMap (LookupEntryClass(..), LookupMap(..))
-import Data.LookupMap (makeLookupMap, listLookupMap, setLookupMap, mapFind, mapReplaceAll,
-                       mapAddIfNew, mapReplaceMap, mapMerge)
+import Data.LookupMap (LookupEntryClass(..))
 import Data.Ord (comparing)
 import Data.Word
 
 import qualified Data.List as L
+import qualified Data.Map as M
 import qualified Data.Set as S
 
 --------------------------
 
 -- | Type for label->index lookup table
 data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv =
-    LabelMap Word32 (LookupMap (GenLabelEntry lb lv))
+    LabelMap Word32 (M.Map lb lv)
 
 -- | A label lookup table specialized to 'LabelIndex' indices.
 type LabelMap lb = GenLabelMap lb LabelIndex
 
 instance (Label lb) => Eq (LabelMap lb) where
     LabelMap gen1 lmap1 == LabelMap gen2 lmap2 =
-      (gen1, setLookupMap lmap1) == (gen2, setLookupMap lmap2)
+      (gen1, lmap1) == (gen2, lmap2)
 
 -- | The empty label map table.
 emptyMap :: (Label lb) => LabelMap lb
-emptyMap = LabelMap 1 $ makeLookupMap []
+emptyMap = LabelMap 1 M.empty
 
 --------------------------
 --  Equivalence class type
     "LabelMap gen="++ Prelude.show gn ++", map="++
     foldl' (++) "" (map (("\n    "++) . Prelude.show) es)
     where
-        es = listLookupMap lmap
+        es = M.toList lmap
 
 -- | Map a label to its corresponding label index value in the
 --   supplied LabelMap.
 --
 mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex
-mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms
+mapLabelIndex (LabelMap _ lxms) lb = M.findWithDefault nullLabelVal lb lxms
 
 -- | Confirm that a given pair of labels are matchable, and are
 --  mapped to the same value by the supplied label map
 setLabelHash :: (Label lb)
     => LabelMap lb -> (lb, Word32) -> LabelMap lb
 setLabelHash  (LabelMap g lmap) (lb,lh) =
-    LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) )
+    LabelMap g $ M.insert lb (g,lh) lmap
 
 -- | Increment the generation of the label map.
 --
 assignLabelMap ns lmap = S.foldl' (flip assignLabelMap1) lmap ns
 
 assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb
-assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs'
-    where
-        lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab))
+assignLabelMap1 lab (LabelMap g lvs) = 
+    LabelMap g $ M.insertWith (flip const) lab (g, initVal lab) lvs
 
 --  Calculate initial value for a node
 
             remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs
         LabelMap gen2 lm2 =
             remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs
-        lm' = mapReplaceMap lm $ mapMerge lm1 lm2
+
+        -- replace values in lm with those from (lm1+lm2), but do not copy
+        -- over new keys from (lm1+lm2)
+        lm' = M.mergeWithKey (\_ _ v -> Just v) id (const M.empty) lm $ M.union lm1 lm2
         
         tmap f (a,b) = (f a, f b)
         
         pairEq = uncurry (==)
         pairG1 (p1,p2) = p1 > 1 || p2 > 1
         remapEc = pairGroup . map (newIndex lm') . pairUngroup 
-        newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab)
+        newIndex x (_,lab) = (M.findWithDefault nullLabelVal lab x,lab)
 
 -- | Calculate a new index value for a supplied set of labels based on the
 --  supplied label map and adjacency calculations in the supplied graph
   -- for the given graph labels. The label map generation number is
   -- incremented by 1.
 remapLabels gs lmap@(LabelMap gen _) ls =
-    LabelMap gen' (LookupMap newEntries)
+    LabelMap gen' $ M.fromList newEntries
     where
         gen'                = gen+1
-        newEntries          = [ newEntry (l, (gen', fromIntegral (newIndex l))) | l <- ls ]
+        newEntries          = [ (l, (gen', fromIntegral (newIndex l))) | l <- ls ]
         newIndex l
             | labelIsVar l  = mapAdjacent l                 -- adjacency classifies variable labels
             | otherwise     = hashVal (fromIntegral gen) l  -- otherwise rehash (to disentangle collisions)
   changed; added a @Monoid@ instance for @VarBinding@; added @Ord@
   instances for a number of containers; removed some un-needed constraints.
   .
+  * Bumped the minimum containers requirement to @0.5@.
+  .
   Changes in previous versions can be found at <https://bitbucket.org/doug_burke/swish/src/tip/CHANGES>.
   .
   References:
    Build-Depends:
       base >=3 && < 5,
       binary == 0.5.*,
-      containers >= 0.3 && < 0.6,
+      containers == 0.5.*,
       directory >= 1.0 && < 1.2,
       filepath >= 1.1 && < 1.4,
       hashable == 1.1.*,

tests/GraphTest.hs

 import Swish.GraphClass (arc, arcFromTriple, arcToTriple)
 import Swish.GraphMem
 import Swish.GraphMatch
-      ( LabelMap, GenLabelMap(..), LabelEntry, 
+      ( LabelMap, GenLabelMap(..), 
         EquivalenceClass,
         ScopedLabel(..), makeScopedLabel, makeScopedArc,
         LabelIndex, nullLabelVal, emptyMap,
 
 -- import Swish.Utils.ListHelpers (subset)
 
-import Data.LookupMap (LookupEntryClass(..), makeLookupMap)
-
 import TestHelpers (runTestSuite, testEq)
 
 import Data.List (sort, elemIndex)
 import Data.Ord (comparing)
 import Data.Word (Word32)
 
+import qualified Data.Map as M
 import qualified Data.Set as S
 
 default ( Int )
 ------------------------------------------------------------
 
 tstLabelMap :: (Label lb) => Word32 -> [(lb,LabelIndex)] -> LabelMap lb
-tstLabelMap gen lvs = LabelMap gen (makeLookupMap $ makeEntries lvs)
-
-makeEntries :: (Label lb) => [(lb,LabelIndex)] -> [LabelEntry lb]
-makeEntries = map newEntry
+tstLabelMap gen = LabelMap gen . M.fromList
 
 ------------------------------------------------------------
 --  Graph helper function tests
 testShowLabelMap = testEq "showLabelMap" showMap (show lmap)
     where
         showMap = "LabelMap gen=5, map=\n"++
-                  "    !s1:(1,1)\n"++
-                  "    !s2:(2,2)\n"++
-                  "    !s3:(3,3)\n"++
-                  "    !:(4,4)\n"++
-                  "    !o1:(1,1)\n"++
-                  "    !o2:(2,2)\n"++
-                  "    !o3:(3,3)"
+                  "    (!,(4,4))\n"++
+                  "    (!o1,(1,1))\n"++
+                  "    (!o2,(2,2))\n"++
+                  "    (!o3,(3,3))\n"++
+                  "    (!s1,(1,1))\n"++
+                  "    (!s2,(2,2))\n"++
+                  "    (!s3,(3,3))"
 
 testMapLabelHash00 :: Test
 testMapLabelHash00 = testEq "mapLabelHash00" showMap (show lmap1)
     where
         showMap = "LabelMap gen=5, map=\n"++
-                  "    !s1:(1,1)\n"++
-                  "    !s2:(5,22)\n"++
-                  "    !s3:(3,3)\n"++
-                  "    !:(4,4)\n"++
-                  "    !o1:(1,1)\n"++
-                  "    !o2:(2,2)\n"++
-                  "    !o3:(3,3)"
+                  "    (!,(4,4))\n"++
+                  "    (!o1,(1,1))\n"++
+                  "    (!o2,(2,2))\n"++
+                  "    (!o3,(3,3))\n"++
+                  "    (!s1,(1,1))\n"++
+                  "    (!s2,(5,22))\n"++
+                  "    (!s3,(3,3))"
 
 -- mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex