module FileFormat.TIM ( RawTimeTableProblem(RawTimeTableProblem,rawNumberOfEvents,rawNumberOfRooms,
rawNumberOfPeople,rawNumberOfFeatures,rawNumberOfSlotsPerDay,
rawNumberOfDays,rawRoomSizes,rawPersonEventLookup,rawRoomFeatureLookup,
rawEventFeatureLookup),
parseFile,loadTIMFileRaw,loadTIMFile,convertToConstrainedProblem,rawToCSV
)where
import CombinatorialOptimisation.TIM
import qualified Data.Array as A
import qualified Data.Map as M
import Data.List
import Control.Monad
import Text.ParserCombinators.Parsec
data RawTimeTableProblem
= RawTimeTableProblem { rawNumberOfEvents :: Int
, rawNumberOfRooms :: Int
, rawNumberOfPeople :: Int
, rawNumberOfFeatures :: Int
, rawNumberOfSlotsPerDay :: Int
, rawNumberOfDays :: Int
, rawRoomSizes :: RoomNumber->Int
, rawPersonEventLookup :: PersonNumber->[EventNumber]
, rawRoomFeatureLookup :: RoomNumber->[FeatureNumber]
, rawEventFeatureLookup :: EventNumber->[FeatureNumber]
}
readHeader :: Parser (Int,Int,Int,Int)
readHeader = do [a,b,c,d] <-replicateM 4 readNum
return (a,b,c,d)
readNum :: Parser Int
readNum = do as<-many digit;spaces;return $ read as
chunkStream :: Int->[a]->[[a]]
chunkStream i [] = []
chunkStream i xs = let (as,bs) = splitAt i xs in as : chunkStream i bs
invertLookup :: (Ord a,Ord b,A.Ix b)=> [a]->[b]->(a->[b])->b->[a]
invertLookup baseIndices newIndices baseLookup = (A.!) (A.array (minimum newIndices,maximum newIndices) (M.toList dat))
where
dat'' = M.fromList $ zip newIndices (repeat [])
dat' = foldl' f dat'' baseIndices
dat = M.map sort dat'
f c k = let xs = baseLookup k
in foldl' (\c' k'->M.adjust (k:) k' c') c xs
parseFile :: Parser RawTimeTableProblem
parseFile = do (nEvents,nRooms,nFeatures,nPeople)<-readHeader
roomSizes<-replicateM nRooms readNum
personEventGrid <-replicateM (nEvents*nPeople) readNum
roomFeatureGrid<-replicateM (nRooms*nFeatures) readNum
eventFeatureGrid <-replicateM (nEvents*nFeatures) readNum
return $ RawTimeTableProblem nEvents nRooms nPeople nFeatures 9 5
(makeArrayLookup roomSizes)
(cga nEvents personEventGrid)
(cga nFeatures roomFeatureGrid)
(cga nFeatures eventFeatureGrid)
where
gridToLookup xs = [b |(a,b)<-zip xs [0..],a==1]
makeArrayLookup xs = (A.!) (A.listArray (0,length xs 1) xs)
cga n as = makeArrayLookup . (map gridToLookup) . (chunkStream n) $ as
loadTIMFileRaw :: String->IO RawTimeTableProblem
loadTIMFileRaw fName = do rawContents<-readFile fName
let k = parse parseFile "" rawContents
let (Right x) = k
return x
loadTIMFile :: String->IO TimeTable
loadTIMFile s = (loadTIMFileRaw s) >>= (return . convertToConstrainedProblem)
convertToConstrainedProblem :: RawTimeTableProblem->TimeTable
convertToConstrainedProblem input
= TimeTable (rawNumberOfEvents input) (rawNumberOfRooms input) (rawNumberOfPeople input) (rawNumberOfDays input * rawNumberOfSlotsPerDay input)
(rawPersonEventLookup input) eventToPerson eventToRoom (invertLookup eventList roomList eventToRoom) M.empty M.empty M.empty eventList
(numDays1) (numSlots1) 0 (\x->x `div` numSlots) (\x->x `mod` numSlots) numEventsInDayEmpty 0 0 0
where
eventToPerson = invertLookup [0 .. rawNumberOfPeople input 1] eventList (rawPersonEventLookup input)
roomList = [0 .. rawNumberOfRooms input 1]
eventList = [0 .. rawNumberOfEvents input 1]
allEventsAnywhere = M.fromList $ zip eventList (repeat roomList)
filteredForSizes = foldl' filterOnRoomSize allEventsAnywhere eventList
filteredForFeatures = foldl' filterOnRoomFeature filteredForSizes eventList
filterOnRoomSize c e = let numPeople = length . eventToPerson $ e
previousValidRooms = c M.! e
in M.insert e (filter (\r->rawRoomSizes input r >= numPeople) previousValidRooms) c
filterOnRoomFeature c e = let previousValidRooms = c M.! e
eFs = rawEventFeatureLookup input e
f r = let rFs = rawRoomFeatureLookup input r
in and $ map (\e->elem e rFs) eFs
in M.insert e (filter f previousValidRooms) c
eventToRoom = (A.!) (A.array (0 , rawNumberOfEvents input 1) (M.toList filteredForFeatures))
numEventsInDayEmpty = M.fromList [ ((d,p),0) | d<-[0 .. numDays 1],p<-[0 .. rawNumberOfPeople input 1]]
numDays = rawNumberOfDays input
numSlots = rawNumberOfSlotsPerDay input
rawToCSV :: RawTimeTableProblem->String
rawToCSV ffdttp
= concat [header,"\n\nRoom Sizes\n",roomOutput,"\nStudent Event Table\n",studentEventTable,"\nRoom Feature Table\n",roomFeatureTable,"\nEvent Feature Table\n",eventFeatureTable]
where
pList = [0..rawNumberOfPeople ffdttp 1]
rList = [0..rawNumberOfRooms ffdttp 1]
eList = [0 .. rawNumberOfEvents ffdttp 1]
fList = [0..rawNumberOfFeatures ffdttp 1]
header = concat $ (zipWith (++)) ["Number Of Events,","\nNumber Of Rooms,","\nNumber Of Features,","\nNumber Of People,","\nSlots Per Day,","\nDays,"]
(map (\f->show $ f ffdttp) [rawNumberOfEvents,rawNumberOfRooms,rawNumberOfFeatures,rawNumberOfPeople,rawNumberOfSlotsPerDay,rawNumberOfDays])
roomOutput = concatMap concat [["Room ",show r,",",show $ rawRoomSizes ffdttp r,"\n"] | r <- rList]
studentEventTable = eventHeaderRow ++ (concat ['S':(show r) ++ (indexesToBools (rawNumberOfEvents ffdttp) $ rawPersonEventLookup ffdttp r)++"\n" | r<-pList])
roomFeatureTable = featureHeaderRow ++ (concat [ 'R':(show r) ++ (indexesToBools (rawNumberOfFeatures ffdttp) $ rawRoomFeatureLookup ffdttp r)++"\n" | r<-rList])
eventFeatureTable = featureHeaderRow ++ (concat [ 'E':(show r) ++ (indexesToBools (rawNumberOfFeatures ffdttp) $ rawEventFeatureLookup ffdttp r)++"\n" | r<-eList])
eventHeaderRow = (concat [ ",E"++show x | x<-eList])++"\n"
featureHeaderRow = (concat [ ",F"++show x | x<-fList])++"\n"
indexesToBools lim xs = concat [ [',',if elem i xs then '1' else '0'] |i<-[0..lim1]]