[Added a separate branch-and-bound implementation and used it in bestMatchings
tobias@goedderz.info**20150309155256
 Ignore-this: a6bbb4ba0ba9b82cf6295892e837e2d1
] hunk ./src/Igor2/RuleDevelopment/Matching.hs 1
-
hunk ./src/Igor2/RuleDevelopment/Matching.hs 20
+import Utils.BranchAndBound (bnb, NodeValue(LowerBound, Solution), Bag,
+    NodeOps(NodeOps, keyOf, children, valueOf))
+
hunk ./src/Igor2/RuleDevelopment/Matching.hs 97
-                        eitherMatchings <- applyC $ computeMatchings m
+                        context <- gets igor_ctx
+                        eitherMatchings <- applyC $ computeMatchings context m
hunk ./src/Igor2/RuleDevelopment/Matching.hs 111
-computeMatchings :: [[(Ordering, [Rule])]] -> C MatchingErrorMonad [(Ordering, [[Rule]])]
-computeMatchings ioMatrix =
-    let all_matchings = allMatchings ioMatrix
-        best_matchings = bestMatchings ioMatrix
-    in do bm <- best_matchings
-          if null bm
-              then all_matchings
-              else return bm
+computeMatchings :: Context -> [[(Ordering, [Rule])]] -> C MatchingErrorMonad [(Ordering, [[Rule]])]
+computeMatchings context ioMatrix =
+    let cam = allMatchings ioMatrix
+        bm = bestMatchings context ioMatrix
+    in if null bm
+          then cam
+          else return bm
hunk ./src/Igor2/RuleDevelopment/Matching.hs 123
+
+    TODO: An exception in MatchingErrorMonad should never happen here.
+    Therefore, remove "C MatchingErrorMonad" from the return type and throw an
+    error if it does.
hunk ./src/Igor2/RuleDevelopment/Matching.hs 131
+bestMatchings :: Context -> [[(Ordering, [Rule])]] -> [(Ordering, [[Rule]])]
+bestMatchings context ioMatrix = bestMatchingsBnb context ioMatrix
+
+data MatchingBnbNode =
+    InnerNode (Ordering, ArgList FunList) (ArgList Rule) [[(Ordering, ArgList Rule)]]
+
+{-
+    TODO: Use ArgList (Either FunList Rule) in the return value, also to
+    optimize mkIndirectCall to avoid introducing constant functions.
+
+    Either-usage:
+        - Left: open rule, list of IO examples
+        - Right: closed rule, rhs corresponding to the caller's lhs
+-}
+bestMatchingsBnb :: Context -> [[(Ordering, ArgList Rule)]] -> [(Ordering, ArgList FunList)]
+bestMatchingsBnb context ioMatrix = let
+        keyOfBnbNode :: MatchingBnbNode -> Int
+        keyOfBnbNode (InnerNode hist lggs _) = length $ filter Rules.isOpen lggs
+
+        childrenOfBnbNode :: MatchingBnbNode -> [MatchingBnbNode]
+        childrenOfBnbNode (InnerNode hist lggs (xs:xxs)) =
+            map (\(o, rs) ->
+                let cmInnerNode = do
+                        let nhist = (max o *** multiCons rs) hist
+                        nlggs <- nextLgg lggs rs
+                        return (InnerNode nhist nlggs xxs)
+                in case cmInnerNode `withC` context of
+                    Left err -> error err
+                    Right x -> x
+            ) xs
+
+        valueOfBnbNode :: MatchingBnbNode -> NodeValue Int
+        valueOfBnbNode x@(InnerNode _ _ [])    = Solution   (keyOfBnbNode x)
+        valueOfBnbNode x@(InnerNode _ _ (_:_)) = LowerBound (keyOfBnbNode x)
+
+        bnbNodeOps :: NodeOps Int Int MatchingBnbNode
+        bnbNodeOps = NodeOps
+            { keyOf = keyOfBnbNode
+            , children = childrenOfBnbNode
+            , valueOf = valueOfBnbNode
+            }
+
+        initial_node :: MatchingBnbNode
+        initial_node = InnerNode (LT, []) [] ioMatrix
+
+        _queue_witness :: Bag Int MatchingBnbNode
+        _queue_witness = undefined
+
+        solutions :: [MatchingBnbNode]
+        solutions = bnb _queue_witness bnbNodeOps initial_node
+
+    -- bnb must not return nodes where the last argument is non-empty, because
+    -- those are inner nodes rather than leafs.
+    in map (\(InnerNode hist _ []) -> hist) solutions
+
hunk ./src/Igor2/RuleDevelopment/Matching.hs 191
-bestMatchings :: [[(Ordering, [Rule])]] -> C MatchingErrorMonad [(Ordering, [[Rule]])]
-bestMatchings ioMatrix = evalStateT (bestMatchings' (LT, []) [] ioMatrix) 0
-
adddir ./src/Utils
addfile ./src/Utils/BranchAndBound.hs
hunk ./src/Utils/BranchAndBound.hs 1
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Utils.BranchAndBound
+    (bnb, NodeValue(..), Bag(), NodeOps(..), PriorityQueue)
+    where
+
+import qualified Data.Map as Map
+import Data.Map (Map())
+import Control.Monad.State as State
+import Data.Functor ((<$>))
+
+{- Nodes -}
+
+data NodeValue v = LowerBound v | Solution v
+
+nodeValue :: NodeValue v -> v
+nodeValue (LowerBound v) = v
+nodeValue (Solution v) = v
+
+data NodeOps k v n = NodeOps
+    { keyOf :: n -> k
+    , valueOf :: n -> NodeValue v
+    , children :: n -> [n]
+    }
+
+{- PriorityQueue -}
+
+class Ord k => PriorityQueue q k n where
+    extractMin :: q k n -> Maybe (n, q k n)
+    singleton :: (k, n) -> q k n
+    insert :: (k, n) -> q k n -> q k n
+    insertList :: [(k, n)] -> q k n -> q k n
+    insertList ns q0 = foldr (\n q -> insert n q) q0 ns
+
+{- Bag, a PriorityQueue implementation -}
+
+data Bag k v = Bag { unBag :: Map k [v] }
+
+empty = Bag Map.empty
+
+insertFront :: Ord k => (k, n) -> Bag k n -> Bag k n
+insertFront (k, x) (Bag m) = Bag (Map.insertWith (\[new] old -> new : old) k [x] m)
+
+instance Ord k => PriorityQueue Bag k n where
+    extractMin :: Bag k n -> Maybe (n, Bag k n)
+    extractMin (Bag m) = if Map.null m
+                         then Nothing
+                         else let (k, (v:_)) = Map.findMin m
+                                  tailOrDel [_]    = Nothing
+                                  tailOrDel (_:xs) = Just xs
+                              in Just $ (v, Bag (Map.update tailOrDel k m))
+
+    insert :: (k, n) -> Bag k n -> Bag k n
+    insert = insertFront
+
+    singleton :: (k, n) -> Bag k n
+    singleton x = insert x empty
+
+{- Branch and bound implementation -}
+
+data BnbState q k v n = BnbState
+    { queue :: q k n
+    , upperBound :: v
+    , solutions :: [n]
+    }
+
+updateQueue :: (q k n -> q k n) -> BnbState q k v n -> BnbState q k v n
+updateQueue f s = s { queue = f (queue s) }
+
+setQueue :: q k n -> BnbState q k v n -> BnbState q k v n
+setQueue q s = s { queue = q }
+
+updateUpperBound :: (v -> v) -> BnbState q k v n -> BnbState q k v n
+updateUpperBound f s = s { upperBound = f (upperBound s) }
+
+updateSolutions :: ([n] -> [n]) -> BnbState q k v n -> BnbState q k v n
+updateSolutions f s = s { solutions = f (solutions s) }
+
+bnb :: forall q k v n. (Ord k, Ord v, Bounded v, PriorityQueue q k n) => (q k n) -> NodeOps k v n -> n -> [n]
+bnb _queue_witness nodeOps x =
+    let withKey x = (keyOf' x, x)
+        withKeys = map withKey
+        keyOf' = keyOf nodeOps
+        valueOf' = valueOf nodeOps
+        children' = children nodeOps
+        initial_state = BnbState
+            { queue = singleton (withKey x) `asTypeOf` _queue_witness
+            , upperBound = maxBound `asTypeOf` nodeValue (valueOf' undefined)
+            , solutions = []
+            }
+        insertChildren :: n -> State (BnbState q k v n) ()
+        insertChildren x = State.modify (updateQueue (insertList (withKeys $ children' x)))
+        extractMinNode :: State (BnbState q k v n) (Maybe n)
+        extractMinNode = do
+            q <- State.gets queue
+            case extractMin q of
+                Nothing      -> return Nothing
+                Just (x :: n, q') -> do
+                    State.modify (setQueue q')
+                    return (Just x)
+        step :: State (BnbState q k v n) ()
+        step = do
+            ub <- State.gets upperBound
+            mx <- extractMinNode :: (Ord k, PriorityQueue q k n) => State (BnbState q k v n) (Maybe n)
+            case (\x -> (x, valueOf' x)) <$> mx of
+                Nothing -> error "No solution found. This should never happen."
+                Just (x, Solution v) ->
+                    case (v `compare` ub) of
+                        LT -> State.modify (\state ->
+                                state { upperBound = v
+                                      , solutions = [x] }
+                              )
+                        EQ -> State.modify (updateSolutions (x:))
+                        GT -> return ()
+                Just (x, LowerBound v) ->
+                    if v > ub
+                        then return ()
+                        else insertChildren x
+        queueIsEmpty :: State (BnbState q k v n) Bool
+        queueIsEmpty = do
+            q <- State.gets queue
+            case extractMin q of
+                Nothing -> return True
+                _       -> return False
+        allSolutionsFound :: State (BnbState q k v n) Bool
+        allSolutionsFound = do
+            mx <- State.gets (extractMin . queue)
+            ub <- State.gets upperBound :: State (BnbState q k v n) v
+            case mx of
+                -- Queue is empty
+                Nothing -> return True
+                Just (x, q') -> return (nodeValue (valueOf' x) > ub)
+        bnb' :: State (BnbState q k v n) ()
+        bnb' = do done <- allSolutionsFound
+                  unless done (step >> bnb')
+    in solutions $ execState bnb' initial_state
+    {- Steps:
+       - Compare the lower bound of x against the global upper bound (i.e. the
+         best solution so far). If it's greater, prune (i.e., return []).
+       - Insert all children of x it into the priority queue.
+       - If x is a leaf, update the global upper bound and return [x].
+    -}