diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 + +Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Michael B. Gale and Oscar Harris + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,53 @@ +# Iterative Forward Search + +![MIT](https://img.shields.io/github/license/fpclass/iterative-forward-search) +[![CI](https://github.com/fpclass/iterative-forward-search/actions/workflows/haskell.yaml/badge.svg)](https://github.com/fpclass/iterative-forward-search/actions/workflows/haskell.yaml) +[![stackage-nightly](https://github.com/fpclass/iterative-forward-search/actions/workflows/stackage-nightly.yaml/badge.svg)](https://github.com/fpclass/iterative-forward-search/actions/workflows/stackage-nightly.yaml) +[![iterative-forward-search](https://img.shields.io/hackage/v/iterative-forward-search)](https://hackage.haskell.org/package/iterative-forward-search) + +This library implements a contraint solver via the [iterative forward search algorithm](https://muller.unitime.org/lscs04.pdf). It also includes a helper module specifically for using the algorithm to timetable events. + +## Usage + +To use the CSP solver first create a `CSP` value which describes your CSP, for example +```haskell +csp :: CSP Solution +csp = MkCSP { + cspVariables = IS.fromList [1,2,3], + cspDomains = IM.fromList [(1, [1, 2, 3]), (2, [1, 2, 4]), (3, [4, 5, 6])], + cspConstraints = [ (IS.fromList [1, 2], \a -> IM.lookup 1 a != IM.lookup 2 a) + , (IS.fromList [2, 3], \a -> IM.lookup 2 a >= IM.lookup 3 a) + ], + cspRandomCap = 30, -- 10 * (# of variables) is a reasonable default + cspTermination = defaultTermination +} +``` + +This example represents a CSP with 3 variables, `1`, `2` and `3`, where variable `1` has domain `[1, 2, 3]`, variable `2` has domain `[1, 2, 4]`, and variable `3` has domain `[4, 5, 6]`. The contraints are that variable `1` is not equal to variable `2`, and variable `2` is at least as big as variable `3`. It uses the default termination condition, and performs 30 iterations before we select variables randomly. + +You can then find a solution simply by evaluating `ifs csp`, which will perform iterations till the given termination function returns a `Just` value. + +### Timetabling + +The `toCSP` function in `Data.IFS.Timetable` takes a mapping from slot IDs to intervals, a hashmap of event IDs to the person IDs involved, and a map of person IDs to the slots where they are unavailable and generates a CSP which can then be solved with `ifs`. For example: + +```haskell +slotMap :: IntMap (Interval UTCTime) +slotMap = IM.fromList [(1, eventTime1), (2, eventTime2), (3, eventTime3)] + +events :: HashMap Int [person] +events = HM.fromList [(1, [user1, user2]), (2, [user1])] + +unavailability :: HashMap person (Set Int) +unavailability = HM.fromList [(user1, S.empty), (user2, S.fromList [1,3])] + +csp :: CSP r +csp = toCSP slotMap events unavailability defaultTermination +``` + +This will generate a CSP that creates a mapping from the events 1 and 2 to the time slots 1, 2 and 3. + +## Limitations + +- Variables and values must be integers +- Only hard constraints are supported diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,124 @@ +-------------------------------------------------------------------------------- +-- 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) + ] + ] + +-------------------------------------------------------------------------------- diff --git a/iterative-forward-search.cabal b/iterative-forward-search.cabal new file mode 100644 --- /dev/null +++ b/iterative-forward-search.cabal @@ -0,0 +1,66 @@ +cabal-version: 1.12 +name: iterative-forward-search +version: 0.1.0.0 +license: MIT +license-file: LICENSE +copyright: Copyright (c) Michael B. Gale and Oscar Harris +maintainer: m.gale@warwick.ac.uk +author: Michael B. Gale and Oscar Harris +homepage: https://github.com/fpclass/iterative-forward-search#readme +bug-reports: https://github.com/fpclass/iterative-forward-search/issues +synopsis: An IFS constraint solver +description: + An implementation of the IFS contraint satisfaction algorithm + +category: Constraints, Library +build-type: Simple +extra-source-files: + README.md + Changelog.md + +source-repository head + type: git + location: https://github.com/fpclass/iterative-forward-search + +library + exposed-modules: + Data.IFS + Data.IFS.Algorithm + Data.IFS.Timetable + Data.IFS.Types + + hs-source-dirs: src + other-modules: Paths_iterative_forward_search + default-language: Haskell2010 + default-extensions: RecordWildCards TupleSections + build-depends: + base >=4.7 && <5, + containers <0.7, + deepseq <1.5, + fingertree <0.2, + hashable <1.4, + random <1.2, + time <1.10, + transformers <0.6, + unordered-containers <0.3 + +benchmark iterative-forward-search-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + other-modules: Paths_iterative_forward_search + default-language: Haskell2010 + default-extensions: RecordWildCards TupleSections + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5, + containers <0.7, + criterion <1.6, + deepseq <1.5, + fingertree <0.2, + hashable <1.4, + iterative-forward-search -any, + random <1.2, + time <1.10, + transformers <0.6, + unordered-containers <0.3 diff --git a/src/Data/IFS.hs b/src/Data/IFS.hs new file mode 100644 --- /dev/null +++ b/src/Data/IFS.hs @@ -0,0 +1,17 @@ +-------------------------------------------------------------------------------- +-- Iterative Forward Search -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the terms found in the LICENSE file in -- +-- the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +module Data.IFS ( + module R +) where + +-------------------------------------------------------------------------------- + +import Data.IFS.Algorithm as R +import Data.IFS.Types as R + +-------------------------------------------------------------------------------- diff --git a/src/Data/IFS/Algorithm.hs b/src/Data/IFS/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Data/IFS/Algorithm.hs @@ -0,0 +1,239 @@ +-------------------------------------------------------------------------------- +-- Iterative Forward Search -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the terms found in the LICENSE file in -- +-- the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +module Data.IFS.Algorithm ( + defaultTermination, + ifs +) where + +-------------------------------------------------------------------------------- + +import Control.Arrow ( Arrow((&&&)) ) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Reader + +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Maybe ( fromJust ) + +import System.Random + +import Data.IFS.Types + +-------------------------------------------------------------------------------- + +-- | `defaultTermination` @iterations currAssign@ determines whether to continue +-- the algorithm or terminate. It terminates if the current assignment assigns +-- all variables or the maximum number of iterations has been exceded (25 times +-- the number of variables) +defaultTermination :: Int + -> Assignment + -> CSPMonad Solution (Maybe Solution) +defaultTermination iterations currAssign = do + -- get variables + vars <- cspVariables <$> ask + -- check conditions + case (IS.size vars > IM.size currAssign, iterations <= 25 * IS.size vars) of + (True, True) -> pure Nothing + (True, False) -> pure $ Just $ Incomplete currAssign + (False, _) -> pure $ Just $ Complete currAssign + +-- | `getMostRestricted` @vars doms cons@ indexes these variables by size of +-- domain - # connected constraints. The lowest index is then the most +-- restricted variable. +getMostRestricted :: Variables + -> Domains + -> Constraints + -> IM.IntMap [Var] +getMostRestricted vars doms cons = + -- TODO: Scaling one of these numbers could be better + IM.fromListWith (++) $ flip map (IS.toList vars) $ \var -> + (IS.size (doms IM.! var) - countConnectedCons var cons, [var]) + + where + -- counts the number of constraints connected to @var@ + countConnectedCons var = flip foldl 0 $ \conflicting (conVars, _) -> + if var `IS.member` conVars + then conflicting + 1 + else conflicting + +-- | `selectVariable` @currAssignment@ decides which variable to change next +selectVariable :: Int -> Assignment -> CSPMonad r Var +selectVariable iterations currAssignment = do + -- get CSP parameters + MkCSP{..} <- ask + + -- get variables currently not assigned. We can assume this is non-empty + -- as the algorithm terminates when all are assigned + let unassigned = cspVariables IS.\\ IS.fromList (IM.keys currAssignment) + + -- find which of these is most restricted + let restricted = getMostRestricted unassigned cspDomains cspConstraints + + -- if we are before the random cap then pick one of the most difficult + -- variables + if iterations < cspRandomCap + then + -- pick a random variable from the most difficult + let toChoseFrom = snd $ IM.findMin restricted + in (toChoseFrom !!) <$> lift (randomRIO (0, length toChoseFrom - 1)) + else + -- pick any random variable + let unassignedList = IS.toList unassigned + in (unassignedList !!) <$> lift (randomRIO (0, length unassignedList - 1)) + +-- | `setValue` @csp currAssign var@ determines a value to assign to @var@ and +-- returns @currAssign@ with @var@ assigned to the determined value +setValue :: Assignment + -> Var + -> CSPMonad r Assignment +setValue currAssign var = do + (doms, cons) <- (cspDomains &&& cspConstraints) <$> ask + let domain = flip IS.filter (fromJust $ IM.lookup var doms) $ \val -> + countConflicts (IM.singleton var val) cons == 0 + + -- If no possible values return current assignment unchanged + if IS.null domain + then pure currAssign + else do + -- create map with key of the number of contraints violated, and the + -- value being a list of assignments with that number of conflicts + let conflictMap = IM.fromListWith (++) $ flip map (IS.toList domain) + $ \val -> + let assignment = IM.insert var val currAssign + in (countConflicts assignment cons, [assignment]) + + -- TODO: Some kind of nice formula - weight the smaller conflicts more + -- and the weighting should be heaver if the gap between nums of + -- conflicts is larger + -- Will chose from the 10% of assignments with the lowest number of + -- conflicts + let cap = ceiling $ 0.1 * fromIntegral (IS.size domain) + + -- get at least @cap@ assignments in order of conflicts + let toChoseFrom = getToChoseFrom 0 cap [] conflictMap + + -- get a radndom assignment from this list + (toChoseFrom !!) <$> lift (randomRIO (0, length toChoseFrom - 1)) + + where + -- counts the number of conflicts in @assignment@ + countConflicts assignment = flip foldl 0 $ + \conflicting (_, constraintF) -> + if constraintF assignment + then conflicting + else conflicting + 1 + + -- gets lowest number of assignments >cap possible when sorting by + -- conflict number + getToChoseFrom :: Int + -> Int + -> [Assignment] + -> IM.IntMap [Assignment] + -> [Assignment] + getToChoseFrom n cap added toAdd + | n >= cap = added + | otherwise = let ((_,as), toAdd') = IM.deleteFindMin toAdd + in getToChoseFrom (n + length as) + cap + (added ++ as) + toAdd' + +-- | `removeConflicts'` @var assign constraintF toRemove@ repeated unassigns +-- one of the least constrained variables except @var@ from @assign@ until the +-- @constraintF@ passes +removeConflicts' :: Var + -> Assignment + -> (Assignment -> Bool) + -> IM.IntMap [Var] + -> Assignment +removeConflicts' var assign constraintF toRemove + | constraintF assign = assign + | otherwise = + let + -- get next minimum variables + (_, x:remaining) = IM.findMax toRemove + -- remove this variable from the map + toRemove' = if null remaining + then snd $ IM.deleteFindMax toRemove + else IM.updateMax (const $ Just remaining) toRemove + -- unassign this variable unless it is the variable just assigned + newAssign = if x==var then assign else IM.delete x assign + in removeConflicts' var newAssign constraintF toRemove' + +-- | `removeConflicts` @currAssign var@ checks which constraints from @csp@ +-- are violated by @currAssign@ and removes all variables involved in the +-- violated constraints except @var@ +removeConflicts :: Assignment + -> Var + -> CSPMonad r Assignment +removeConflicts currAssignment var = do + (doms, cons) <- (cspDomains &&& cspConstraints) <$> ask + -- check each constraint and if it is violated unassign variables until + -- the constraint passes + pure $ flip (flip foldl currAssignment) cons $ + \assign (constraintVars, constraintF) -> + if constraintF assign + then assign + else removeConflicts' var assign constraintF + $ getMostRestricted constraintVars doms cons + +-- | `getBest` @newAssign bestAssign@ determines whether @newAssign@ is better +-- than @bestAssign@ and returns the best out of the two. A random is picked +-- if both are deemed equally good +getBest :: Assignment + -> Assignment + -> CSPMonad r Assignment +getBest newAssign bestAssign = + case IM.size newAssign `compare` IM.size bestAssign of + -- if more variables are assigned in the current assignment it is better + GT -> pure newAssign + -- if less variables are assigned it is worse + LT -> pure bestAssign + -- if both have an equal number of variables assigned pick randomly + EQ -> do + useNew <- (<= 0.5) <$> (lift randomIO :: CSPMonad r Double) + pure $ if useNew then newAssign else bestAssign + +-- | `ifs'` @iterations currAssign bestAssign@ checks whether it should continue +-- the search given @currAssign@, and if so performs the next iteration of the +-- IFS algorithm and recursively calls this function again with the new +-- assignment. If `canContinue` returns false the best assignment found so far +-- is returned +ifs' :: Int + -> Assignment + -> Assignment + -> CSPMonad r r +ifs' iterations currAssign bestAssign = do + canContinue <- cspTermination <$> ask + continue <- canContinue iterations bestAssign + case continue of + Nothing -> do + -- get variable to change + var <- selectVariable iterations currAssign + + -- determine and set new value for @var@ + newAssignment <- setValue currAssign var + + -- find and unassign conflicting variables + conflictsRemoved <- removeConflicts newAssignment var + + -- run ifs' with the new assignment + nextAssignment <- getBest conflictsRemoved bestAssign + ifs' (iterations+1) conflictsRemoved nextAssignment + + Just a -> pure a + +-- | `ifs` @csp startingAssignment@ performs an iterative first search on @csp@ +-- using @startingAssignment@ as the initial assignment +ifs :: CSP r + -> Assignment + -> IO r +ifs csp startingAssignment = + runReaderT (ifs' 0 startingAssignment startingAssignment) csp + +-------------------------------------------------------------------------------- diff --git a/src/Data/IFS/Timetable.hs b/src/Data/IFS/Timetable.hs new file mode 100644 --- /dev/null +++ b/src/Data/IFS/Timetable.hs @@ -0,0 +1,133 @@ +-------------------------------------------------------------------------------- +-- Iterative Forward Search -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the terms found in the LICENSE file in -- +-- the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +module Data.IFS.Timetable ( + Slots, + Slot, + Event, + toCSP +) where + +-------------------------------------------------------------------------------- + +import Data.Hashable +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.List ( nub ) +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Time + +import Data.IFS.Types + +-------------------------------------------------------------------------------- + +type Slots = IS.IntSet +type Slot = Int +type Event = Int + +-- | `noOverlap` @vs@ ensures that no `Just` values in @vs@ are the same +noOverlap :: [Maybe Slot] -> Bool +noOverlap vs = length (nub assigned) == length assigned + where assigned = catMaybes vs + +-- | `noConcurrentOverlap` @vs slots@ ensures that the assigned values (the Just +-- values) in @vs@ do not overlap. @slots@ is used to fetch the interval for +-- each slot +noConcurrentOverlap :: [Maybe Slot] -> IM.IntMap (Interval UTCTime) -> Bool +noConcurrentOverlap vs slots = snd $ foldl f (empty, True) vs' + where + vs' = catMaybes vs + + f (im, False) _ = (im, False) + f (im, True) s = + let interval = (slots IM.! s) in + if all (\(i,_) -> low interval == high i || high interval == low i) + $ interval `intersections` im + then (insert interval () im, True) + else (im, False) + +-- | `calcDomains` @slots events unavailability@ creates the domain for each +-- event by finding all the slots where any member of the event is unavailable +-- and setting the domain to all slots except these +calcDomains :: (Eq person, Hashable person) + => Slots + -> HM.HashMap Event [person] + -> HM.HashMap person Slots + -> Domains +calcDomains slots events unavailability = + -- generate map of domains for every event + flip (flip HM.foldlWithKey' IM.empty) events $ \m event people -> + -- add domain for this event - all slots where no one is busy + flip (IM.insert event) m $ IS.difference slots $ + -- generate all slots where any member is unavailable + let unavailable = fromMaybe IS.empty . (`HM.lookup` unavailability) + in foldl (\s u -> s `IS.union` unavailable u) IS.empty people + +-- | `flipHashmap` @hm@ converts the hashmap of lists of type `b` with key `a` +-- to a hashmap indexed on values of `b` linked to lists of `a` +flipHashmap :: (Eq a, Hashable a, Eq b, Hashable b) + => HM.HashMap a [b] + -> HM.HashMap b [a] +flipHashmap hm = HM.fromListWith (++) $ concat $ flip HM.mapWithKey hm $ + \k vs -> map (, [k]) vs + +-- | `calcConstraints` @slots slotMap events@ creates the constraints which stop +-- the same slot being used by 2 events, and the same person being assigned to 2 +-- places at once +calcConstraints :: (Eq person, Hashable person) + => IM.IntMap (Interval UTCTime) + -> HM.HashMap Event [person] + -> Constraints +calcConstraints slotMap events = + let eventKeys = HM.keys events + noOverlapCons xs a = noConcurrentOverlap [a IM.!? i | i <- xs] slotMap + notOverlapping = filter ((>1) . length) $ HM.elems $ flipHashmap events + in -- prevent duplicate slot usage + (IS.fromList eventKeys, \a -> noOverlap [a IM.!? i | i <- eventKeys]) + -- prevent the same person being allocated to multple places at the same + -- time + : map (\xs -> (IS.fromList xs, noOverlapCons xs)) notOverlapping + +-- | `toCSP` @slots events unavailability termination@ creates a CSP that +-- timetables the events in @events@ such that everyones availability is +-- respected and no one is timetabled to 2 events simultaneously. In this CSP +-- the events are the variables, and the slots are the values. +-- +-- Slots are identified by integers, and must be supplied with a time interval, +-- and events are also identifed by intergers, and must be supplied as with a +-- list of all people in the event. People can be represented by anything with +-- a `Hashable` and an `Eq` instance, and @unavailability@ can be used to +-- specify the slots where a person is unavailable. +-- +-- Finally a termination condition must be provided. This is as defined in +-- "Data.IFS.Types" +toCSP :: (Eq person, Hashable person) + => IM.IntMap (Interval UTCTime) + -> HM.HashMap Event [person] + -> HM.HashMap person Slots + -> (Int -> Assignment -> CSPMonad r (Maybe r)) + -> CSP r +toCSP slotMap events unavailability term = + let slots = IM.keysSet slotMap + in MkCSP { + -- variables are the events + cspVariables = IS.fromList $ HM.keys events, + -- domains are the slots the events may be assigned to + cspDomains = calcDomains slots events unavailability, + -- constraints prevent several events being assigned to the same slot + -- and people being assigned to 2 places at once + cspConstraints = calcConstraints slotMap events, + -- iterate a maximum of 10 times the number of events before switching + -- to random variable selection + cspRandomCap = 10 * HM.size events, + -- use the provided termination condition + cspTermination = term + } + +-------------------------------------------------------------------------------- diff --git a/src/Data/IFS/Types.hs b/src/Data/IFS/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/IFS/Types.hs @@ -0,0 +1,87 @@ +-------------------------------------------------------------------------------- +-- Iterative Forward Search -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the terms found in the LICENSE file in -- +-- the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +module Data.IFS.Types ( + Var, + Val, + CSPMonad, + CSP(..), + Domains, + Variables, + Constraints, + Assignment, + Solution(..), + fromSolution +) where + +-------------------------------------------------------------------------------- + +import Control.DeepSeq +import Control.Monad.Trans.Reader ( ReaderT ) + +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +-------------------------------------------------------------------------------- + +-- | Represents a variable +type Var = Int + +-- | Represents a value +type Val = Int + +-- | Monad used in the CSP solver +type CSPMonad r = ReaderT (CSP r) IO + +-- | Represents a contraint satisfaction problem +data CSP r = MkCSP{ + cspDomains :: Domains, + cspVariables :: Variables, + cspConstraints :: Constraints, + -- | The number of iterations the algorithm should perform before selecting + -- unassigned variables at random instead of picking one of the most + -- constrained (to avoid getting stuck in a loop) + cspRandomCap :: Int, + -- | When to terminate and return the current assignment, given the number + -- of iterations performed and the current assignment. A `Nothing` value + -- means continue, and a `Just` value means terminate and return that + -- value + cspTermination :: Int -> Assignment -> CSPMonad r (Maybe r) +} + +-- | Represents the domains for different variables. The variables are indexed +-- by integers +type Domains = IM.IntMap IS.IntSet + +-- | Represents the variables used in the timetabling problem +type Variables = IS.IntSet + +-- | Represents the constraints for the timetabling problem. The first element +-- of the tuple represents the variables this constraint affects, the second is +-- the constraint itself +type Constraints = [(Variables, Assignment -> Bool)] + +-- | Represents an assignment of variables +type Assignment = IM.IntMap Val + +-- | This is returned by the IFS. `Complete` indicates the assignment is +-- complete, and `Incomplete` indicates the assignment is not complete +data Solution + = Complete Assignment + | Incomplete Assignment + deriving Show + +instance NFData Solution where + rnf = rnf . fromSolution + +-- | `fromSolution` @solution@ extracts an `Assignment` value from a `Solution` +-- value +fromSolution :: Solution -> Assignment +fromSolution (Complete a) = a +fromSolution (Incomplete a) = a + +--------------------------------------------------------------------------------