{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
-- |
-- Module: BDCS.Depsolve
-- Copyright: (c) 2016-2017 Red Hat, Inc.
-- License: LGPL
--
-- Maintainer: https://github.com/weldr
-- Stability: alpha
-- Portability: portable
--
-- Manage 'Builds' records in the database.
module BDCS.Depsolve(Formula(..),
CNFLiteral(..),
CNFAtom(..),
CNFFormula,
DepAssignment,
formulaToCNF,
solveCNF
-- export private symbols for testing
#ifdef TEST
, pureLiteralEliminate
, unitPropagate
#endif
)
where
import Control.Monad.Except(MonadError, catchError, throwError)
import Control.Monad.State(State, evalState, state)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Maybe(isNothing, mapMaybe)
import Data.Set(Set)
import qualified Data.Set as Set
import BDCS.Utils.Monad(concatMapM)
-- A logical proposition in negation normal form
-- (i.e., NOT is applied only to atoms, not sub-formulas)
data Formula a = Atom a
| Not a
| Or [Formula a]
| And [Formula a]
deriving(Eq, Show)
-- Conjunctive Normal Form (CNF) is, essentially, and AND of ORs. The formula is of the form
-- (a1 OR a2 ...) AND (b1 OR b2 OR ...) AND ...
-- where each a1, b2, etc is an atom or a not-atom.
-- To keep the size of converted formulas under control, some extra variables are added to represent
-- sub-formulas from the original expression.
data CNFLiteral a = CNFOriginal a
| CNFSubstitute Int
deriving(Eq, Ord, Show)
data CNFAtom a = CNFAtom (CNFLiteral a)
| CNFNot (CNFLiteral a)
deriving(Eq, Ord, Show)
type CNFFormula a = [[CNFAtom a]]
formulaToCNF :: Formula a -> CNFFormula a
formulaToCNF f =
-- wrap the call in a State Int starting at 0 to create a counter for substitution variables
evalState (formulaToCNF' f) 0
where
formulaToCNF' :: Formula a -> State Int (CNFFormula a)
-- easy ones: a becomes AND(OR(a)), NOT(a) becomes AND(OR(NOT(a)))
formulaToCNF' (Atom x) = return [[CNFAtom (CNFOriginal x)]]
formulaToCNF' (Not x) = return [[CNFNot (CNFOriginal x)]]
-- -- for an expression of the form And [a1, a2, a3, ...], we need to convert
-- each a1, a2, ... to CNF and concatenate the results.
--
-- In other words, for And [a1, a2], map the list to something like
--
-- [And[Or[a1_or1_1, a1_or1_2],
-- Or[a1_or2_1, a1_or2_2]],
-- And[Or[a2_or1, a2_or1_2],
-- Or[a2_or2_1, a2_or2_2]]]
--
-- which is equivalent to
--
-- And[Or[a1_or1_1, a1_or1_2],
-- Or[a1_or2_1, a1_or2_2],
-- Or[a2_or1_1, a2_or1_2],
-- Or[a2_or2_1, a2_or2_2]]
formulaToCNF' (And andFormulas) = concatMapM formulaToCNF' andFormulas
-- For Or, the equivalent formula is exponentially larger than the original, so instead
-- create an equisatisfiable formula using new substitution variables, via Tseytin transformations.
--
-- For a given expression:
--
-- a1 OR a2 OR a3 ...
--
-- we start out by creating an equisatisfiable expression with new variables:
--
-- (Z1 -> a1) AND (NOT(Z1) -> (a2 OR a3 ...))
--
-- starting with the left side of the AND, the expression is equivalent to
--
-- (NOT(Z1) OR a1)
--
-- and if we can convert a1 into CNF, we get an expression of the form
--
-- NOT(Z1) OR (a1_1 AND a1_2 AND ...)
--
-- where each a1_1, a1_2 etc is an OR. We can then use the distributive property to create
--
-- (NOT(Z1) OR a1_1) AND (NOT(Z1) OR a1_2) AND ...
--
-- which is CNF. Then, for the right hand side of that original AND pair up there, we're
-- left with:
--
-- Z1 OR (a2 OR a3 OR ...)
--
-- so to recurse, we convert (a2 OR a3 OR ...) to CNF, and then convert (Z1 OR (CNF))
-- to CNF via distribution as above. We then have AND , which is CNF.
-- end of recursion: OR of nothing is nothing, OR of 1 thing is just that thing
formulaToCNF' (Or []) = return [[]]
formulaToCNF' (Or [x]) = formulaToCNF' x
formulaToCNF' (Or (x:xs)) = do
-- Get and increment the counter
subVar <- state $ \i -> (CNFSubstitute i, i+1)
-- recurse on the left hand expression
lhCNF <- formulaToCNF' x
-- distribute NOT(subVar) AND lhCNF by adding NOT(subVar) into each of the OR lists
let lhSubCNF = map (CNFNot subVar:) lhCNF
-- recurse on the right hand side
rhCNF <- formulaToCNF' (Or xs)
-- distribute subVar across the right hand expression
let rhSubCNF = map (CNFAtom subVar:) rhCNF
-- combine the results
return (lhSubCNF ++ rhSubCNF)
-- assignments to literals that will satisfy a formula
type DepAssignment a = (a, Bool)
-- internal types for the variable=bool assignments
type AssignmentMap a = Map (CNFLiteral a) Bool
-- if the formula is unsolvable, returns Nothing, other Just the list of assignments
-- This function uses the Davis-Putnam-Logemann-Loveman procedure for satisfying the formula, which is as follows:
-- Repeatedly simplify the formula using unit propagation and pure literal elimination:
-- unit propagation looks for a clause that contains only one literal, assigns it, and then removes clauses satisfied by the assignment
-- for example, in
-- (a OR b OR c) AND (a) AND (b OR ~c)
--
-- (a) appears alone, so it must be true. We can then remove both (a) and (a OR b OR c), as these clauses are now satisfied
-- by a=True.
--
-- pure literal elimation looks for literals that only appear as true or false. In the above example, b is only present
-- in the formula as True (there is no ~b in the formula), so we can assign b=True and then remove all clauses containing b.
--
-- once simplified, pick a literal and assign it to True and try to satisfy the formula. If that doesn't work, assign to to False.
--
-- Repeat until solved.
solveCNF :: (MonadError String m, Ord a) => CNFFormula a -> m [DepAssignment a]
solveCNF formula = solveCNF' Map.empty formula
where
-- helper function that takes an assignment map and a formula
solveCNF' :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a]
solveCNF' assignments f =
-- simplify the formula. simplify will recurse as necessary
simplify assignments f >>= \case
-- All clauses have been satisfied, we're done. Return the assignments
(assignments', []) -> return $ assignmentsToList assignments'
-- otherwise, try an assignment, or if that fails try the opposite assignment
(assignments', formula') -> guessAndCheck assignments' formula'
guessAndCheck :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a]
guessAndCheck assignments f@((firstLiteral:_):_) =
try True `catchError` const (try False)
where
try val = do
let tryAssignments = Map.insert (atomToLiteral firstLiteral) val assignments
solveCNF' tryAssignments f
-- probably shouldn't happen
guessAndCheck assignments ([]:ys) = guessAndCheck assignments ys
-- No variables left, so we're done
guessAndCheck _ [] = return []
simplify :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a)
simplify assignments f = do
-- pureLiteralEliminate only updates the assignments, the assigned literals are actually
-- removed by unitPropagate.
let pleAssignments = pureLiteralEliminate Set.empty assignments f
(upAssignments, upFormula) <- unitPropagate pleAssignments f
-- repeat until the formula doesn't change
if f == upFormula then
return (upAssignments, upFormula)
else
simplify upAssignments upFormula
assignmentsToList :: Ord a => AssignmentMap a -> [DepAssignment a]
assignmentsToList assignments = let
-- start by getting everything out of the map as a list of (CNFLiteral, Bool)
literalList = Map.assocs assignments
in
-- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings
mapMaybe literalToOriginal literalList
where
-- unwrap original values, discard substitutes
literalToOriginal :: (CNFLiteral a, Bool) -> Maybe (a, Bool)
literalToOriginal (CNFOriginal x, b) = Just (x, b)
literalToOriginal _ = Nothing
-- find pure literals and add them to the assignment map. This just updates assignments and does not make a decision as
-- to satisfiability. It works by assuming every new literal it finds is pure and then correcting as needed. The Set
-- argument is the literals that have been found to be unpure (i.e, they appear as both A and ~A)
pureLiteralEliminate :: Ord a => Set (CNFLiteral a) -> AssignmentMap a -> CNFFormula a -> AssignmentMap a
-- end of recursion
pureLiteralEliminate _ assignments [] = assignments
-- end of a clause, move on to the next one
pureLiteralEliminate unpure assignments ([]:ys) = pureLiteralEliminate unpure assignments ys
-- update unpure and assignments based on the first element and continue
pureLiteralEliminate unpure assignments ((x:xs):ys) = let
(unpure', assignments') = updateAssignments
in
pureLiteralEliminate unpure' assignments' (xs:ys)
where
updateAssignments = let
literalX = atomToLiteral x
in
case (x, Map.lookup literalX assignments, Set.member literalX unpure) of
-- something we've already marked as unpure, skip it
(_, _, True) -> (unpure, assignments)
-- Not in the map, add it
(CNFAtom a, Nothing, _) -> (unpure, Map.insert a True assignments)
(CNFNot a, Nothing, _) -> (unpure, Map.insert a False assignments)
-- In the map and matches our guess, keep it
(CNFAtom _, Just True, _) -> (unpure, assignments)
(CNFNot _, Just False, _) -> (unpure, assignments)
-- otherwise we guessed wrong. Remove from the map and add to unpure
_ -> (Set.insert literalX unpure, Map.delete literalX assignments)
unitPropagate :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a)
-- We have a unit! If it's new, add it to assignments and eliminate the unit
-- If it's something in assignments, check that it matches
unitPropagate assignments ([x]:ys) = do
let literalX = atomToLiteral x
let boolX = atomToBool x
let literalLookup = Map.lookup literalX assignments
-- if literalLookup is Nothing, this is a new literal. add it to the assignments.
assignments' <- if | isNothing literalLookup -> return $ Map.insert literalX boolX assignments
-- old literal, matches
| Just boolX == literalLookup -> return assignments
-- old literal, does not match
| otherwise -> throwError "Unable to solve expression"
unitPropagate assignments' ys
-- for clauses with more than one thing:
-- if the clause contains any literal that matches the map, the whole clause is true and we can remove it
-- otherwise, remove any literals that do not match the map, as they cannot be true. If, after removing
-- untrue literals, the clause is empty, the expression is unsolvable.
unitPropagate assignments (clause:ys) = do
let clauseTrue = any (\atom -> Just (atomToBool atom) == Map.lookup (atomToLiteral atom) assignments) clause
let clauseFiltered = filter (\atom -> case Map.lookup (atomToLiteral atom) assignments of
Nothing -> True
Just x -> x == atomToBool atom) clause
if | clauseTrue -> unitPropagate assignments ys
| null clauseFiltered -> throwError "Unable to solve expression"
| otherwise -> do
(assignments', formula') <- unitPropagate assignments ys
return (assignments', clauseFiltered:formula')
unitPropagate assignments [] = return (assignments, [])
-- unwrap an atom
atomToLiteral :: CNFAtom a -> CNFLiteral a
atomToLiteral (CNFAtom x) = x
atomToLiteral (CNFNot x) = x
atomToBool :: CNFAtom a -> Bool
atomToBool (CNFAtom _) = True
atomToBool (CNFNot _) = False