-- |
-- Module      :  FileFormat.TIM
-- Copyright   :  (c) Richard Senington 2011
-- License     :  GPL-style
-- Maintainer  :  Richard Senington <sc06r2s@leeds.ac.uk>
-- Stability   :  provisional
-- Portability :  portable
-- The loading routines for the TIM file format. 
-- I am not sure what (if anything) TIM stands for.
-- The format has been used by the |International Timetabling Competition|
-- which has been run twice so far (2002,2007). Problems in this format can be found on 
-- their websites. 

module FileFormat.TIM ( RawTimeTableProblem(RawTimeTableProblem,rawNumberOfEvents,rawNumberOfRooms,

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

{-| This is intended to be an internal format only, though I will provide access and visibility to it so that 
    it can be inspected by other programs. In practice I do not expect users to operate upon the raw problem, 
    but instead upon TimeTable.-}

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]

{-| Helper function that will not be exported. -}
readHeader :: Parser (Int,Int,Int,Int)
readHeader = do [a,b,c,d] <-replicateM 4 readNum
                return (a,b,c,d)

{-| Helper function that will not be exported. -}
readNum :: Parser Int
readNum = do as<-many digit;spaces;return $ read as

{-| Helper function that will not be exported. -}
chunkStream :: Int->[a]->[[a]]
chunkStream i [] = []
chunkStream i xs = let (as,bs) = splitAt i xs in as : chunkStream i bs

{-| Helper function not for export. -}

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))
    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 is a file parser for the /tim/ format. For the output format, the FullyDescriptiveTimeTableProblem data type, 
    I have included a number of slots per day and number of days. These are constants in this loading routine. 

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)
    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
{-| Load in a TIM file, but keep the data in the original form, as a large number of grids of bits.-}

loadTIMFileRaw :: String->IO RawTimeTableProblem
loadTIMFileRaw fName = do rawContents<-readFile fName
                          let k = parse parseFile "" rawContents
                          let (Right x) = k 
                          return x

{-| Load a TIM file, and transform it into the constrained data format so that the look up tables no longer give back just ones and zeros, 
    but lists of valid options. This should be easier to work with. -}
loadTIMFile :: String->IO TimeTable
loadTIMFile s = (loadTIMFileRaw s) >>= (return . convertToConstrainedProblem)

{-| Use the raw data to constrain problem. Only rooms that can reasonably be chosen (feature and size constraints) should be available for specific events and so on. 
    In short I am doing my own constraint (hard coded urg) processing here. -}

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
              (numDays-1) (numSlots-1) 0 (\x->x `div` numSlots) (\x->x `mod` numSlots) numEventsInDayEmpty 0 0 0                                     
    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) -- initially any event can go anywhere
    filteredForSizes = foldl' filterOnRoomSize allEventsAnywhere eventList -- filter rooms, based upon event size/room size correlation
    filteredForFeatures = foldl' filterOnRoomFeature filteredForSizes eventList -- filter rooms, based upon event feature/room feature corelation

    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

{-| This is for human readability. It will take a raw format and return a comma and new line separated format as a String. Dump the string to a file
    and it should now be easy to load into a spread sheet and inspect. I was not comfortable incoding this as a |show| function, it seems to me that there
    is far too much information here to easily display it to a user, at least in a terminal window. -}

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]
    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..lim-1]]