Haskellで組合せ最適化(メモ)
SQLで作成したコードに対応するHaskellコードを作成した
あまり、カッコ良く書けていないですが。。。
■巡回セールスマン全探索
import Data.List (maximumBy,minimumBy,permutations) import Data.Function (on) -- エッジのデータ型 data Edge = Edge { path :: [Int], name :: String, cost :: Integer } deriving (Show) -- 入力データ nodes = zip [1..] ["Zurich", "London", "Berlin", "Roma", "Madrid"] edges = [(Edge [1, 2] "Zurich,London" 476) ,(Edge [2, 3] "London,Berlin" 569) ,(Edge [3, 1] "Berlin,Zurich" 408) ,(Edge [4, 3] "Roma,Berlin" 736) ,(Edge [4, 1] "Roma,Zurich" 434) ,(Edge [4, 2] "Roma,London" 894) ,(Edge [5, 4] "Madrid,Roma" 852) ,(Edge [5, 1] "Madrid,Zurich" 774) ,(Edge [5, 2] "Madrid,London" 786) ,(Edge [5, 3] "Madrid,Berlin" 1154)] -- 最大・最小 -- minRoot len or maxRoot len -- minRoot (length nodes) => ([1,3,2,5,4,1],3049) -- maxRoot (length nodes) => ([1,5,3,4,2,1],4034) minRoot n = minimumBy (compare `on` snd) (costRoots (enumRoots [1..n])) maxRoot n = maximumBy (compare `on` snd) (costRoots (enumRoots [1..n])) -- ルート列挙 -- enumRoots [1,2,3] => [[1,2,3,1],[1,3,2,1]] -- enumRoots [1,2,3,4] => [[1,2,3,4,1],[1,3,2,4,1],[1,3,4,2,1],[1,2,4,3,1],[1,4,2,3,1],[1,4,3,2,1]] enumRoots (x:xs) = map (\ys -> x:ys ++ [x]) (permutations xs) -- ラベル付きコスト算出を展開 -- costRoots [[1,2,3,4,1],[1,2,4,3,1]] => [([1,2,3,4,1],2215),([1,2,4,3,1],2514)] costRoots roots = map costRoot roots -- ルート(例:[1,2,3,4,1])のラベル付きコスト算出 -- costRoot [1,2,3,4,1] => ([1,2,3,4,1],2215) costRoot rt = (rt, sumRoot rt) -- アトム化したルート(例:[[1,2],[2,3][3,4][4,1]])のコスト算出 -- sumRoot [1,2,3,4,1] => 2215 sumRoot rt = foldl (\acc pt -> acc + (atomCost pt)) 0 (atomRoot rt) --パス(例:[2,3])のコスト算出 -- atomCost [2,3] => 569 atomCost pt = cost (findEdge pt) -- パスからエッジを取得 -- formalPath [3, 2] => [2, 3] -- formalPath [2, 3] => [2, 3] -- findEdge [2,3] => Edge {path = [2,3], name = "London,Berlin", cost = 569} formalPath [a, b] = if a < b then [a, b] else [b, a] findEdge pt = head (filter (\e -> formalPath (path e) == formalPath pt) edges) -- ルート(例:[1,2,3,1])をパス(例:[1,2])に分解 -- atomRoot [1,2,3,1] => [[1,2],[2,3],[3,1]] atomRoot (a:b:as) = [a,b] : atomRoot (b:as) atomRoot as = []