[laternative, heap-based implementation of HypoSpace
martin.hofmann@uni-bamberg.de**20090925063749] move ./src/Data/HypoSpace.hs ./src/Data/HypoSpace_propagate.hs
addfile ./src/Data/GHeap.hs
hunk ./src/Data/GHeap.hs 1
-
+{- |
+   An implementation of lazy pairing minimum heaps following Chris Okazaki's 
+   paper 'Functional Data Structures'
+   
+   @inproceedings{ DBLP:conf/afp/Okasaki96
+                 , author    = {Chris Okasaki}
+                 , title     = {Functional Data Structures}
+                 , booktitle = {Advanced Functional Programming}
+                 , year      = {1996}
+                 , pages     = {131-158}
+                 , crossref  = {DBLP:conf/afp/1996}
+                 , bibsource = {DBLP, http://dblp.uni-trier.de}
+                 }  
+-}
+module Data.GHeap (
+
+    Heap(..),
+    empty, isEmpty,
+    
+    singleton, insert, merge, link,
+    getMin, delMin, getDelMin,
+    
+    toList, prios, elems,
+    fromList
+    
+    ) where
+
+import Data.Function (on)
+import Data.List (foldl')
+
+data (Ord p) => Heap p v = Nil | Node p v (Heap p v) (Heap p v)
+
+-- | Returns an empty heap
+empty :: (Ord p) => Heap p v
+empty = Nil
+
+-- | Returns 'True' if the heap is empty, 'alse' otherwise
+isEmpty :: (Ord p) => Heap p v -> Bool
+isEmpty Nil = True
+isEmpty _   = False
+
+prio :: (Ord p) => Heap p v -> p
+prio (Node p _ _ _) = p
+prio _              = error "Data.Heap.prio: empty heap"
+
+val :: (Ord p) => Heap p v -> v
+val (Node _ v _ _) = v
+val _              = error "Data.Heap.val: empty heap"
+
+-- | creates a singleton heap from a priority\/value pair
+singleton :: (Ord p) => p -> v -> Heap p v
+singleton p v = Node p v Nil Nil
+
+-- | 'insert k v h' inserts the value 'k' with priority 'k' into heap 'h'
+insert :: (Ord p) => p -> v -> Heap p v -> Heap p v
+insert  = (merge . ) . singleton
+
+-- | Merge two heaps into one
+merge :: (Ord p) => (Heap p v) -> (Heap p v) -> (Heap p v)
+merge a Nil = a
+merge Nil b = b
+merge a b
+    | on (<=) prio a b = link a b
+    | otherwise       = link b a
+    
+-- | Merging two heaps into one heap, maintainnig the heap property    
+link :: (Ord p) => (Heap p v) -> (Heap p v) -> (Heap p v)
+link (Node p v Nil la) b = Node p v b la
+link (Node p v la ra) b  = Node p v Nil (merge (merge la b) ra)
+
+--  | Returns the minimal priority\/value pair and the heap without it
+getDelMin :: (Ord p) => (Heap p v) -> ((p,v),Heap p v)
+getDelMin Nil =  error "Data.Heap.findDelMin: empty heap"
+getDelMin (Node p v l r) = ((p,v),merge l r)
+
+-- | Returns the th minimal priority\/value pair
+getMin :: (Ord p) => (Heap p v) -> (p,v)
+getMin = fst . getDelMin
+
+-- | Returns the resulting heap after removing the minimal priority\/value pair
+delMin :: (Ord p) => (Heap p v) -> Heap p v
+delMin = snd . getDelMin
+
+toList :: (Ord p) => (Heap p v) -> [(p,v)]
+toList Nil = []
+toList (Node p v l r) = (p,v) : (toList $ merge l r)
+
+prios :: (Ord p) => (Heap p v) -> [p]
+prios m = [p | (p,_) <- toList m]
+
+elems :: (Ord p) => (Heap p v) -> [v]
+elems m = [v | (_,v) <- toList m]
+
+fromList :: (Ord p) => [(p,v)] -> (Heap p v) 
+fromList = foldl' (flip $ uncurry insert) empty
addfile ./src/Data/HypoSpace.hs
hunk ./src/Data/HypoSpace.hs 1
-
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Data.HypoSpace (
+
+    HSpace, initHSpace, emptyHSpace, 
+    bestHypos, propagateHSp, countHypos,
+    
+    module Data.Hypotheses
+    
+   
+
+) where
+
+import qualified Data.GHeap as H
+import Rating.Rateable
+import Data.Hypotheses
+import Data.IOData
+
+import Logging
+
+import Control.Arrow ( (***), first, second )
+import Data.Maybe (mapMaybe)
+
+data HSpace = HS { cntr :: Int
+                 , heap :: H.Heap RatingData Hypo}
+                 
+
+ -- | /O(1)/, create an empty Search Space
+emptyHSpace :: HSpace
+emptyHSpace = HS 
+    { cntr   = 0
+    , heap   = H.empty
+    }
+    
+countHypos :: HSpace -> Int  
+countHypos = cntr      
+ 
+-- | /O(1)/, initialise a search space with a 'CovrRule' as inital hypothese
+initHSpace :: CovrRule ->  HSpace  
+initHSpace = (pushHypo emptyHSpace) . hypo . (:[])    
+
+-- | find the best valued Hypotheses
+bestHypo :: HSpace -> Hypo
+bestHypo = snd . H.getMin . heap
+
+-- | find the best valued Hypothesis
+bestHypos :: HSpace -> Hypos
+bestHypos = hypos . (:[]) . bestHypo       
+
+
+-- Propagate a Rule modification over the whole search space
+propagateHSp :: CovrRule -> [(CovrRules,[Call])] -> HSpace -> HSpace
+propagateHSp cr sucs hsp = 
+    (uncurry  pushHypos) . swap . (first $ develHs cr sucs) $ popHypo hsp 
+    where
+    swap (a,b) = (b,a)
+    -- develHs =   \c sucs h -> mapMaybe (\s -> developH c s h) sucs
+    develHs = flip . (mapMaybe .) . flip . developH
+--------------------------------------------------------------------------------
+-- Hidden helpers
+--------------------------------------------------------------------------------
+
+
+pushHypo :: HSpace -> Hypo -> HSpace
+pushHypo = (incCntr . ) . pushUnsafe
+
+pushHypos :: HSpace -> [Hypo] -> HSpace
+pushHypos h = foldl pushHypo h
+
+popHypo :: HSpace -> (Hypo,HSpace)
+popHypo = (second decCntr) . popUnsafe
+
+
+--------------------------------------------------------------------------------
+-- Unsafe helpers
+--------------------------------------------------------------------------------
+
+incCntr :: HSpace -> HSpace
+incCntr (HS c hp) = HS (c+1) hp
+
+decCntr :: HSpace -> HSpace
+decCntr (HS c hp) = HS (c-1) hp
+
+pushUnsafe :: HSpace -> Hypo -> HSpace
+pushUnsafe (HS c hp) h = HS c (H.insert (rate h) h hp)      
+
+popUnsafe :: HSpace -> (Hypo,HSpace)
+popUnsafe (HS c hp) = ( snd *** (HS c) ) . H.getDelMin $ hp
+
+  
+--{- -----------------------------------------------------------------------------
+-- | Show instances and pretty printing stuff
+------------------------------------------------------------------------------- -}
+  
+
+instance Show HSpace where
+        show = show.pretty            
+instance Pretty HSpace where
+        pretty hsp = text "HSPACE" <$> 
+                     parens ( indent 2 $ 
+                        text "Total Hypos:"     <+> (int.countHypos $ hsp) <$>
+                        text "Rating -> Hypo:" <^> indent 2 (vcat . (map asMap) .  H.toList . heap $ hsp)
+--                        text "Rating -> HypoID:" <^> pretty (rateIdsMap hsp) <$> 
+--                        text "Rule   -> HypoID:" <^> pretty (ruleIdsMap hsp) <$> 
+--                        text "ID     -> Hypo:  " <$> pretty (hypoIdBimap hsp)
+                     )        
+ 
addfile ./src/Data/HypoSpace_heap.hs
hunk ./src/Data/HypoSpace_heap.hs 1
-
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Data.HypoSpace (
+
+    HSpace, initHSpace, emptyHSpace, 
+    bestHypos, propagateHSp, countHypos,
+    
+    module Data.Hypotheses
+    
+   
+
+) where
+
+import qualified Data.GHeap as H
+import Rating.Rateable
+import Data.Hypotheses
+import Data.IOData
+
+import Logging
+
+import Control.Arrow ( (***), first, second )
+import Data.Maybe (mapMaybe)
+
+data HSpace = HS { cntr :: Int
+                 , heap :: H.Heap RatingData Hypo}
+                 
+
+ -- | /O(1)/, create an empty Search Space
+emptyHSpace :: HSpace
+emptyHSpace = HS 
+    { cntr   = 0
+    , heap   = H.empty
+    }
+    
+countHypos :: HSpace -> Int  
+countHypos = cntr      
+ 
+-- | /O(1)/, initialise a search space with a 'CovrRule' as inital hypothese
+initHSpace :: CovrRule ->  HSpace  
+initHSpace = (pushHypo emptyHSpace) . hypo . (:[])    
+
+-- | find the best valued Hypotheses
+bestHypo :: HSpace -> Hypo
+bestHypo = snd . H.getMin . heap
+
+-- | find the best valued Hypothesis
+bestHypos :: HSpace -> Hypos
+bestHypos = hypos . (:[]) . bestHypo       
+
+
+-- Propagate a Rule modification over the whole search space
+propagateHSp :: CovrRule -> [(CovrRules,[Call])] -> HSpace -> HSpace
+propagateHSp cr sucs hsp = 
+    (uncurry  pushHypos) . swap . (first $ develHs cr sucs) $ popHypo hsp 
+    where
+    swap (a,b) = (b,a)
+    -- develHs =   \c sucs h -> mapMaybe (\s -> developH c s h) sucs
+    develHs = flip . (mapMaybe .) . flip . developH
+--------------------------------------------------------------------------------
+-- Hidden helpers
+--------------------------------------------------------------------------------
+
+
+pushHypo :: HSpace -> Hypo -> HSpace
+pushHypo = (incCntr . ) . pushUnsafe
+
+pushHypos :: HSpace -> [Hypo] -> HSpace
+pushHypos h = foldl pushHypo h
+
+popHypo :: HSpace -> (Hypo,HSpace)
+popHypo = (second decCntr) . popUnsafe
+
+
+--------------------------------------------------------------------------------
+-- Unsafe helpers
+--------------------------------------------------------------------------------
+
+incCntr :: HSpace -> HSpace
+incCntr (HS c hp) = HS (c+1) hp
+
+decCntr :: HSpace -> HSpace
+decCntr (HS c hp) = HS (c-1) hp
+
+pushUnsafe :: HSpace -> Hypo -> HSpace
+pushUnsafe (HS c hp) h = HS c (H.insert (rate h) h hp)      
+
+popUnsafe :: HSpace -> (Hypo,HSpace)
+popUnsafe (HS c hp) = ( snd *** (HS c) ) . H.getDelMin $ hp
+
+  
+--{- -----------------------------------------------------------------------------
+-- | Show instances and pretty printing stuff
+------------------------------------------------------------------------------- -}
+  
+
+instance Show HSpace where
+        show = show.pretty            
+instance Pretty HSpace where
+        pretty hsp = text "HSPACE" <$> 
+                     parens ( indent 2 $ 
+                        text "Total Hypos:"     <+> (int.countHypos $ hsp) <$>
+                        text "Rating -> Hypo:" <^> indent 2 (vcat . (map asMap) .  H.toList . heap $ hsp)
+--                        text "Rating -> HypoID:" <^> pretty (rateIdsMap hsp) <$> 
+--                        text "Rule   -> HypoID:" <^> pretty (ruleIdsMap hsp) <$> 
+--                        text "ID     -> Hypo:  " <$> pretty (hypoIdBimap hsp)
+                     )        
+ 