fuzzy-timings (empty) → 0.0.1
raw patch · 13 files changed
+755/−0 lines, 13 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, fuzzy-timings, glpk-hs, mtl, random, test-framework, test-framework-hunit, test-framework-quickcheck2, time
Files
- FuzzyTimings/AccTiming.hs +13/−0
- FuzzyTimings/FuzzyTiming.hs +41/−0
- FuzzyTimings/Schedule.hs +47/−0
- FuzzyTimings/SlicedTime.hs +81/−0
- FuzzyTimings/Solve.hs +82/−0
- FuzzyTimings/TimeOfDaySlice.hs +42/−0
- FuzzyTimings/TimeSlice.hs +96/−0
- FuzzyTimings/TimingBuckets.hs +54/−0
- FuzzyTimings/WeeklySlicedTime.hs +52/−0
- LICENSE +21/−0
- Setup.hs +2/−0
- fuzzy-timings.cabal +58/−0
- tests/main.hs +166/−0
+ FuzzyTimings/AccTiming.hs view
@@ -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
+ FuzzyTimings/FuzzyTiming.hs view
@@ -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++
+ FuzzyTimings/Schedule.hs view
@@ -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 _ [] = []+ + + + ++
+ FuzzyTimings/SlicedTime.hs view
@@ -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)+ }
+ FuzzyTimings/Solve.hs view
@@ -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+
+ FuzzyTimings/TimeOfDaySlice.hs view
@@ -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)++
+ FuzzyTimings/TimeSlice.hs view
@@ -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'++
+ FuzzyTimings/TimingBuckets.hs view
@@ -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++
+ FuzzyTimings/WeeklySlicedTime.hs view
@@ -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] ]+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fuzzy-timings.cabal view
@@ -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
+ tests/main.hs view
@@ -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+ ]++ ]