--------------------------------------------------------------------------------
-- Iterative Forward Search --
--------------------------------------------------------------------------------
-- This source code is licensed under the terms found in the LICENSE file in --
-- the root directory of this source tree. --
--------------------------------------------------------------------------------
import Criterion.Main
import Control.Monad
import qualified Data.HashMap.Lazy as HM
import Data.IntervalMap.FingerTree
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Data.Maybe
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.IFS.Algorithm
import Data.IFS.Timetable
import Data.IFS.Types
--------------------------------------------------------------------------------
-- | A value representing 9am
am9 :: UTCTime
am9 = posixSecondsToUTCTime 1625043600
-- | A convenient operator for adding seconds to `UTCTime`
(+.) :: UTCTime -> NominalDiffTime -> UTCTime
(+.) = flip addUTCTime
-- | Possible slot set (max-assignment 8):
-- 4 sets of 2 overlapping slots (like 4 time slots with 2 rooms each)
solvableSlots :: IM.IntMap (Interval UTCTime)
solvableSlots = IM.fromList [ (1, Interval am9 (am9 +. 3600))
, (2, Interval am9 (am9 +. 3600))
, (3, Interval (am9 +. 3600) (am9 +. (2*3600)))
, (4, Interval (am9 +. 3600) (am9 +. (2*3600)))
, (5, Interval (am9 +. (2*3600)) (am9 +. (3*3600)))
, (6, Interval (am9 +. (2*3600)) (am9 +. (3*3600)))
, (7, Interval (am9 +. (3*3600)) (am9 +. (4*3600)))
, (8, Interval (am9 +. (3*3600)) (am9 +. (4*3600)))
]
-- | Impossible slot set (max-assignment 6):
-- 2 sets of 4 overlapping slots (like 2 time slots with 4 rooms each)
unsolvableSlots :: IM.IntMap (Interval UTCTime)
unsolvableSlots = IM.fromList [ (1, Interval am9 (am9 +. 3600))
, (2, Interval am9 (am9 +. 3600))
, (3, Interval am9 (am9 +. 3600))
, (4, Interval am9 (am9 +. 3600))
, (5, Interval (am9 +. 3600) (am9 +. (2*3600)))
, (6, Interval (am9 +. 3600) (am9 +. (2*3600)))
, (7, Interval (am9 +. 3600) (am9 +. (2*3600)))
, (8, Interval (am9 +. 3600) (am9 +. (2*3600)))
]
-- | A HashMap of who should be at certain events
events :: HM.HashMap Event [String]
events = HM.fromList $ zip [1..8]
[
["v", "m"],
["r", "pa"],
["v", "t"],
["v", "pe"],
["a", "j"],
["m", "r"],
["pa", "s"],
["pe", "v"]
]
-- | A HashMap of when each person is available
usersAvail :: HM.HashMap String Slots
usersAvail = HM.map IS.fromList $ HM.fromList
[
("v", []),
("m", []),
("r", []),
("pa", [2, 3, 6, 7]),
("t", []),
("pe", [1..5]),
("a", []),
("j", 2:[4..8]),
("s", [1..3])
]
--------------------------------------------------------------------------------
-- | A CSP made from the solvable slots
cspSolvable :: CSP Solution
cspSolvable = toCSP solvableSlots events usersAvail defaultTermination
-- | A CSP made from the unsolvable slots
cspUnsolvable :: CSP Solution
cspUnsolvable = toCSP unsolvableSlots events usersAvail defaultTermination
-- | `countExpectedLength` @expected solutions@ counts the number of solutions
-- that have @expected@ variables assigned
countExpectedLength :: Int -> [Solution] -> Int
countExpectedLength n = length . filter ((==n) . IM.size . fromSolution)
main :: IO ()
main = do
-- count how many times /1000 the result is the best length
resultsSolveable <- replicateM 1000 $ ifs cspSolvable IM.empty
putStrLn $ "Solvable Best: " ++ show (countExpectedLength 8 resultsSolveable)
resultsUnsolveable <- replicateM 1000 $ ifs cspUnsolvable IM.empty
putStrLn $ "Unsolvable Best: " ++ show (countExpectedLength 6 resultsUnsolveable)
-- benchmark solvable and unsolvable CSPs
defaultMain
[
bgroup "Basic IFS Tests"
[
bench "solvable" $
nfIO (ifs cspSolvable IM.empty),
bench "unsolvable" $
nfIO (ifs cspUnsolvable IM.empty)
]
]
--------------------------------------------------------------------------------