Room allocations

Alloc.hs

module Alloc where

import Data.List
import Control.Arrow

data Allocs = Allocs {checkouts :: [Int], checkins :: [Int]} deriving (Eq, Show)


allocs :: [[Int]] -> (Int, [Allocs])
allocs = first length . mapAccumL f []
  where 
    f :: [Int] -> [Int] -> ([Int], Allocs)
    f rooms arrivals = (rooms'', Allocs outs ins)
      where
        rooms'  = map (subtract 1) rooms
        outs    = [room | (nights, room) <- zip rooms' [0..], nights == 0]
        free    = [room | (nights, room) <- zip rooms' [0..], nights <= 0]
        ins     = [room | (nights, room) <- zip arrivals (free  ++ [length rooms..])]
        rooms'' = allocNewRooms rooms' arrivals


allocNewRooms :: [Int] -> [Int]-> [Int]
allocNewRooms []        guests              = guests
allocNewRooms rooms     []                  = rooms
allocNewRooms (r:rooms) (g:guests) | r <= 0 = g : allocNewRooms rooms guests
allocNewRooms (r:rooms) guests              = r : allocNewRooms rooms guests

Alloc2.hs

module Allocation where

import Data.List
import Control.Arrow

data Actions = Actions {deallocs :: [Int], allocs :: [Int]} 
  deriving (Eq, Show)

actions :: [[Int]] -> (Int, [Actions])
actions = first (\(_,_,maxSlot) -> maxSlot + 1) . mapAccumL processStep ([0..], repeat [], 0)
  where
    processStep (free, ds : futureDeallocs, maxSlot) items = (state', Actions ds as)
      where
        (state', as) = mapAccumL processItem (ds ++ free, futureDeallocs, maxSlot) items
    processItem (slot : free', futureDeallocs, maxSlot) item =
      ((free', modifyNth (slot:) (item-1) futureDeallocs, max slot maxSlot), slot)

modifyNth :: (a -> a) -> Int -> [a] -> [a]
modifyNth _ _ []       = []
modifyNth f 0 (x : xs) = f x : xs
modifyNth f n (x : xs) = x : modifyNth f (n-1) xs