module FuzzyTimings.Solve (solveTimingBuckets) where
import FuzzyTimings.TimingBuckets
import FuzzyTimings.SlicedTime
import FuzzyTimings.TimeSlice
import FuzzyTimings.FuzzyTiming
import FuzzyTimings.AccTiming
import Control.Monad.LPMonad
import Control.Monad
import Data.LinearProgram
import qualified Data.Map as Map
tVar :: (Show k, Ord k) => FuzzyTiming k -> String
tVar f = "p" ++ (show $ ftId f)
bfVar :: (Show k, Ord k) => (Int, FuzzyTiming k) -> String
bfVar (i,f) = "b" ++ (show i) ++ "_" ++ (show $ ftId f)
sVar :: Int -> String
sVar i = "s" ++ (show i)
objFun :: (Show k, Ord k) => [FuzzyTiming k] -> LinFunc String Int
objFun fuzzies = linCombination $ [(ftDuration f, tVar f) | f <- fuzzies ]
timingBucketsLp :: (Show k, Ord k) => SlicedTime (FuzzyCountMap k) -> LP String Int
timingBucketsLp st = execLPM $ do
setDirection Max
setObjective (objFun fuzzies)
forM_ (Map.assocs tCounts) (\(f,c) -> do
setVarKind (tVar f) IntVar
varBds (tVar f) 0 (ceiling c)
equal (var (tVar f)) $ varSum [ bfVar (i,f') | (i,ts) <- nSlices,
(f',c') <- Map.assocs $ tsValue ts,
f == f']
)
forM_ nSlices (\(i,ts) -> do
equal (var (sVar i)) $ linCombination [ (ftDuration f, bfVar (i,f))
| f <- Map.keys $ tsValue ts ]
varBds (sVar i) 0 (floor $ (0.75::Double) * (fromIntegral $ tsDuration ts))
forM_ (Map.assocs $ tsValue ts) (\(f,c) -> do
setVarKind (bfVar (i,f)) IntVar
varBds (bfVar (i,f)) 0 (ceiling c)
))
where
slices = toTimeSlices st
fCounts = map tsValue slices
nSlices = [ (i, ts) | (i,ts) <- zip [1..] slices ]
tCounts = foldl (Map.unionWith (+)) Map.empty fCounts
fuzzies = Map.keys tCounts
updateTimingBuckets :: (Show k, Ord k) => SlicedTime (FuzzyCountMap k) -> Map.Map String Double -> SlicedTime (FuzzyCountMap k)
updateTimingBuckets st vm = fromTimeSlices [ ts {
tsValue = Map.mapWithKey (updateTs i) $ tsValue ts
} | (i, ts) <- zip [1..] (toTimeSlices st) ]
where
updateTs i f _ = Map.findWithDefault 0.0 (bfVar (i,f)) vm
solveTimingBuckets :: (Show k, Ord k) => SlicedTime (FuzzyCountMap k) -> IO (Maybe (SlicedTime (FuzzyCountMap k)))
solveTimingBuckets st = do
let lp = timingBucketsLp st
print $ lp
(_, mresult) <- glpSolveVars mipDefaults lp
print mresult
let res = (mresult >>= \(_,vm) -> return $ updateTimingBuckets st vm)
print res
return res