Much more aggressive prevention of sharing

diff --git a/Main.hs b/Main.hs
index b44e8fe..cce0047 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -172,12 +172,11 @@ runBritney config = do
 
     hPutStrLn stderr $ "After adding installability atoms, AtomIndex knows about " ++ show (unIndex (maxIndex ai)) ++ " atoms."
 
-    let (rules, relaxable, desired, unwanted) =
-            transitionRules config ai unstableThin testing general pi
-        rulesT = toProducer $
-                 map (\i -> Not i "we are investigating testing") desired ++
-                 map (\i -> OneOf [i] "we are investigating testing") unwanted ++
-                 build rules
+    let (rules, relaxable, desired, unwanted)
+            = transitionRules config ai unstableThin testing general pi
+        rulesT = mapP (\i -> Not i "we are investigating testing") desired `concatP`
+                 mapP (\i -> OneOf [i] "we are investigating testing") unwanted `concatP`
+                 rules
         cnfT = clauses2CNF (maxIndex ai) rulesT
         relaxableClauses = clauses2CNF (maxIndex ai) relaxable
 
@@ -186,11 +185,10 @@ runBritney config = do
 
     mbDo (clausesUnrelaxH config) $ \h -> do
         hPutStrLn stderr $ "Writing unrelaxed SAT problem as literal clauses"
-        mapM_ (hPrint h . nest 4 . pp ai) (build rulesT)
+        mapM_ (hPrint h . nest 4 . pp ai) (build rules)
         hPutStrLn h ""
         mapM_ (hPrint h . nest 4 . pp ai) (build relaxable)
         hFlush h
-
     
     hPutStrLn stderr $ "Relaxing testing to a consistent set..."
     removeClauseE <- relaxer relaxableClauses cnfT
@@ -210,7 +208,7 @@ runBritney config = do
 
 
     let extraRules = maybe [] (\si -> [OneOf [si] "it was requested"]) (migrateThisI config)
-        cleanedRules = toProducer $ extraRules ++ build rules
+        cleanedRules = toProducer extraRules `concatP` rules
         cnf = clauses2CNF (maxIndex ai) cleanedRules `combineCNF` leftConj
 
     mbDo (dimacsH config) $ \h -> do
@@ -221,6 +219,7 @@ runBritney config = do
     mbDo (clausesH config) $ \h -> do
         hPutStrLn stderr $ "Writing SAT problem as literal clauses"
         mapM_ (hPrint h . nest 4 . pp ai) (build cleanedRules)
+        -- TODO what about clauses from leftConf?
         hFlush h
 
     {-
@@ -232,13 +231,13 @@ runBritney config = do
             AsLargeAsPossible -> (desired, unwanted)
             ManySmall         -> (desired, unwanted)
             AsSmallAsPossible -> (unwanted, desired)
-            AnySize           -> ([], [])
+            AnySize           -> (toProducer [], toProducer [])
 
     hPutStrLn stderr $ "Running main picosat run"
     result <- if transSize config == ManySmall
-        then runClauseMINMAXSAT (maxIndex ai) desired' unwanted' cnf
+        then runClauseMINMAXSAT (maxIndex ai) (build desired') (build unwanted') cnf
         else fmap (\res -> (res,[res])) <$>
-             runClauseSAT (maxIndex ai) desired' unwanted' cnf
+             runClauseSAT (maxIndex ai) (build desired') (build unwanted') cnf
     case result of 
         Left musCNF -> do
             hPutStrLn stderr $

diff --git a/Picosat.hs b/Picosat.hs
index 293c2fd..f316909 100644 (file)
--- a/Picosat.hs
+++ b/Picosat.hs
@@ -133,8 +133,8 @@ runPicosat cnf = do
             musString <- BS.hGetContents coreIn
             ensureSuccess [10,20] picoProc procHandle
             let mus = parseCNF (snd cnf) musString
-            let annotatedMus = findConj mus cnf
-            return (Left annotatedMus)
+            --let annotatedMus = findConj mus cnf
+            return (Left mus)
         "s SATISFIABLE" -> do
             hClose coreIn
             satvarsS <- BS.hGetContents hout

diff --git a/TransRules.hs b/TransRules.hs
index d461b27..ca9b396 100644 (file)
--- a/TransRules.hs
+++ b/TransRules.hs
@@ -191,16 +191,55 @@ generateInstallabilityAtoms config pi ai =
     ) ai $
     IxM.toList (dependsBadHull pi)
 
+-- Wrapper around transitionRules' that prevents sharing. We _want_ to
+-- recalculate the rules everytime 'build' is called upon the producer.
+transitionRules :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
+     -> (Producer (Clause AtomI), Producer (Clause AtomI), Producer AtomI, Producer AtomI)
+transitionRules config ai unstable testing general pi =
+    ( hardTransitionRules config ai unstable testing general pi 
+    , softTransitionRules config ai unstable testing general pi 
+    , desiredAtoms config ai unstable testing general pi 
+    , unwantedAtoms config ai unstable testing general pi 
+    )
 
-transitionRules
+hardTransitionRules 
   :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
-     -> (Producer (Clause AtomI), Producer (Clause AtomI), [AtomI], [AtomI])
-transitionRules config ai unstable testing general pi =
+     -> Producer (Clause AtomI)
+hardTransitionRules config ai unstable testing general pi f x =
+    let (r,_,_,_) = transitionRules' config ai unstable testing general pi
+    in r f x
+
+softTransitionRules 
+  :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
+     -> Producer (Clause AtomI)
+softTransitionRules config ai unstable testing general pi f x =
+    let (_,r,_,_) = transitionRules' config ai unstable testing general pi
+    in r f x
+
+desiredAtoms 
+  :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
+      -> Producer AtomI
+desiredAtoms config ai unstable testing general pi f x =
+    let (_,_,a,_) = transitionRules' config ai unstable testing general pi
+    in a f x
+
+unwantedAtoms 
+  :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
+      -> Producer AtomI
+unwantedAtoms config ai unstable testing general pi f x =
+    let (_,_,_,a) = transitionRules' config ai unstable testing general pi
+    in a f x
+
+
+transitionRules'
+  :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> PackageInfo
+     -> (Producer (Clause AtomI), Producer (Clause AtomI), Producer AtomI, Producer AtomI)
+transitionRules' config ai unstable testing general pi =
     if fullDependencies config then
     ( toProducer $ keepSrc ++ keepBin ++ uniqueBin ++ needsSource ++ needsBinary ++ releaseSync ++ completeBuild ++ outdated ++ obsolete ++ tooyoung ++ buggy ++ hardDependenciesFull
     , toProducer $ conflictClauses ++ softDependenciesFull
-    , desired
-    , unwanted
+    , toProducer $ desired
+    , toProducer $ unwanted
     )
     else error "unsupported" {-
     ( toProducer $ keepSrc ++ keepBin ++ uniqueBin ++ needsSource ++ needsBinary ++ releaseSync ++ completeBuild ++ outdated ++ obsolete ++ tooyoung ++ buggy

diff --git a/Types.hs b/Types.hs
index c865940..d07da7d 100644 (file)
--- a/Types.hs
+++ b/Types.hs
@@ -245,5 +245,13 @@ type Producer a = forall b. (a -> b -> b) -> b -> b
 toProducer l f x = foldr f x l
 {-# INLINE toProducer #-}
 
+mapP :: (a -> b) -> Producer a -> Producer b
+mapP f p c n = p (\x ys -> c (f x) ys) n
+{-# INLINE mapP #-}
+
+concatP :: Producer a -> Producer a -> Producer a
+concatP p1 p2 c n = p1 c (p2 c n)
+{-# INLINE concatP #-}
+
 mbDo Nothing _ = return ()
 mbDo (Just x) f = f x