[HypoSpace as BagHeap, storing values with same key in a Sequence, new module BagHeap
martin.hofmann@uni-bamberg.de**20091008092717] addfile ./src/Data/BagHeap.hs
hunk ./src/Data/BagHeap.hs 1
-
+{-| Implementation of a heap which allows storing multiple values under one 
+    priority (key), preserving the insertion order. It is based on Data.GHeap and Data.Sequence and virtually
+    just interfacing the necessary functions.
+-}
+module Data.BagHeap (
+
+
+    BagHeap(..),
+    empty, isEmpty,
+    
+    singleton, insert, merge, 
+    getMin, delMin, getDelMin,
+    
+    toList, prios, elems,
+    fromList,
+
+)where
+
+
+import Data.GHeap (Heap)
+import qualified Data.GHeap as H
+import Data.Sequence (Seq, (><))
+import qualified Data.Sequence as S
+import qualified Data.Foldable as F
+import Data.List (foldl')
+import Data.Function (on)
+import Control.Arrow
+
+-- | A heap storing values with the same priority (key) 'p' in a sequence. 
+data BagHeap p v = BH {unBH :: (Heap p (Seq v))} 
+
+
+-- | Returns an empty heap
+empty :: (Ord p) => BagHeap p v
+empty = BH H.empty
+
+-- | Returns 'True' if the heap is empty, 'alse' otherwise
+isEmpty :: (Ord p) => BagHeap p v -> Bool
+isEmpty = H.isEmpty . unBH
+
+-- | creates a singleton heap from a priority\/value pair
+singleton :: (Ord p) => p -> v -> BagHeap p v
+singleton p v = BH $ H.singleton p (S.singleton v)  
+
+
+-- | 'insert k v h' inserts the value 'k' with priority 'k' into heap 'h'
+insert :: (Ord p) => p -> v -> BagHeap p v -> BagHeap p v
+insert  = (flip merge . ) . singleton
+
+-- | Merge two heaps into one
+merge :: (Ord p) => BagHeap p v -> BagHeap p v -> BagHeap p v
+merge = (BH .) . (on (H.mergeWith (><)) unBH)
+
+--  | Returns the minimal priority\/value pair and the heap without it
+getDelMin :: (Ord p) => BagHeap p v -> ((p,[v]),BagHeap p v)
+getDelMin = ((id *** F.toList) *** BH) . H.getDelMin . unBH
+
+-- | Returns the th minimal priority\/value pair
+getMin :: (Ord p) => BagHeap p v -> (p,[v])
+getMin = fst . getDelMin
+
+-- | Returns the resulting heap after removing the minimal priority\/value pair
+delMin :: (Ord p) => BagHeap p v -> BagHeap p v
+delMin = snd . getDelMin
+
+toList :: (Ord p) => BagHeap p v -> [(p,[v])]
+toList = (map (id *** F.toList)) . H.toList . unBH
+
+prios :: (Ord p) => BagHeap p v -> [p]
+prios m = [p | (p,_) <- toList m]
+
+elems :: (Ord p) => BagHeap p v -> [[v]]
+elems m = [v | (_,v) <- toList m]
+
+fromList :: (Ord p) => [(p,v)] -> BagHeap p v
+fromList = (foldl' (flip $ uncurry insert) empty)
hunk ./src/Data/GHeap.hs 20
-    singleton, insert, merge, link,
+    singleton, insert, merge, insertWith, mergeWith, link,
hunk ./src/Data/GHeap.hs 24
-    fromList
+    fromList,
hunk ./src/Data/GHeap.hs 32
+    deriving (Show)
hunk ./src/Data/GHeap.hs 34
+--both (Node _ _ l r) = (l,r)
+--both _              = error "Data.Heap.both: empty heap"
+               
hunk ./src/Data/GHeap.hs 62
+-- | 'insert k v h' inserts the value 'k' with priority 'k' into heap 'h'
+--   using a combining function for value with e same key
+insertWith :: (Ord p) => (v->v->v) -> p -> v -> Heap p v -> Heap p v
+insertWith f  = (mergeWith f . ) . singleton
+
hunk ./src/Data/GHeap.hs 75
--- | Merging two heaps into one heap, maintainnig the heap property    
+--- | Merge two heaps into one using a combining function for value with
+--    the same key
+mergeWith :: (Ord p) => (v->v->v) -> (Heap p v) -> (Heap p v) -> (Heap p v)
+mergeWith _ a Nil = a
+mergeWith _ Nil b = b
+mergeWith f a@(Node p1 v1 l1 r1) b@(Node p2 v2 l2 r2)
+    | p1 == p2  = mergeWith f (singleton p1 (v1 `f` v2)) 
+                              (mergeWith f (merge l1 r1)(merge l2 r2))
+    | p1 < p2   = linkWith f a b
+    | otherwise = linkWith f b a
+    
+-- | Merging two heaps into one heap, maintainig the heap property    
hunk ./src/Data/GHeap.hs 88
-link (Node p v Nil la) b = Node p v b la
+link (Node p v Nil ra) b = Node p v b ra
hunk ./src/Data/GHeap.hs 91
+-- | Merging two heaps into one heap using a combining function for value with
+--   the same key, maintainig the heap property    
+linkWith :: (Ord p) => (v->v->v) -> (Heap p v) -> (Heap p v) -> (Heap p v)
+linkWith f (Node p v Nil ra) b = Node p v b ra
+linkWith f (Node p v la ra) b  = Node p v Nil (mergeWith f (mergeWith f la b) ra)
+
hunk ./src/Data/GHeap.hs 122
+
+
hunk ./src/Data/HypoSpace.hs 13
-import qualified Data.GHeap as H
+import qualified Data.BagHeap as H
hunk ./src/Data/HypoSpace.hs 24
-                 , heap :: H.Heap RatingData Hypo}
+                 , heap :: H.BagHeap RatingData Hypo}
hunk ./src/Data/HypoSpace.hs 43
-bestHypo = snd . H.getMin . heap
+bestHypo = head . snd . H.getMin . heap
hunk ./src/Data/HypoSpace.hs 47
-bestHypos = hypos . (:[]) . bestHypo       
+bestHypos = hypos . snd . H.getMin . heap
hunk ./src/Data/HypoSpace.hs 53
-    (uncurry  pushHypos) . swap . (first $ develHs cr sucs) $ popHypo hsp 
+    (uncurry  pushHypos) . swap . (first $ develHs cr sucs) $ popHypos hsp 
hunk ./src/Data/HypoSpace.hs 56
-    -- develHs =   \c sucs h -> mapMaybe (\s -> developH c s h) sucs
-    develHs = flip . (mapMaybe .) . flip . developH
+    -- develHs =  \c sucs hs -> concatMap (\h -> mapMaybe (\s -> developH c s h) sucs) hs
+    develHs = ((=<<) .) . flip . (mapMaybe .) . flip . developH
+               
hunk ./src/Data/HypoSpace.hs 70
-popHypo :: HSpace -> (Hypo,HSpace)
-popHypo = (second decCntr) . popUnsafe
+popHypos :: HSpace -> ([Hypo],HSpace)
+popHypos = (second decCntr) . popUnsafe
hunk ./src/Data/HypoSpace.hs 85
-pushUnsafe (HS c hp) h = HS c (H.insert (rate h) h hp)      
+pushUnsafe (HS c hp) h = HS c (H.insert (rate h) h hp)     
hunk ./src/Data/HypoSpace.hs 87
-popUnsafe :: HSpace -> (Hypo,HSpace)
+popUnsafe :: HSpace -> ([Hypo],HSpace)
hunk ./src/Data/HypoSpace.hs 99
-        pretty hsp = text "HSPACE" <$> 
+        pretty hsp = text "HSPACE" <$>
hunk ./src/Logging/PrettyPrinter.hs 14
+import qualified Data.Sequence as Sq
hunk ./src/Logging/PrettyPrinter.hs 18
+import qualified Data.Foldable as F
hunk ./src/Logging/PrettyPrinter.hs 139
+instance (Pretty e) => Pretty (Sq.Seq e) where
+    pretty = pretty . F.toList
+    