module Data.DCFL (
Distribution,
Values,
Variable,
ConstraintEl,
Solved,
initDistribution,
cummDistribution,
checkSolved,
randomizeSingle,
randomize,
printVariables,
getConstraintsFor,
justConstraints,
solve,
update,
updateEach,
updateEachTimes,
solveParallel,
updateEachTimesParallel,
updateEachParallel
) where
import System.Random
import Control.Parallel.Strategies
import Control.DeepSeq
data Distribution = Distribution {probab::[Double]} deriving Show
instance NFData Distribution where
rnf (Distribution probab) = rnf probab
data Values = Values [Integer] deriving Show
data Variable = Variable {possible::[Int], valueIndex::Int,
distr::Distribution} deriving (Show)
instance NFData Variable where
rnf (Variable possible valueIndex distr) = rnf (possible, valueIndex, distr)
data ConstraintEl = ConstraintEl {variableIndices :: [Int],
constraint :: ([Int] -> Bool)}
data Solved = Solved {variables :: [Variable], iterationCount :: Int}
instance Show ConstraintEl where
show (ConstraintEl variableIndices _) =
"Constraint " ++ (show variableIndices)
width :: Distribution -> Int
width (Distribution p) = fromIntegral $ length p
b = 0.1 :: Double
oneIfEqual :: (Eq a) => a -> a -> Int
oneIfEqual x val
| val == x = 1
| otherwise = 0
replicateDouble :: Int -> Double -> [Double]
replicateDouble a f
| a == 0 = []
| otherwise = (f :) $ replicate (a 1) f
initDistribution :: Int -> Distribution
initDistribution width = Distribution $
replicateDouble width (1.0/(fromIntegral width))
failureCurrProb :: Int -> Double -> Double
failureCurrProb _ currValue = (1.0b)*currValue
failureOtherProb :: Int -> Double -> Double
failureOtherProb width currValue = ((1.0b)*currValue) + (b/((fromIntegral $ width)1.0))
failureProb :: Int -> Int -> Double -> Int -> Double
failureProb width valueIndex currValue currIndex
| valueIndex == currIndex = failureCurrProb width currValue
| otherwise = failureOtherProb width currValue
updateProb :: Distribution -> Int -> Bool -> Distribution
updateProb dist@(Distribution p) valueIndex success
| success = Distribution $
map (\x -> fromIntegral $ oneIfEqual (snd x) valueIndex) $ zip p [0..]
| otherwise = Distribution $ map (\x ->
failureProb (width dist) valueIndex (fst x) (snd x)) $ zip p [0..]
updateVariableProb :: Variable -> Bool -> Variable
updateVariableProb (Variable possib valIndex dist) success =
Variable possib valIndex $ updateProb dist valIndex success
cummDistributionIter :: Distribution -> Int -> Double -> [Double]
cummDistributionIter dist@(Distribution p) ind curr
| ind == length p = []
| otherwise = newCurr : (cummDistributionIter dist (ind + 1) (newCurr)) where
newCurr = curr + (p !! ind)
cummDistribution :: Distribution -> Distribution
cummDistribution dist@(Distribution p) = Distribution $ cummDistributionIter dist 0 0
getValueIndex :: Distribution -> Double -> Int
getValueIndex (Distribution p) randValue =
length $ takeWhile (\x -> randValue > (fst x)) $ zip p [0..]
randomNum :: IO Double
randomNum = do
x <- getStdRandom (randomR (0.0, 1.0))
return x
randomizeVariable :: Variable -> IO Variable
randomizeVariable var@(Variable p v dist) = do
randVal <- randomNum
let newValIndex = getValueIndex (cummDistribution dist) randVal in
return $ Variable p newValIndex dist
evalConstraint :: ([Int] -> Bool) -> [Int] -> Bool
evalConstraint constraint values = constraint values
evalConstraints :: [[Int] -> Bool] -> [Int] -> Bool
evalConstraints constraints values =
foldr (&&) True $ map (\c -> evalConstraint c values) constraints
applyAt :: (a -> a) -> Int -> [a] -> [a]
applyAt f index list =
map (\x -> if (snd x) == index then f (fst x)
else (fst x)) $ zip list [0..]
getConstraintsFor :: Int -> [ConstraintEl] -> [[Int] -> Bool]
getConstraintsFor n constraintSet =
[constraint | ConstraintEl [a, b] constraint <- constraintSet, ((a == n) || (b == n))]
justConstraints :: [ConstraintEl] -> [[Int] -> Bool]
justConstraints = map constraint
getValues variables = map (\(Variable _ val _) -> val) variables
randomizeSingle::Int -> [Variable] -> [IO Variable]
randomizeSingle variableIndex variables =
map (\x -> if (snd x) == variableIndex then randomizeVariable $ fst x
else return $ (fst x)) $ zip variables [0..]
randomize :: [Variable] -> [IO Variable]
randomize variables = map randomizeVariable variables
printVariables :: [Variable] -> [IO ()]
printVariables variables = do
map (putStrLn . show) variables
update :: Int -> [Variable] -> [ConstraintEl] -> IO [Variable]
update variableIndex variables constraintSet = do
rvariables <- sequence $ randomizeSingle variableIndex variables
let values = getValues rvariables
constraints = getConstraintsFor variableIndex constraintSet
constraintRes = evalConstraints constraints values
appliedVars = applyAt (\var -> updateVariableProb var constraintRes)
variableIndex rvariables in
return appliedVars
updateEach' :: [Variable] -> [ConstraintEl] -> [Int] -> IO [Variable]
updateEach' variables constraintSet (i:indices)
| length indices > 0 = do
vars <- update i variables constraintSet
updateEach' vars constraintSet indices
| otherwise = do
return variables
updateEach :: [Variable] -> [ConstraintEl] -> IO [Variable]
updateEach variables constraintSet =
updateEach' variables constraintSet [0 .. (length variables)]
updateEachTimes :: [Variable] -> [ConstraintEl] -> Int -> IO [Variable]
updateEachTimes variables constraintSet n
| n > 0 = do
rvars <- updateEach variables constraintSet
updateEachTimes rvars constraintSet (n 1)
| otherwise = return variables
checkDistrSolved :: Distribution -> Bool
checkDistrSolved (Distribution probab) = all (\x -> x == 0.0 || x == 1.0) probab
checkSolved :: [Variable] -> Bool
checkSolved [] = True
checkSolved (var:vars)
| checkDistrSolved $ distr var = checkSolved vars
| otherwise = False
solve :: [Variable] -> [ConstraintEl] -> IO Solved
solve vars constraints = do
rvars <- updateEachTimes vars constraints 10
if checkSolved rvars
then return $ Solved rvars 0
else do
solved <- solve rvars constraints
return $ Solved (variables solved) ((iterationCount solved) + 1)
updateMapF :: [Variable] -> [ConstraintEl] -> Int -> IO Variable
updateMapF variables constraints index = do
rvars <- update index variables constraints
return (rvars !! index)
updateEachParallel :: [Variable] -> [ConstraintEl] -> IO [Variable]
updateEachParallel variables constraints = do
m <- sequence $ map (updateMapF variables constraints) [0..(length variables)]
let mp = m `using` parList rdeepseq in return mp
updateEachTimesParallel :: [Variable] -> [ConstraintEl] -> Int -> IO [Variable]
updateEachTimesParallel variables constraints times
| times == 0 = return variables
| otherwise = do
rvars <- updateEachParallel variables constraints
updateEachTimesParallel variables constraints (times 1)
solveParallel :: [Variable] -> [ConstraintEl] -> IO Solved
solveParallel vars constraints = do
rvars <- updateEachTimesParallel vars constraints 10
if checkSolved rvars
then return $ Solved rvars 0
else do
solved <- solve rvars constraints
return $ Solved (variables solved) ((iterationCount solved) + 1)