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 <[email protected]> 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 _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
