In an attempt to try something new, and possibly help out at work, I tried creating a random schedule generator that generates schedules based on 3 inputs (Rotation length, Staff list, and Shift list), then filters them based on predicates (so far, the only predicate is to make sure that no-one is working longer then X days at a time).
So far, it seems to work, but has 2 issues:
It's incredibly slow. Obviously dependent on the computer, but it feels like it's taking longer then I expected it to.
It's taking up a ton of memory; even when I set an impossible predicate. Generating a million schedules uses up around 2.5GB of memory. This would be understandable if it was actually collecting a ton of schedules because of a loose restriction, but even when I impose something that results in a empty list (
noonesWorkingLongerThen 0
days) it still uses a ton of memory; even though in theory, it shouldn't be collecting anything. My only guess is that this is a by-product of lazy evaluation gone wrong somewhere.
Can someone please look it over and point out any bits that could be improved on (either to address my above points, or otherwise)? I'd also like to know if anything I'm doing (habits) are worth continuing.
Note that it's far from done, and isn't very user friendly yet. All the inputs are hard-coded into main()
.
import Data.List
import Data.Maybe
import System.Random
type ShiftList = String
data Day = Day Int [Shift] deriving (Eq, Show)
type Person = String
data Shift = Shift Char Person deriving (Eq, Show)
type Schedule = [Day]
ran = randomRIO
--Assumes that Nothing's have already been filtered
extJust :: Maybe a -> a
extJust (Just a) = a
selectJustsM :: IO [Maybe a] -> IO [a]
selectJustsM mayActs = mayActs >>= return . map extJust . filter isJust
randomElem :: [a] -> IO a
randomElem list = do
let enumLimit = (length list) - 1
r <- ran (0,enumLimit)
let e = [e | (n,e) <- zip [0..enumLimit] list, n == r]
return $ head e
shuffle :: Eq e => [e] -> IO [e]
shuffle [] = return []
shuffle list = do
re <- randomElem list
let restList = delete re list
recur <- shuffle restList
return $ re : recur
--Adds Xs ("is-off") to the shift list to pair up with non-working people
padShifts :: Int -> ShiftList -> ShiftList
padShifts nPeople shifts =
shifts ++ (take (nPeople - length shifts) $ repeat 'X')
--Randomly assigns people shifts
randomFillShifts :: [Person] -> ShiftList -> IO [Shift]
randomFillShifts people shifts = do
shuffledPeople <- shuffle people
return $ map (\(p,s) -> Shift s p) (zip shuffledPeople paddedShifts)
where
paddedShifts = padShifts (length people) shifts
randomDay :: Int -> [Person] -> ShiftList -> IO Day
randomDay day people shifts = do
rshifts <- randomFillShifts people shifts
return $ Day day rshifts
getRandomSchedule :: Int -> [Person] -> ShiftList -> IO Schedule
getRandomSchedule days people shifts = mapM (\day ->
randomDay day people shifts) [0..(days - 1)]
getTestSched :: IO Schedule
getTestSched = do
let days = 30
people = ["Brendon","Erin","Kenton","Troy"]
shifts = "DEXX"
s <- getRandomSchedule days people shifts
return s
testLoop :: Int -> [Person] -> ShiftList -> Int -> IO [Schedule]
testLoop days people shifts trys =
selectJustsM $ mapM (\t-> do
putStr $ if t `rem` 10000 == 0 then "Try number " ++ show t ++ "\n"
else ""
s <- getRandomSchedule days people shifts
if pred s
then return $ Just s
else return Nothing) [0..trys]
where
pred s = noonesWorkingLongerThen 7 s
main :: IO ()
main = do
let days = 30 --The full rotation length
people = ["B","E","K","T","R","C"] --Staff list
shifts = "123" --Each char is a seperate shift
found <- testLoop days people shifts 50000
print found
return ()
getStaffList :: Schedule -> [Person]
getStaffList (cDay:_) = let (Day _ shifts) = cDay in
map (\(Shift _ p) -> p) shifts
isOffOn :: Person -> Day -> Bool
person `isOffOn` (Day _ shifts) =
any (== True) $ map (\(Shift shift p) -> shift == 'X' && p == person) shifts
longestStreak :: Eq e => e -> [e] -> Int
longestStreak toMatch list =
snd $ foldr (\value oldV@(cStretch,cMax) ->
if value == toMatch
then (cStretch + 1,max cMax (cStretch + 1)) else (0,cMax)) (0,0) list
getStretchList :: Schedule -> [Int]
getStretchList sched =
map (\person ->
longestStreak False $ map (\day -> person `isOffOn` day) sched) staffList
where
staffList = getStaffList sched
--Restrictions:
noonesWorkingLongerThen :: Int -> Schedule -> Bool
noonesWorkingLongerThen daysLong sched =
not . any (>daysLong) $ getStretchList sched