Commit fba4b252 authored by Andres Löh's avatar Andres Löh
Browse files

Count conflicts and prefer goals that contribute to conflicts.

parent 8f32ab44
......@@ -4,6 +4,7 @@ module Distribution.Solver.Modular.Explore
) where
import Data.Foldable as F
import Data.List as L (foldl')
import Data.Map as M
import Distribution.Solver.Modular.Assignment
......@@ -16,6 +17,7 @@ import Distribution.Solver.Modular.Tree
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings (EnableBackjumping(..))
import qualified Distribution.Solver.Types.Progress as P
import Distribution.Solver.Modular.Var
-- | This function takes the variable we're currently considering, an
-- initial conflict set and a
......@@ -40,57 +42,85 @@ import qualified Distribution.Solver.Types.Progress as P
-- with the (virtual) option not to choose anything for the current
-- variable. See also the comments for 'avoidSet'.
--
backjump :: F.Foldable t => EnableBackjumping -> Var QPN
-> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a
backjump (EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
backjump :: EnableBackjumping -> Var QPN
-> ConflictSet QPN -> ConflictMap -> P.PSQ k (ConflictMap -> (ConflictSetLog a, ConflictMap))
-> (ConflictSetLog a, ConflictMap)
backjump (EnableBackjumping enableBj) var initial cm xs =
F.foldr combine logBackjump xs initial cm
where
combine :: ConflictSetLog a
-> (ConflictSet QPN -> ConflictSetLog a)
-> ConflictSet QPN -> ConflictSetLog a
combine (P.Done x) _ _ = P.Done x
combine (P.Fail cs) f csAcc
| enableBj && not (var `CS.member` cs) = logBackjump cs
| otherwise = f (csAcc `CS.union` cs)
combine (P.Step m ms) f cs = P.Step m (combine ms f cs)
combine :: (ConflictMap -> (ConflictSetLog a, ConflictMap))
-> (ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap))
-> ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap)
combine x f csAcc cm =
let (l, cm') = x cm
in case l of
P.Done x -> (P.Done x, cm')
P.Fail cs
| enableBj && not (var `CS.member` cs) -> logBackjump cs cm'
| otherwise -> f (csAcc `CS.union` cs) cm'
P.Step m ms ->
let (l', cm'') = combine (\ x -> (ms, x)) f csAcc cm'
in (P.Step m l', cm'')
logBackjump :: ConflictSet QPN -> ConflictSetLog a
logBackjump cs = failWith (Failure cs Backjump) cs
logBackjump :: ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap)
logBackjump cs cm' = (failWith (Failure cs Backjump) cs, cm')
type ConflictSetLog = P.Progress Message (ConflictSet QPN)
type ConflictMap = Map (Var QPN) Int
getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)
getBestGoal cm =
P.maximumBy
( flip (M.findWithDefault 0) cm
. (\ (Goal v _) -> v)
)
updateCM :: ConflictSet QPN -> ConflictMap -> ConflictMap
updateCM cs cm =
L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs)
where
inc Nothing = Just 1
inc (Just n) = Just $! n + 1
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
exploreLog :: EnableBackjumping -> Tree QGoalReason
-> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
exploreLog enableBj = cata go
where
go :: TreeF QGoalReason (Assignment -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) _ = failWith (Failure c fr) c
go (DoneF rdm) a = succeedWith Success (a, rdm)
go (PChoiceF qpn gr ts) (A pa fa sa) =
backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
go :: TreeF QGoalReason (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
-> (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
go (FailF c fr) _ cm = (failWith (Failure c fr) c, updateCM c cm)
go (DoneF rdm) a cm = (succeedWith Success (a, rdm), cm)
go (PChoiceF qpn gr ts) (A pa fa sa) cm =
backjump enableBj (P qpn) (avoidSet (P qpn) gr) cm $ -- try children in order,
P.mapWithKey -- when descending ...
(\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...
r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
(\ i@(POption k _) r cm ->
let (l, cm') = r (A (M.insert qpn k pa) fa sa) cm
in (tryWith (TryP qpn i) l, cm')
)
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) cm =
backjump enableBj (F qfn) (avoidSet (F qfn) gr) cm $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryF qfn k) $ -- log and ...
r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice
(\ k r cm ->
let (l, cm') = r (A pa (M.insert qfn k fa) sa) cm
in (tryWith (TryF qfn k) l, cm')
)
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
go (SChoiceF qsn gr _ ts) (A pa fa sa) cm =
backjump enableBj (S qsn) (avoidSet (S qsn) gr) cm $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryS qsn k) $ -- log and ...
r (A pa fa (M.insert qsn k sa))) -- record the pkg choice
(\ k r cm ->
let (l, cm') = r (A pa fa (M.insert qsn k sa)) cm
in (tryWith (TryS qsn k) l, cm')
)
ts
go (GoalChoiceF ts) a =
P.casePSQ ts
(failWith (Failure CS.empty EmptyGoalChoice) CS.empty) -- empty goal choice is an internal error
(\ k v _xs -> continueWith (Next k) (v a)) -- commit to the first goal choice
go (GoalChoiceF ts) a cm =
let (k, v) = getBestGoal cm ts
(l, cm') = v a cm
in (continueWith (Next k) l, cm')
-- | Build a conflict set corresponding to the (virtual) option not to
-- choose a solution for a goal at all.
......@@ -123,7 +153,7 @@ avoidSet var gr =
backjumpAndExplore :: EnableBackjumping
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj t =
toLog $ exploreLog enableBj t (A M.empty M.empty M.empty)
toLog $ fst $ exploreLog enableBj t (A M.empty M.empty M.empty) M.empty
where
toLog :: P.Progress step fail done -> Log step done
toLog = P.foldProgress P.Step (const (P.Fail ())) P.Done
......@@ -19,6 +19,7 @@ module Distribution.Solver.Modular.PSQ
, mapKeys
, mapWithKey
, mapWithKeyState
, maximumBy
, minimumBy
, null
, prefer
......@@ -124,6 +125,10 @@ dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs
where
d = sel (snd y)
maximumBy :: (k -> Int) -> PSQ k a -> (k, a)
maximumBy sel (PSQ xs) =
S.minimumBy (flip (comparing (sel . fst))) xs
minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a
minimumBy sel (PSQ xs) =
PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]
......
......@@ -110,8 +110,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
in case goalOrder sc of
Nothing -> (if asBool (preferEasyGoalChoices sc)
then P.preferEasyGoalChoices -- also leaves just one choice
else P.firstGoal) . -- after doing goal-choice heuristics,
-- commit to the first choice (saves space)
else id) .
heuristicsTree .
P.deferWeakFlagChoices .
P.deferSetupChoices .
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment