元記事:組合せ最適化でグループ分け
元々記事:【日常に潜む最適化問題】受験者をなるべく均等に試験会場に割り振るアルゴリズム
が勉強になったので、Haskellでやってみたメモ。

#世の中には動的計画法というのがあって、単純に条件でフィルターするだけよりだいぶ効率がいいそうな。
でも、難しそう...
記事を読んだとき、すごいH本にあった経路探索に似てる!できるかも...と思ってしまったのが運のつき。
全然違った。めっちゃ難しいじゃん。

アルゴリズムはほぼ元々記事と同じです。
ただ、Haskellでどうやるの?というところで自分なりに工夫してみました。

#RoomVal.hs データの型と関数
部屋の値とそこに至るまでの部屋の履歴をセットにしました。
値は部屋が変わるときに固定化される部分と同じ部屋でまだ確定していない部分のペアです。
履歴は部屋の番号とグループの番号のペアのリストです。
値と履歴に関する関数を必要になるたびにここに加えていきました。

RoomVal.hs


module RoomVal (
  RoomVal(..)
  , calcRmVal
  , fixRmVal
  , addHistStay
  , addHistChange
  , addVal
  ) where
    
    data RoomVal = RoomVal{
    rmVal::(Int , Int)   --(fixed value from former histories,not fixed value for this place) 
    ,rmHist::[(Int,Int)]  -- a list of history(room, group)
    } deriving (Show)

    calcRmVal :: RoomVal -> Int
    --Returns an actual room value = (fixed) + (not fixed)^2
    --From a RoomVal
    calcRmVal aRmVal = fst x + (snd x ^ 2)
      where
        x = rmVal aRmVal

    fixRmVal :: RoomVal -> RoomVal
    --Returns fixed RoomVal
    --From a RoomVal not fixed
    fixRmVal aRmVal = aRmVal{rmVal = (calcRmVal aRmVal, 0)}

    addHistStay :: RoomVal -> RoomVal
    --Returns a RoomVal a history(to stay the same room) added
    --From a RoomVal
    addHistStay aRmVal = aRmVal{ rmHist = (fst x, succ $ snd x) : (x : xs) }
      where
        (x : xs) = rmHist aRmVal
    
    addHistChange :: RoomVal -> RoomVal
    --Returns a RoomVal a history(to change room to the next) added
    --From aRoomVal
    addHistChange aRmVal = aRmVal{ rmHist = (succ $ fst x, succ $ snd x) : (x : xs) }
      where
        (x : xs) = rmHist aRmVal

    addVal :: RoomVal -> Int ->  RoomVal
    --Returns a RoomVal a number added
    --From a RoomVal 
    --  and a number a group contains 
    addVal aRmVal aGroup  = aRmVal{ rmVal = (fst x, snd x + aGroup)} 
      where
        x = rmVal aRmVal

#MyFunc.hs 補助的な関数
計算が複雑で自分でもよくわからなくなってきたので、標準の関数に似たものを作って使いました。
minimumFは、minimumと同じですが、関数をとって関数を適用した結果でminimumを選びます。
scanwlは、scanlと同じですが、3引数の関数と初期値とリストを二つとってスキャンします。
もっと良い方法があるのでしょうが、わからなかったので。

MyFunc.hs

module MyFunc (
  scanwl
  , minimumF
  ) where

minimumF :: Ord b => (a -> b) -> [a] -> a
minimumF f [x] = x
minimumF f (x:y:xs)
  | f x < f y = minimumF f (x:xs)
  | otherwise = minimumF f (y:xs)

scanwl :: (a -> b -> c -> a) -> a -> [b] -> [c] -> [a]
scanwl f x [] _ = [x]
scanwl f x _ [] = [x]
scanwl f x (y:ys) (z:zs) = x : scanwl f (f x y z) ys zs

#Main.hs
アルゴリズムはほぼ元々記事と同じです。

部屋が変わるごとに、

その部屋に有効なグループと前の部屋の確定した値から
すべての可能な値を計算し、
その中から最適な値を選んで確定する

というのを繰り返して、

最後の部屋の最後のグループの履歴を得る、

というものです。

畳み込み部分は、リストのheadで初期値を作って、リストのtailでfoldlやscanl、scanwlを畳み込むようにしました。

Main.hs

import qualified RoomVal as RV
import qualified MyFunc as MF


planRoom :: [Int] -> Int -> [(Int,Int)]
-- Returns optimal histories
-- From numbers each group contains
--  and a number of rooms
planRoom grpsList rmsNum =
  reverse . RV.rmHist . last $ foldl fixeds (initFixeds xs) xss
    where
     (xs:xss) = validGrpss grpsList rmsNum

validGrpss ::[Int] -> Int -> [[Int]]
--Returns a list of numbers each group contains, valid for each room
--From numbers each group contains
--  and a number of rooms
validGrpss grpsList rmsNum = 
 filter (isLengthGE validLength) . map (take validLength)
  $ tails grpsList
  where
    isLengthGE n xs = length xs >= n
    validLength = length grpsList - rmsNum + 1
    tails xs = take (length xs + 1) $ iterate tail xs

fixeds :: [RV.RoomVal] -> [Int] -> [RV.RoomVal]
--Returns new fixed RoomVals
--From former fixed RoomVals
--  and numbers each group contains, valid for this room
fixeds formerFixeds groups =
  map (RV.fixRmVal . MF.minimumF RV.calcRmVal)
  $ possiblesList formerFixeds groups

possiblesList :: [RV.RoomVal] -> [Int] -> [[RV.RoomVal]]
--Returns a list of candidates for each new fixed RoomVal
--From former fixed RoomVals
--  and numbers each group contains, valid for this room
possiblesList formerFixeds@(x : xs) groups@(y : ys) =
  MF.scanwl possibles [possibleFromChange x y] xs ys

possibles :: [RV.RoomVal] -> RV.RoomVal -> Int -> [RV.RoomVal]
--Returns candidates for new fixed RoomVal
--From previous RoomVals
--  , a former fixed RoomVal
--  and a number a group contains, valid for this place
possibles prevPossibles aFormerFixed aGroup =
  possibleFromChange aFormerFixed aGroup
   : possiblesFromStay prevPossibles aGroup

possibleFromChange :: RV.RoomVal -> Int -> RV.RoomVal
--Returns a candidate for new fixed RoomVal
--From a former fixed RoomVal
--  and a number a group contains, valid for this place
possibleFromChange aRmVal aGroup =
  RV.addHistChange $ RV.addVal aRmVal aGroup

possiblesFromStay ::[RV.RoomVal] -> Int -> [RV.RoomVal]
--Returns candidates for new fixed RoomVal
--From previous RoomVals
--  and a number a group contains, valid for this place
possiblesFromStay rmVals aGroup =
  map (RV.addHistStay . flip RV.addVal aGroup) rmVals

initFixeds :: [Int] -> [RV.RoomVal]
--Returns fixed RoomVals of the first room
--From numbers each group contains, valid for the first room
initFixeds groups@(x : xs) =
  map (RV.fixRmVal . head)
  $ scanl possiblesFromStay [initPossible x]  xs
  where
    initPossible :: Int -> RV.RoomVal
    --Returns a candidate for the first fixed RoomVal of the first room
    --From a number the first group contains
    initPossible n = RV.RoomVal (0, n) [(1,1)] 

convertToIndex::String -> [(Int,Int)] -> String
--Returns a String to show
--From a String of group indexes
--  and optimal histories
convertToIndex indexes hists@(y : ys) =
  concatMap snd $ MF.scanwl insertWall (fst y, xs) xss ys
  where
    (xs:xss) = map (: []) indexes  -- String -> [String]
    
    insertWall ::(Int,String) -> String -> (Int,Int) -> (Int,String)
    --Returns new (the first of a history (=room), a String)
    --From previous (the first of a history (=room), a String)
    --  , a String
    --  and a history
    insertWall (a, _) bs (c, _ )
      | a == c    = (c, bs)
      | otherwise = ( c, " | " ++ bs)


main = putStrLn
   . convertToIndex "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  $ planRoom
  [19,10,11,17,11,17,12
  ,18,10,10,14,12,11,15
  ,15,17,14,11,18,18,11
  ,13,16,12,12,10] 6

--出力
ABCD | EFGH | IJKLM | NOPQ | RSTU | VWXYZ

入力データは元記事のものです。

~~(注：実際の出力を見易いように適宜、改行しています。)~~
~~生の履歴なので見た目がだいぶ違いますが、~~ 手計算で確認したら元記事の結果と同じでした。たぶん合っているのでしょう。

基本手続き脳の自分にはこれが精一杯でした。
おかしいよ、もっと賢い方法があるよ、というのがあればコメントおねがいします。