diff --git a/FuzzyTimings/AccTiming.hs b/FuzzyTimings/AccTiming.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/AccTiming.hs @@ -0,0 +1,13 @@ +module FuzzyTimings.AccTiming where + +import Data.Time.LocalTime + +-- | Accurately timed object with duration +data AccTiming k = AccTiming { + atId :: k, + atTime :: LocalTime, + atDuration :: Int +} deriving (Show) + +instance (Eq k) => Eq (AccTiming k) where + a1 == a2 = atId a1 == atId a2 diff --git a/FuzzyTimings/FuzzyTiming.hs b/FuzzyTimings/FuzzyTiming.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/FuzzyTiming.hs @@ -0,0 +1,41 @@ +module FuzzyTimings.FuzzyTiming (FuzzyTiming(..), + ftPlayCount, + cropFuzzyTiming, + TimesToPlay) where + +import FuzzyTimings.SlicedTime +import FuzzyTimings.TimeSlice + +type TimesToPlay = Double + +-- | "Fuzzily" timed object that is to be scheduled a number of times within a period of time. +data FuzzyTiming k = FuzzyTiming { + ftId :: k, + ftPlayTimes :: SlicedTime TimesToPlay, + ftDuration :: Int +} deriving (Show) + +instance (Eq k) => Eq (FuzzyTiming k) where + ft1 == ft2 = ftId ft1 == ftId ft2 + +instance (Ord k) => Ord (FuzzyTiming k) where + compare f1 f2 = compare (ftId f1) (ftId f2) + +ftPlayCount :: FuzzyTiming k -> Double +ftPlayCount ft = sum [ tsValue ts | ts <- toTimeSlices $ ftPlayTimes ft ] + +cropFuzzyTiming :: SlicedTime () -> FuzzyTiming k -> FuzzyTiming k +cropFuzzyTiming allowed ft = ft { + ftPlayTimes = mapSlicedTime (intersectSlicedTime (ftPlayTimes ft) allowed) adjustTimesToPlay + + } + where + adjustTimesToPlay ts = Just $ ts { + tsValue = (fromIntegral $ tsDuration ts) + * totalTimesToPlay / (fromIntegral totalLength) + } + playTimeSlices = toTimeSlices $ ftPlayTimes ft + totalTimesToPlay = sum $ map tsValue playTimeSlices + totalLength = sum $ map tsDuration playTimeSlices + + diff --git a/FuzzyTimings/Schedule.hs b/FuzzyTimings/Schedule.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/Schedule.hs @@ -0,0 +1,47 @@ +module FuzzyTimings.Schedule (scheduleTimings) where +import FuzzyTimings.TimingBuckets +import FuzzyTimings.TimeSlice +import FuzzyTimings.SlicedTime +import FuzzyTimings.AccTiming +import FuzzyTimings.FuzzyTiming +import qualified Data.Map as Map +import System.Random +import Data.List + +scheduleTimings :: Show k => SlicedTime (FuzzyCountMap k) -> IO [AccTiming k] +scheduleTimings st = do + accTimings <- mapM scheduleSlice $ toTimeSlices st + return $ concat accTimings + +scheduleSlice :: Show k => TimeSlice (FuzzyCountMap k) -> IO [AccTiming k] +scheduleSlice ts = do + print instanceRanges + instances <- mapM rndInstancePos instanceRanges + return [ AccTiming (ftId ft) (addSecs pos (tsStart ts)) (ftDuration ft) + | (ft,pos) <- schedule instances ] + where + schedule instances = let + sortedInstances = sortBy (\(_,pos1) (_,pos2) -> compare pos1 pos2) + instances + in scheduleInstances 0 [ (ft,pos i (length instances)) + | ((ft,_), i) <- zip sortedInstances [0..] ] + instanceRanges = [ (ft,pos (i-1) ttp, (pos (i-1) ttp + pos i ttp) `div` 2) + | (ft,ttp) <- fts, i <- [1..ttp] ] + pos i ttp = (tsDuration ts * i) `div` ttp + fts = [ (ft,floor ttp) | (ft,ttp) <- Map.toList (tsValue ts) ] + rndInstancePos (ft,start,end) = do + pos <- randomRIO (start,end) + return (ft,pos) + + +scheduleInstances :: Int -> [(FuzzyTiming k, Int)] -> [(FuzzyTiming k, Int)] +scheduleInstances now ((ft,pos):xs) + | now > pos = (ft,now):scheduleInstances (now+ftDuration ft) xs + | otherwise = (ft,pos):scheduleInstances (pos+ftDuration ft) xs +scheduleInstances _ [] = [] + + + + + + diff --git a/FuzzyTimings/SlicedTime.hs b/FuzzyTimings/SlicedTime.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/SlicedTime.hs @@ -0,0 +1,81 @@ +module FuzzyTimings.SlicedTime (SlicedTime, + fromTimeSlices, + toTimeSlices, + fromBoundaries, + flattenSlicedTime, + intersectSlicedTime, + deleteSlicedTime, + slicedTimeBoundaries, + cutSlicedTime, + mapSlicedTime) where +import FuzzyTimings.TimeSlice +import Data.Maybe +import Control.Monad +import Data.Time.LocalTime +import Data.List + +data SlicedTime a = SlicedTime { + stSlices :: [TimeSlice a] + } deriving (Show, Eq) + + +fromTimeSlices :: [TimeSlice a] -> SlicedTime a +fromTimeSlices tss = SlicedTime { + stSlices = tss + } + +toTimeSlices :: SlicedTime a -> [TimeSlice a] +toTimeSlices st = stSlices st + +sortNub :: Ord a => [a] -> [a] +sortNub = map head . group . sort + +fromBoundaries :: [LocalTime] -> a -> SlicedTime a +fromBoundaries bs d = SlicedTime { + stSlices = slices bs + } + where slices (b1:b2:bs') = TimeSlice { + tsStart = b1, + tsEnd = b2, + tsValue = d + }:slices (b2:bs') + slices _ = [] + + + +intersectSlicedTime :: SlicedTime a -> SlicedTime b -> SlicedTime a +intersectSlicedTime st1 st2 = st1 { + stSlices = concatMap intersect (stSlices st1) + } + where intersect ts = mapMaybe (intersectTimeSlice ts) $ stSlices st2 + + +deleteSlicedTime :: SlicedTime a -> SlicedTime b -> SlicedTime a +deleteSlicedTime st1 st2 = foldl delete st1 (stSlices st2) + where delete st ts = st { + stSlices = concatMap (\t -> deleteTimeSlice t ts) $ stSlices st + } + +flattenSlicedTime :: SlicedTime a -> SlicedTime a +flattenSlicedTime st = SlicedTime { + stSlices = flatten (sort . stSlices $ st) + } + where + flatten (t1:t2:tss) + | overlaps t1 t2 = t1 { tsEnd = tsStart t2 } : flatten (t2:tss) + | otherwise = t1 : flatten (t2:tss) + flatten tss = tss + +slicedTimeBoundaries :: SlicedTime a -> [LocalTime] +slicedTimeBoundaries st = concatMap (\ts -> [tsStart ts, tsEnd ts]) + (stSlices st) + +cutSlicedTime :: SlicedTime a -> [LocalTime] -> SlicedTime a +cutSlicedTime st boundaries = st { + stSlices = concatMap (cutTimeSlice boundaries) (stSlices st) + } + +mapSlicedTime :: SlicedTime a -> (TimeSlice a -> Maybe (TimeSlice a)) -> SlicedTime a +mapSlicedTime st op = st { + stSlices = mapMaybe op (stSlices st) + } diff --git a/FuzzyTimings/Solve.hs b/FuzzyTimings/Solve.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/Solve.hs @@ -0,0 +1,82 @@ +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 corresponds to the combined play counts for a single fuzzy timing +tVar :: (Show k, Ord k) => FuzzyTiming k -> String +tVar f = "p" ++ (show $ ftId f) + +-- bfVar corresponds to the play counts for a fuzzy timing in a single timing +-- bucket +bfVar :: (Show k, Ord k) => (Int, FuzzyTiming k) -> String +bfVar (i,f) = "b" ++ (show i) ++ "_" ++ (show $ ftId f) + +-- sVar corresponds to the number of seconds used to play spots in a single +-- timing bucket +sVar :: Int -> String +sVar i = "s" ++ (show i) + +-- the objective is maximize the amount of spot seconds to play +-- consisting of combined play counts of each FuzzyTiming +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 + -- the total play count must be smaller than equal to the + -- desired play count + varBds (tVar f) 0 (ceiling c) + -- the total play count consists of play counts in individual buckets + equal (var (tVar f)) $ varSum [ bfVar (i,f') | (i,ts) <- nSlices, + (f',c') <- Map.assocs $ tsValue ts, + f == f'] + ) + forM_ nSlices (\(i,ts) -> do + -- measure the number of seconds play spots in this bucket + equal (var (sVar i)) $ linCombination [ (ftDuration f, bfVar (i,f)) + | f <- Map.keys $ tsValue ts ] + -- only 75% of the seconds can be used to play spots + varBds (sVar i) 0 (floor $ (0.75::Double) * (fromIntegral $ tsDuration ts)) + forM_ (Map.assocs $ tsValue ts) (\(f,c) -> do + setVarKind (bfVar (i,f)) IntVar + -- allow to play one additional time in case of fractional amounts + -- in a single bucket + varBds (bfVar (i,f)) 0 (ceiling c) + )) + where + slices = toTimeSlices st + fCounts = map tsValue slices + nSlices = [ (i, ts) | (i,ts) <- zip [1..] slices ] + -- combined play counts for all fuzzies + 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 + diff --git a/FuzzyTimings/TimeOfDaySlice.hs b/FuzzyTimings/TimeOfDaySlice.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/TimeOfDaySlice.hs @@ -0,0 +1,42 @@ +module FuzzyTimings.TimeOfDaySlice (TimeOfDaySlice(..), + mkTimeOfDaySlice, + todsOverlaps) where + +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Clock +import Data.Maybe +import Data.List + + +data TimeOfDaySlice a = TimeOfDaySlice { + todsStart :: TimeOfDay, + todsEnd :: TimeOfDay, + todsValue :: a +} deriving (Show) + + +instance Eq (TimeOfDaySlice a) where + t1 == t2 = todsStart t1 == todsStart t2 + && todsEnd t1 == todsEnd t2 + +instance Ord (TimeOfDaySlice a) where + compare t1 t2 = compare (todsStart t1) (todsStart t2) + +mkTimeOfDaySlice :: TimeOfDay -> Int -> a -> TimeOfDaySlice a +mkTimeOfDaySlice start duration value = TimeOfDaySlice { + todsStart = start, + todsEnd = dayFractionToTimeOfDay $ + timeOfDayToDayFraction start + fromIntegral duration, + todsValue = value + } + + +todsOverlaps :: TimeOfDaySlice a -> TimeOfDaySlice b -> Bool +todsOverlaps t1 t2 + | todsStart t1 == todsEnd t1 = False + | todsStart t2 == todsEnd t2 = False + | otherwise = (todsStart t1 >= todsStart t2 && todsStart t1 < todsEnd t2) + || (todsStart t2 >= todsStart t1 && todsStart t2 < todsEnd t1) + + diff --git a/FuzzyTimings/TimeSlice.hs b/FuzzyTimings/TimeSlice.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/TimeSlice.hs @@ -0,0 +1,96 @@ +module FuzzyTimings.TimeSlice (TimeSlice(..), + tsDuration, + mkTimeSlice, + overlaps, + addSecs, + inTimeSlice, + intersectTimeSlice, + deleteTimeSlice, + cutTimeSlice) where + +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Clock +import Data.Maybe +import Data.List + + +data TimeSlice a = TimeSlice { + tsStart :: LocalTime, + tsEnd :: LocalTime, + tsValue :: a +} deriving (Show) + +instance Eq (TimeSlice a) where + t1 == t2 = tsStart t1 == tsStart t2 + && tsEnd t1 == tsEnd t2 + +instance Ord (TimeSlice a) where + compare t1 t2 = compare (tsStart t1) (tsStart t2) + +tsDuration :: TimeSlice a -> Int +tsDuration t = floor $ (localTimeToUTC utc $ tsEnd t) + `diffUTCTime` + (localTimeToUTC utc $ tsStart t) + +addSecs :: Int -> LocalTime -> LocalTime +addSecs s lt = LocalTime { + localDay = addDays (fromIntegral (days + extraDay)) + (localDay lt), + localTimeOfDay = dayFractionToTimeOfDay endTodFrac + } + where + days = s `div` 86400 + rest = (fromIntegral (s `mod` 86400)) / 86400 + tod = localTimeOfDay lt + endTodFrac' = (timeOfDayToDayFraction tod) + rest + (extraDay, endTodFrac) + | endTodFrac' >= 1 = (1, endTodFrac' - 1) + | otherwise = (0, endTodFrac') + +mkTimeSlice :: LocalTime -> Int -> a -> TimeSlice a +mkTimeSlice start duration value = TimeSlice { + tsStart = start, + tsEnd = addSecs duration start, + tsValue = value + } + +inTimeSlice :: TimeSlice a -> LocalTime -> Bool +inTimeSlice ts lt = lt >= tsStart ts && lt < tsEnd ts +overlaps :: TimeSlice a -> TimeSlice b -> Bool +overlaps t1 t2 + | tsStart t1 == tsEnd t1 = False + | tsStart t2 == tsEnd t2 = False + | otherwise = (tsStart t1 >= tsStart t2 && tsStart t1 < tsEnd t2) + || (tsStart t2 >= tsStart t1 && tsStart t2 < tsEnd t1) + +intersectTimeSlice :: TimeSlice a -> TimeSlice b -> Maybe (TimeSlice a) +intersectTimeSlice t1 t2 + | overlaps t1 t2 = Just (t1 { + tsStart = max (tsStart t1) (tsStart t2), + tsEnd = min (tsEnd t1) (tsEnd t2) + }) + | otherwise = Nothing + +deleteTimeSlice :: TimeSlice a -> TimeSlice b -> [TimeSlice a] +deleteTimeSlice t1 t2 = deleteBy $ intersectTimeSlice t1 t2 + where + deleteBy (Just t3) + | tsStart t3 > tsStart t1 && tsEnd t3 < tsEnd t1 = + [ t1 { tsEnd = tsStart t3 }, t1 { tsStart = tsEnd t3 } ] + | tsStart t3 > tsStart t1 = [ t1 { tsEnd = tsStart t3 }] + | otherwise = [ t1 { tsStart = tsEnd t3 } ] + deleteBy Nothing = [t1] + + +cutTimeSlice :: [LocalTime] -> TimeSlice a -> [TimeSlice a] +cutTimeSlice times ts = let + times' = tsStart ts : filter (inTimeSlice ts) times ++ [tsEnd ts] + cut (t1:t2:lts) = ts { + tsStart = t1, + tsEnd = t2 + }:cut (t2:lts) + cut _ = [] + in (cut . sort . nub) times' + + diff --git a/FuzzyTimings/TimingBuckets.hs b/FuzzyTimings/TimingBuckets.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/TimingBuckets.hs @@ -0,0 +1,54 @@ +module FuzzyTimings.TimingBuckets (FuzzyCountMap, + TimingBuckets, + splitToTimingBuckets) + where + +import FuzzyTimings.SlicedTime +import FuzzyTimings.TimeSlice +import FuzzyTimings.FuzzyTiming +import FuzzyTimings.AccTiming +import Data.Time.LocalTime +import Data.Maybe +import Data.List +import qualified Data.Map as Map +import System.Random +import Control.Monad.State +type FuzzyCountMap k = Map.Map (FuzzyTiming k) TimesToPlay +type TimingBuckets k = SlicedTime (FuzzyCountMap k) + +emptyBucket :: FuzzyCountMap k +emptyBucket = Map.empty + +addToBucketGoal :: Ord k => FuzzyCountMap k -> FuzzyCountMap k -> FuzzyCountMap k +addToBucketGoal = Map.unionWith (+) + +emptyBuckets :: [LocalTime] -> TimingBuckets k +emptyBuckets lts = fromBoundaries (nub lts) emptyBucket + +cropBuckets :: (Ord k) => TimingBuckets k -> SlicedTime b -> TimingBuckets k +cropBuckets tb st = deleteSlicedTime tb st + +splitToBuckets :: (Ord k) => TimingBuckets k -> FuzzyTiming k -> TimingBuckets k +splitToBuckets tb ft = mapSlicedTime tb splitTo + where + playTimes = toTimeSlices $ ftPlayTimes ft + splitTo t = Just $ t { + tsValue = addToBucketGoal (tsValue t) + (Map.fromList (mapMaybe (proportion t) playTimes)) + } + proportion t1 t2 = do + t3 <- intersectTimeSlice t1 t2 + return $ (ft, tsValue t2 * fromIntegral (tsDuration t3) / + fromIntegral (tsDuration t2)) + +splitToTimingBuckets :: (Ord k) => [FuzzyTiming k] -> [AccTiming k] -> TimingBuckets k +splitToTimingBuckets fts ats = let + boundaries = concatMap (slicedTimeBoundaries . ftPlayTimes) fts + reserved = fromTimeSlices $ [ mkTimeSlice (atTime at) (atDuration at) () + | at <- ats ] + in foldl (\tb ft -> splitToBuckets tb ft) + (cropBuckets (emptyBuckets boundaries) + reserved) + fts + + diff --git a/FuzzyTimings/WeeklySlicedTime.hs b/FuzzyTimings/WeeklySlicedTime.hs new file mode 100644 --- /dev/null +++ b/FuzzyTimings/WeeklySlicedTime.hs @@ -0,0 +1,52 @@ +module FuzzyTimings.WeeklySlicedTime (WeeklySlicedTime, + fromTimeOfDaySlices, + toTimeOfDaySlices, + flattenWeeklySlicedTime, + implementWeeklySlicedTime) where +import FuzzyTimings.TimeSlice +import FuzzyTimings.TimeOfDaySlice +import FuzzyTimings.SlicedTime +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Calendar +import Data.Maybe +import Data.Time.LocalTime +import Data.List +import qualified Data.Map as Map + +type WeekDay = Int +type WSTMap a = Map.Map WeekDay [TimeOfDaySlice a] + +data WeeklySlicedTime a = WeeklySlicedTime { + wstSlices :: WSTMap a + } deriving (Show, Eq) + + +fromTimeOfDaySlices :: [(WeekDay, [TimeOfDaySlice a])] -> WeeklySlicedTime a +fromTimeOfDaySlices tss = WeeklySlicedTime { + wstSlices = Map.fromList tss + } + +toTimeOfDaySlices :: WeeklySlicedTime a -> [(WeekDay, [TimeOfDaySlice a])] +toTimeOfDaySlices = Map.toList . wstSlices + +flattenWeeklySlicedTime :: WeeklySlicedTime a -> WeeklySlicedTime a +flattenWeeklySlicedTime wst = WeeklySlicedTime { + wstSlices = Map.map (flatten . sort) (wstSlices wst) + } + where + flatten (t1:t2:tss) + | todsOverlaps t1 t2 = t1 { todsEnd = todsStart t2 } : flatten (t2:tss) + | otherwise = t1 : flatten (t2:tss) + flatten tss = tss + +implementWeeklySlicedTime :: WeeklySlicedTime a -> Day -> Day -> SlicedTime a +implementWeeklySlicedTime wst d1 d2 = fromTimeSlices slices + where + slices = [ TimeSlice (LocalTime d (todsStart tods)) + (LocalTime d (todsEnd tods)) + (todsValue tods) + | d <- days, tods <- Map.findWithDefault [] (weekDay d) + (wstSlices wst) ] + weekDay d = let (_,_,wd) = toWeekDate d in wd + days = [ addDays i d1 | i <- [0..diffDays d2 d1] ] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014 Tero Laitinen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fuzzy-timings.cabal b/fuzzy-timings.cabal new file mode 100644 --- /dev/null +++ b/fuzzy-timings.cabal @@ -0,0 +1,58 @@ +name: fuzzy-timings +version: 0.0.1 +license: MIT +license-file: LICENSE +author: Tero Laitinen +maintainer: Tero Laitinen +synopsis: Translates high-level definitions of "fuzzily" scheduled objects (e.g. play this commercial 10 times per hour between 9:00-13:00) to a list of accurately scheduled objects using glpk-hs. +description: + The original use case of this package is to implement "media planning" in + retail stores, that is, what should be played and when. Accurately scheduled + announcements, fuzzily scheduled commercials and store opening hours are taken + into account. +category: Scheduling +stability: Experimental +cabal-version: >= 1.8 +build-type: Simple +homepage: https://github.com/tlaitinen/fuzzy-timings + +library + build-depends: base >= 4.3 && < 5 + , time + , random + , containers + , glpk-hs + , mtl + + exposed-modules: + FuzzyTimings.AccTiming + FuzzyTimings.FuzzyTiming + FuzzyTimings.Schedule + FuzzyTimings.SlicedTime + FuzzyTimings.Solve + FuzzyTimings.TimeOfDaySlice + FuzzyTimings.TimeSlice + FuzzyTimings.TimingBuckets + FuzzyTimings.WeeklySlicedTime + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/tlaitinen/fuzzy-timings + +Test-suite tests + Type: exitcode-stdio-1.0 + Hs-source-dirs: tests + Main-is: main.hs + ghc-options: -Wall + build-depends: base >= 4 && < 5 + , test-framework >= 0.3.3 + , test-framework-quickcheck2 >= 0.2.9 + , test-framework-hunit >= 0.3.0 + , HUnit >= 1.2.5 + , QuickCheck >= 2.4.0 && <= 2.5.1.1 + , containers >= 0.4.0 + , time >= 1.4 + , fuzzy-timings + , random + , mtl diff --git a/tests/main.hs b/tests/main.hs new file mode 100644 --- /dev/null +++ b/tests/main.hs @@ -0,0 +1,166 @@ +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck +import Test.Framework.Providers.HUnit + +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.LocalTime +import Data.List +import Data.Maybe +import FuzzyTimings.TimeSlice +import FuzzyTimings.SlicedTime +import FuzzyTimings.FuzzyTiming +import FuzzyTimings.AccTiming +import FuzzyTimings.TimingBuckets +import FuzzyTimings.Solve +import FuzzyTimings.Schedule +import System.Random +import Control.Monad.State +import qualified Data.Map as Map + +instance Arbitrary UTCTime where + arbitrary = do + + day <- choose (1, 28) :: Gen Int + month <- choose (1, 12) :: Gen Int + year <- choose (1970, 2030) :: Gen Integer + seconds <- choose (0, 86400) :: Gen Integer + + return $ UTCTime { + utctDay = fromGregorian year month day, + utctDayTime = secondsToDiffTime seconds + } + +instance Arbitrary LocalTime where + arbitrary = do + year <- choose (1970, 2030) :: Gen Integer + month <- choose (1, 12) :: Gen Int + day <- choose (1, gregorianMonthLength year month) :: Gen Int + hour <- choose (0, 23) :: Gen Int + min <- choose (0, 59) :: Gen Int + sec <- choose (0, 59) :: Gen Int + return $ LocalTime { + localDay = fromGregorian year month day, + localTimeOfDay = TimeOfDay { + todHour = hour, + todMin = min, + todSec = (fromIntegral sec) + } + } + + +instance Arbitrary a => Arbitrary (TimeSlice a) where + arbitrary = do + value <- arbitrary + start <- arbitrary + duration <- choose (0, 86400) :: Gen Int + + return $ mkTimeSlice start duration value + +instance (Arbitrary a, Ord a, Show a) => Arbitrary (FuzzyTiming a) where + arbitrary = do + idNum <- arbitrary + playTimes <- arbitrary + times <- choose (0, 10) :: Gen Double + duration <- choose (0, 300) :: Gen Int + + return $ FuzzyTiming { + ftId = idNum, + ftPlayTimes = fromTimeSlices playTimes, + ftDuration = duration + } + +instance (Arbitrary a, Ord a, Show a) => Arbitrary (AccTiming a) where + arbitrary = do + idNum <- arbitrary + time <- arbitrary + duration <- choose (0, 300) :: Gen Int + return $ AccTiming { + atId = idNum, + atTime = time, + atDuration = duration + } + + + +instance (Arbitrary a, Ord a, Show a) => Arbitrary (SlicedTime a) where + arbitrary = do + tss <- arbitrary + return $ fromTimeSlices tss +occurrences :: Ord a => [a] -> [(a, Int)] +occurrences = map (\xs@(x:_) -> (x, length xs)) . group . sort + +main :: IO () +main = defaultMain tests + +lt1 :: LocalTime +lt1 = LocalTime { + localDay = fromGregorian 2013 1 1, + localTimeOfDay = TimeOfDay { + todHour = 18, + todMin = 30, + todSec = 15 + } + } +lt2 :: LocalTime +lt2 = LocalTime { + localDay = fromGregorian 2013 1 1, + localTimeOfDay = TimeOfDay { + todHour = 19, + todMin = 45, + todSec = 30 + } + } + +tsDuration_prop :: Bool +tsDuration_prop = tsDuration (TimeSlice { tsStart = lt1, tsEnd = lt2, tsValue = () }) == 4515 + +tsIntersect_prop :: TimeSlice () -> TimeSlice () -> Bool +tsIntersect_prop ts1 ts2 = overlaps ts1 ts2 == + isJust (intersectTimeSlice ts1 ts2) + +tsIntersect_commutative :: TimeSlice () -> TimeSlice () -> Bool +tsIntersect_commutative ts1 ts2 = intersectTimeSlice ts1 ts2 == intersectTimeSlice ts2 ts1 +slicedTimeIntersectProp :: SlicedTime () -> SlicedTime () -> Bool +slicedTimeIntersectProp st1 st2 = intersectSlicedTime st1 st2 == intersectSlicedTime st2 st1 + +timingBucketsAccReserved :: [FuzzyTiming ()] -> [AccTiming ()] -> Bool +timingBucketsAccReserved fts ats = let + tb = splitToTimingBuckets fts ats + reserved = fromTimeSlices [ mkTimeSlice (atTime at) (atDuration at) () + | at <- ats ] + commonSt = intersectSlicedTime reserved tb + in toTimeSlices commonSt == [] + + +cutTimeSlice_boundaries :: [LocalTime] -> TimeSlice () -> Bool +cutTimeSlice_boundaries lts ts = let + tss = cutTimeSlice lts ts + crossing ts = any (\lt -> lt > tsStart ts && lt < tsEnd ts) lts + in all (not . crossing) tss + +slicedTimeFlattenNoOverlaps :: SlicedTime () -> Bool +slicedTimeFlattenNoOverlaps st = let + tss = sort . toTimeSlices . flattenSlicedTime $ st + in all id [ not $ overlaps t1 t2 | t1 <- tss, t2 <- tss, t1 /= t2 ] + + +tests :: [Test.Framework.Test] +tests = [ + testGroup "FuzzyTimings.TimeSlice" $ [ + testProperty "tsDuration" tsDuration_prop, + testProperty "cutTimeSlice_boundary_not_crossed" cutTimeSlice_boundaries, + testProperty "intersect" tsIntersect_prop, + testProperty "intersect-commutative" tsIntersect_commutative + ], + testGroup "FuzzyTimings.SlicedTime" $ [ + testProperty "intersect-commutative" slicedTimeIntersectProp, + testProperty "flatten-no-overlaps" slicedTimeFlattenNoOverlaps + + ], + testGroup "FuzzyTimings.TimingBuckets" $ [ + testProperty "accurate-reserved" timingBucketsAccReserved + ] + + ]