[commit: Cabal] master: implemented a version of backjumping (fa7b97b)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/fa7b97ba85bee473ddea69b7d99063320b8e6dc3

>---------------------------------------------------------------

commit fa7b97ba85bee473ddea69b7d99063320b8e6dc3
Author: Andres Loeh <andres at well-typed.com>
Date:   Mon Jun 20 17:19:57 2011 +0000

    implemented a version of backjumping

>---------------------------------------------------------------

 .../Client/Dependency/Modular/Explore.hs           |   29 ++++++++++++++++++++
 .../Client/Dependency/Modular/Solver.hs            |    2 +-
 2 files changed, 30 insertions(+), 1 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
index 6dc9223..7ebc8ac 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
@@ -2,6 +2,7 @@ module Distribution.Client.Dependency.Modular.Explore where
 
 import Control.Applicative as A
 import Data.Foldable
+import Data.List as L
 import Data.Map as M
 
 import Distribution.Client.Dependency.Modular.Assignment
@@ -12,6 +13,34 @@ import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.PSQ as P
 import Distribution.Client.Dependency.Modular.Tree
 
+-- | Backjumping.
+backjump :: Tree a -> Tree (Maybe [Var QPN])
+backjump = snd . cata go
+  where
+    go (FailF c fr) = (Just c, Fail c fr)
+    go (DoneF rdm ) = (Nothing, Done rdm)
+    go (PChoiceF qpn _   ts) = (c, PChoice qpn c   (P.fromList ts'))
+      where
+        ~(c, ts') = combine (P qpn) (P.toList ts) []
+    go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts'))
+      where
+        ~(c, ts') = combine (F qfn) (P.toList ts) []
+    go (GoalChoiceF      ts) = (c, GoalChoice      (P.fromList ts'))
+      where
+        ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts
+        c          = case cs of []    -> Nothing
+                                d : _ -> d
+
+-- | TODO: This needs documentation. It's a horribly tricky function, mainly w.r.t.
+-- laziness.
+combine :: Var QPN -> [(a, (Maybe [Var QPN], b))] -> [Var QPN] -> (Maybe [Var QPN], [(a, b)])
+combine var []                      c = (Just c, [])
+combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $
+                                        case d of
+                                          Just e | not (var `L.elem` e) -> (Just e, [])
+                                                 | otherwise            -> combine var xs (e ++ c)
+                                          Nothing                       -> (Nothing, snd $ combine var xs [])
+
 -- | Naive backtracking exploration of the search tree. This will yield correct
 -- assignments only once the tree itself is validated.
 explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 705dd80..d87f27a 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -44,7 +44,7 @@ solve sc idx userPrefs userConstraints userGoals =
   prunePhase       $
   buildPhase
   where
-    explorePhase = exploreTreeLog
+    explorePhase = exploreTreeLog . backjump
     heuristicsPhase = if preferEasyGoalChoices sc
                         then P.deferDefaultFlagChoices . P.preferEasyGoalChoices
                         else id