Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: ecc5da3179
Fetching contributors…

Cannot retrieve contributors at this time

138 lines (113 sloc) 3.652 kB
{-# LANGUAGE OverloadedStrings #-}
import System.Random
import System.Environment
import Debug.Trace
import Data.List
import Control.DeepSeq
import Data.Map (Map)
import qualified Data.Map as Map
-- ----------------------------------------------------------------------------
-- <<Talk
newtype Talk = Talk Int
deriving (Eq,Ord)
instance NFData Talk
instance Show Talk where
show (Talk t) = show t
-- >>
-- <<Person
data Person = Person
{ name :: String
, talks :: [Talk]
}
deriving (Show)
-- >>
-- <<TimeTable
type TimeTable = [[Talk]]
-- >>
-- ----------------------------------------------------------------------------
-- <<timetable
timetable :: [Person] -> [Talk] -> Int -> Int -> [TimeTable]
timetable people allTalks maxTrack maxSlot =
-- >>
-- <<generate_call
generate 0 0 [] [] allTalks allTalks
-- >>
where
-- <<generate_type
generate :: Int -- current slot number
-> Int -- current track number
-> [[Talk]] -- slots allocated so far
-> [Talk] -- talks in this slot
-> [Talk] -- talks that can be allocated in this slot
-> [Talk] -- all talks remaining to be allocated
-> [TimeTable] -- all possible solutions
-- >>
-- <<generate
generate slotNo trackNo slots slot slotTalks talks
| slotNo == maxSlot = [slots] -- <1>
| trackNo == maxTrack =
generate (slotNo+1) 0 (slot:slots) [] talks talks -- <2>
| otherwise = concat -- <3>
[ generate slotNo (trackNo+1) slots (t:slot) slotTalks' talks' -- <8>
| (t, ts) <- selects slotTalks -- <4>
, let clashesWithT = Map.findWithDefault [] t clashes -- <5>
, let slotTalks' = filter (`notElem` clashesWithT) ts -- <6>
, let talks' = filter (/= t) talks -- <7>
]
-- >>
-- <<clashes
clashes :: Map Talk [Talk]
clashes = Map.fromListWith union
[ (t, ts)
| s <- people
, (t, ts) <- selects (talks s) ]
-- >>
-- ----------------------------------------------------------------------------
-- Utils
-- <<selects
selects :: [a] -> [(a,[a])]
selects xs0 = go [] xs0
where
go xs [] = []
go xs (y:ys) = (y,xs++ys) : go (y:xs) ys
-- >>
-- ----------------------------------------------------------------------------
-- Benchmarking / Testing
bench :: Int -> Int -> Int -> Int -> Int -> StdGen
-> ([Person],[Talk],[TimeTable])
bench nslots ntracks ntalks npersons c_per_s gen =
(persons,talks, timetable persons talks ntracks nslots)
where
total_talks = nslots * ntracks
talks = map Talk [1..total_talks]
persons = mkpersons npersons gen
mkpersons :: Int -> StdGen -> [Person]
mkpersons 0 g = []
mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest
where
(g1,g2) = split g
rest = mkpersons (n-1) g2
cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ]
main = do
[ a, b, c, d, e ] <- fmap (fmap read) getArgs
let g = mkStdGen 1001
let (ss,cs,ts) = bench a b c d e g
print ss
print (length ts)
-- [ a, b ] <- fmap (fmap read) getArgs
-- print (head (test2 a b))
test = timetable testPersons cs 2 2
where
cs@[c1,c2,c3,c4] = map Talk [1..4]
testPersons =
[ Person "P" [c1,c2]
, Person "Q" [c2,c3]
, Person "R" [c3,c4]
, Person "S" [c1,c4]
]
test2 n m = timetable testPersons cs m n
where
cs = map Talk [1 .. (n * m)]
testPersons =
[ Person "1" (take n cs)
]
Jump to Line
Something went wrong with that request. Please try again.