schools.hs

module Schools where

import Data.List (elemIndex)

{-
Problem:

- for every chilld rank all schools
- for every school, rank every child
- specify capacity of every school (Pupil Allocation Number)

proposed alg:

- only consider the first choice
can I put them there? yes: allocate; no: put at bottom of the list
iterate while first choices are available; then move to second choices etc.
-}

type Student = String

data Offer = Offer { offStudent :: Student
                   , offSchool :: Int
                   }
           deriving (Show, Eq, Ord)

data School = School { schPan :: Int
                     , schPriority :: [Student]
                     }
            deriving (Show, Eq, Ord)

data Pref = Pref { prefStudent :: Student
                 , prefChoices :: [Int]
                 }
          deriving (Show, Eq, Ord)

schools :: [School]
schools = [ School 2 ["A", "B", "D", "C"]
          , School 2 ["B", "D", "A", "C"]
          ]

prefs :: [Pref]
prefs = [ Pref "A" [0, 1]
        , Pref "B" [1, 0]
        , Pref "C" [1, 0]
        , Pref "D" [0, 1]
        ]

allocate :: [School] -> [Pref] -> [Offer]
allocate schools prefs = allocate' schools prefs 0 []

allocate' :: [School] -> [Pref] -> Int -> [Offer] -> [Offer]
allocate' schools prefs idleTurns offers
  | prefs == []              = offers
  | idleTurns > length prefs = allocate' schools (map dropFirstChoice prefs) 0 offers
  | otherwise                = allocate'' schools prefs idleTurns offers

allocate'' :: [School] -> [Pref] -> Int -> [Offer] -> [Offer]
allocate'' schools (p:ps) idleTurns offers =
  if placeAvailable (schools !! schoolIdx) student then 
    allocate' (increaseOthers schools schoolIdx) ps 0 $ (Offer student schoolIdx):offers 
  else 
    allocate' schools (ps++[p]) (idleTurns + 1) offers
  where
    schoolIdx = firstChoice p
    student = prefStudent p

firstChoice :: Pref -> Int
firstChoice (Pref _ (c:_)) = c

placeAvailable :: School -> Student -> Bool
placeAvailable school student = case elemIndex student (schPriority school) of
  Just i  -> i <= (schPan school)
  Nothing -> False

dropFirstChoice :: Pref -> Pref
dropFirstChoice (Pref s (_:cs)) = Pref s cs

increaseOthers :: [School] -> Int -> [School]
increaseOthers schools i = map (increaseIfNot i) $ zip [0..] schools

increaseIfNot :: Int -> (Int, School) -> School 
increaseIfNot i (j, s@(School pan pris))
  | i == j    = s
  | otherwise = School (pan + 1) pris