Random Schedule Generator

Question

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 0days) 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

Answer 1

I've started working through a series of revisions in Git of which I'll highlight the best here. Here's the full random-schedule-generator commit log. They're in reverse chronological order so start from the bottom, each is a single small logical modification with my motivations for the change.

First, it doesn't seem slow at all to me. Maybe you're confused by the behavior between testLoop and main? testLoop prints its try messages in between calculating elements of the result list. The resulting [Schedule] is only printed after the function returns control to main, at which point it begins printing what is usually a ~37,000 element list all at once. Also, there is a HUGE difference between running this interpreted from GHCi and running the compiled version (with or without optimizations turned on).

Regarding your second point, there's certainly some poor thunking behavior. What I describe above is one example, those 37,000 Schedules are all kept in memory until they're printed out by main. I'll fix some memory leaks tangentially but not generating 50,000 tries will push memory usage beneath what I'd scrape the barrel for.

The majority of the changes I've made so far involve using functions out of the standard Prelude or from other modules in base to clean up or entirely eliminate some functions. For instance, I ended up replacing your shuffle function with shuffleM from random-shuffle which operates with a better time complexity and in the process threw out randomElem and ran. Here's my commit message with the full detail.

There isn't a list shuffling function provided in anywhere in the base package, but since it's one of those things that's easier to get subtly wrong than obviously right I added a dependency on the random-shuffle package and replaced shuffle with shuffleM (which operates in an arbitrary MonadRandom monad).

The original implementation of shuffle had O(n^2) complexity, and was weirdly biased due to the Eq constraint. Consider this:

data Foo = Foo Bool Int
instance Eq Foo where
    (Foo p _) == (Foo q _) = p == q

shuffle [Foo True 1, Foo True 2]
--> suppose randomElem selects Foo True 2
--> re = Foo True 2; restList = [Foo True 2]
== [Foo True 2, Foo True 2]

That may be a pathologic instance of Eq, but even so you wouldn't expect a shuffle function to drop or duplicate elements.

After switching shuffle functions we can also delete the randomElem function.

I've still yet to tackle getStretchList or noonesWorkingLongerThen, but I'll hopefully have some time tomorrow to take another pass and think more about architecture and data structures and get to those then as well.