iterative-forward-search (empty) → 0.1.0.0
raw patch · 9 files changed
+745/−0 lines, 9 filesdep +basedep +containersdep +criterion
Dependencies added: base, containers, criterion, deepseq, fingertree, hashable, iterative-forward-search, random, time, transformers, unordered-containers
Files
- Changelog.md +5/−0
- LICENSE +21/−0
- README.md +53/−0
- bench/Main.hs +124/−0
- iterative-forward-search.cabal +66/−0
- src/Data/IFS.hs +17/−0
- src/Data/IFS/Algorithm.hs +239/−0
- src/Data/IFS/Timetable.hs +133/−0
- src/Data/IFS/Types.hs +87/−0
+ Changelog.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++Initial Release
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,53 @@+# Iterative Forward Search+++[](https://github.com/fpclass/iterative-forward-search/actions/workflows/haskell.yaml)+[](https://github.com/fpclass/iterative-forward-search/actions/workflows/stackage-nightly.yaml)+[](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
+ bench/Main.hs view
@@ -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)+ ]+ ]++--------------------------------------------------------------------------------
+ iterative-forward-search.cabal view
@@ -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
+ src/Data/IFS.hs view
@@ -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++--------------------------------------------------------------------------------
+ src/Data/IFS/Algorithm.hs view
@@ -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++--------------------------------------------------------------------------------
+ src/Data/IFS/Timetable.hs view
@@ -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+ }++--------------------------------------------------------------------------------
+ src/Data/IFS/Types.hs view
@@ -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++--------------------------------------------------------------------------------