Performance 在Haskell中提高查找图直径的性能

我正在解决下面的问题，本质上是“求连通无向加权图的直径”，在Haskell中。现在，下面的解决方案生成正确答案，但超过了9/27测试的时间限制。我远非哈斯凯尔的天才，你们能告诉我，在不使用内置的

Data.Graph

模块的情况下，我是否可以以及如何提高解决方案的性能吗？我尝试在某些地方使用累加器参数、严格的对和严格的求值，但要么使用错误，要么性能问题在别处。提前谢谢

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (maximumBy)
import Data.Ord (comparing)

buildGraph :: [Int] -> Map.Map Int [(Int, Int)] -> Map.Map Int [(Int, Int)]
buildGraph [] acc                  = acc
buildGraph (from:to:dist:rest) acc = let withTo = Map.insertWith (++) from [(to, dist)] acc
                                        withFromTo = Map.insertWith (++) to [(from, dist)] withTo
                                        in buildGraph rest $ withFromTo

data Queue a = Queue {
                ingoing :: [a]
                , outgoing :: [a]
            } deriving Show

toQueue xs = Queue [] xs
enqMany xs (Queue is os) = (Queue (reverse xs ++ is) os)
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)

extract :: (Ord a) => a -> Map.Map a [b] -> [b]
extract k m = case Map.lookup k m of
                    Just value -> value
                    Nothing    -> error "sdfsd" -- should never happen

bfs node graph = bfs' Set.empty (toQueue [(node, 0)]) []
    where
        bfs' :: Set.Set Int -> Queue (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
        bfs' visited (Queue [] []) acc = acc
        bfs' visited que acc = let ((n, dist), rest) = deq que
                                    in if Set.member n visited
                                            then bfs' visited rest acc
                                            else let children = map (\(i, d) -> (i, d + dist)) $ extract n graph
                                                    newNodes = enqMany children rest
                                                    in bfs' (Set.insert n visited) newNodes ((n, dist):acc)

findMostDistant xs = maximumBy (comparing snd) xs

solve input = answer
    where
        -- the first number is the number of edges and is not necessary
        (_:triples) = map read $ words input
        graph = buildGraph triples Map.empty
        -- pick arbitary node, find the farther node from it using bfs
        (mostDistant, _) = findMostDistant $ bfs (head triples) graph
        -- find the farthest node from the previously farthest node, counting the distance on the way
        (_, answer) = findMostDistant $ bfs mostDistant graph

tests = [
            "11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
            , "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
            , "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
        ]

runZeroTests = mapM_ print $ map solve tests

main = do
    answer <- solve <$> getContents
    print answer

导入符合条件的数据。映射为映射
导入符合条件的数据。设置为集合
导入数据列表（maximumBy）
导入数据。Ord（比较）
buildGraph:：[Int]->Map.Map Int[（Int，Int）]->Map.Map Int[（Int，Int）]
buildGraph[]acc=acc
buildGraph（from:to:dist:rest）acc=let withTo=Map.insertWith（++）from[（to，dist）]acc
withFromTo=Map.insertWith（++）to[（from，dist）]withTo
在buildGraph rest$withFromTo中
数据队列a=队列{
输入：：[a]
，即将离任：：[a]
}衍生节目
toQueue xs=队列[]xs
enqMany xs（队列是os）=（队列（反向xs++is）os）
deq（队列为[]）=deq（队列为[]$反向为）
deq（队列是（o:os））=（o，队列是os）
摘录：：（Ord a）=>a->Map.Map a[b]->[b]
提取k m=案例映射。查找k m of
只是价值->价值
无->错误“sdfsd”--不应发生
bfs节点图=bfs的Set.empty（toQueue[（节点，0）]）[]
哪里
bfs'：：Set.Set Int->Queue（Int，Int）->[（Int，Int）]->[（Int，Int）]
已访问bfs（队列[]]）acc=acc
bfs的访问时间=let（（n，dist），rest）=deq que
如果访问了Set.n成员，则在中
然后bfs访问了rest acc
否则让children=map（\（i，d）->（i，d+dist））$extract n graph
newNodes=enqMany子项rest
在bfs（Set.insert n已访问）中的新节点（（n，dist）：acc）
FindMostDistance xs=maximumBy（比较snd）xs
解决输入=回答
哪里
--第一个数字是边数，不是必需的
（：三元组）=映射读取$words输入
graph=buildGraph三元组Map.empty
--拾取任意节点，使用bfs查找距离它更远的节点
（mostDistant，）=查找最远的$bfs（头三元组）图
--从以前最远的节点中查找最远的节点，计算途中的距离
（_，答案）=查找最远距离$bfs最静态图
测试=[
"11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
, "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
, "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
]
runZeroTests=mapM_uu打印$map求解测试
main=do
答案
deq（Queue[]]）
导致无限循环，我认为。
deq（Queue[]]）
导致无限循环，我认为。
当我在Haskell解决竞赛问题时，通常最大的性能障碍是缓慢的I/O库，它在宽字符的惰性线性链接列表上运行。在编程竞赛中，我总是做的第一件事就是用快速I/O替换它

这是一个对程序逻辑进行最小更改的版本，它只是用
Data.ByteString.Lazy.Char8
替换I/O，用严格字节数组的延迟计算列表实现，并用
Data.ByteString.Builder
构建一个函数来填充输出缓冲区。仅从快速I/O计算加速应该很有用

{-# LANGUAGE OverloadedStrings #-} -- Added

import Data.ByteString.Builder
  (Builder, char7, intDec, toLazyByteString) -- Added
import qualified Data.ByteString.Lazy.Char8 as B8 -- Added
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (maximumBy)
import Data.Maybe (fromJust) -- Added
import Data.Monoid ((<>)) -- Added
import Data.Ord (comparing)

buildGraph :: [Int] -> Map.Map Int [(Int, Int)] -> Map.Map Int [(Int, Int)]
buildGraph [] acc                  = acc
buildGraph (from:to:dist:rest) acc = let withTo = Map.insertWith (++) from [(to, dist)] acc
                                         withFromTo = Map.insertWith (++) to [(from, dist)] withTo
                                        in buildGraph rest $ withFromTo

data Queue a = Queue {
                ingoing :: [a]
                , outgoing :: [a]
            } deriving Show

toQueue xs = Queue [] xs
enqMany xs (Queue is os) = (Queue (reverse xs ++ is) os)
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)

extract :: (Ord a) => a -> Map.Map a [b] -> [b]
extract k m = case Map.lookup k m of
                    Just value -> value
                    Nothing    -> error "sdfsd" -- should never happen

bfs node graph = bfs' Set.empty (toQueue [(node, 0)]) []
    where
        bfs' :: Set.Set Int -> Queue (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
        bfs' visited (Queue [] []) acc = acc
        bfs' visited que acc = let ((n, dist), rest) = deq que
                                    in if Set.member n visited
                                            then bfs' visited rest acc
                                            else let children = map (\(i, d) -> (i, d + dist)) $ extract n graph
                                                     newNodes = enqMany children rest
                                                    in bfs' (Set.insert n visited) newNodes ((n, dist):acc)

findMostDistant xs = maximumBy (comparing snd) xs

solve triples = answer -- Changed (by deleting one line)
    where
        graph = buildGraph triples Map.empty
        -- pick arbitary node, find the farther node from it using bfs
        (mostDistant, _) = findMostDistant $ bfs (head triples) graph
        -- find the farthest node from the previously farthest node, counting the distance on the way
        (_, answer) = findMostDistant $ bfs mostDistant graph

tests = [ -- Unchanged, but now interpreted as OverloadedStrings
            "11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
            , "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
            , "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
        ]

runZeroTests = B8.putStr -- Changed
  . toLazyByteString
  . foldMap format
  . map (solve . parse)
  $ tests

main :: IO () -- Changed
main = B8.interact ( toLazyByteString . format . solve . parse )

parse :: B8.ByteString -> [Int] -- Added
-- the first number is the number of edges and is not necessary
parse = map (fst . fromJust . B8.readInt) . tail . B8.words

format :: Int -> Builder -- Added
format n = intDec n <> eol where
  eol = char7 '\n'

{-#语言重载字符串#-}--已添加
导入Data.ByteString.Builder
（生成器、char7、intDec、toLazyByteString）--添加
将限定数据.ByteString.Lazy.Char8作为B8导入--已添加
导入符合条件的数据。映射为映射
导入符合条件的数据。设置为集合
导入数据列表（maximumBy）
导入数据。可能（来自Just）--已添加
导入数据。Monoid（（））--已添加
导入数据。Ord（比较）
buildGraph:：[Int]->Map.Map Int[（Int，Int）]->Map.Map Int[（Int，Int）]
buildGraph[]acc=acc
buildGraph（from:to:dist:rest）acc=let withTo=Map.insertWith（++）from[（to，dist）]acc
withFromTo=Map.insertWith（++）to[（from，dist）]withTo
在buildGraph rest$withFromTo中
数据队列a=队列{
输入：：[a]
，即将离任：：[a]
}衍生节目
toQueue xs=队列[]xs
enqMany xs（队列是os）=（队列（反向xs++is）os）
deq（队列为[]）=deq（队列为[]$反向为）
deq（队列是（o:os））=（o，队列是os）
摘录：：（Ord a）=>a->Map.Map a[b]->[b]
提取k m=案例映射。查找k m of
只是价值->价值
无->错误“sdfsd”--不应发生
bfs节点图=bfs的Set.empty（toQueue[（节点，0）]）[]
哪里
bfs'：：Set.Set Int->Queue（Int，Int）->[（Int，Int）]->[（Int，Int）]
已访问bfs（队列[]]）acc=acc
bfs的访问时间=let（（n，dist），rest）=deq que
如果访问了Set.n成员，则在中
然后bfs访问了rest acc
否则让children=map（\（i，d）->（i，d+dist））$extract n graph
newNodes=enqMany子项rest
在bfs（Set.insert n已访问）中的新节点（（n，dist）：acc）
FindMostDistance xs=最大值
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

import Data.ByteString.Builder
(Builder, char7, intDec, toLazyByteString)
import qualified Data.ByteString.Lazy.Char8 as B8
import qualified Data.Set as Set
import Data.Monoid ((<>))
import Data.Char (ord)
import Data.ByteString (getLine)
import Data.Array (Array, array, accumArray, (!), (//))

buildAdjList :: Int -> [Int] -> Array Int [(Int, Int)]
buildAdjList n xs = accumArray (flip (:)) [] (0, n) $ triples xs []
    where
        triples [] res = res
        triples (x:y:dist:rest) res = let edgeXY = (x, (y, dist))
                                        edgeYX = (y, (x, dist))
                                        in triples rest (edgeXY:edgeYX:res)

data Queue a = Queue {
                ingoing :: [a]
                , outgoing :: [a]
            } deriving Show

enqMany xs (Queue is os) = Queue (reverse xs ++ is) os
deq (Queue [] []) = error "gosho"
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)

bfs !node adjList = let start = (node, 0) in bfs' Set.empty (Queue [] [start]) start
    where
        bfs' :: Set.Set Int -> Queue (Int, Int) -> (Int, Int) -> (Int, Int)
        bfs' visited (Queue [] []) !ans = ans
        bfs' visited que !ans = let (curr@(n, dist), rest) = deq que
                                    in if Set.member n visited
                                            then bfs' visited rest ans
                                            else let children = map (\(i, d) -> (i, d + dist)) $ adjList ! n
                                                    newNodes = enqMany children rest
                                                    in bfs' (Set.insert n visited) newNodes (longerEdge curr ans)

longerEdge :: (Int, Int) -> (Int, Int) -> (Int, Int)
longerEdge a b = if (snd a) < (snd b) then b else a

parseInt :: B8.ByteString -> Int
parseInt str = parseInt' str 0 where
    parseInt' str !acc
        | B8.null str  = acc
        | otherwise = parseInt' (B8.tail str) $ ((ord $ B8.head str) - 48 + acc * 10)

parseIntList :: B8.ByteString -> [Int]
parseIntList = map parseInt . B8.words

solve :: [Int] -> Int
solve (n:triples) = answer
    where
        graph = buildAdjList n triples
        -- pick arbitary node, find the farther node from it using bfs
        (mostDistant, _) = bfs (head triples) graph
        -- find the farthest node from the previously farthest node, counting the distance on the way
        (_, answer) = bfs mostDistant graph

main :: IO ()
main = B8.interact ( toLazyByteString . intDec . solve . parseIntList )

-- debug code below
tests = [
            "11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
            , "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
            , "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
        ]

runZeroTests = B8.putStr
    . toLazyByteString
    . foldMap format
    . map (solve . parseIntList)
    $ tests

format :: Int -> Builder
format n = intDec n <> eol
    where eol = char7 '\n'