Improve performance of finding graph diameter in Haskell - performance

Question

I'm solving the following problem, which in essence is "find the diameter of a connected undirected weighted graph", in Haskell. Now, the solution below produces correct answers, but exceeds the time limit on 9/27 of the tests. I'm far from a Haskell prodigy, can you guys give me a clue whether and how I can improve the performance of my solution without using the builtin Data.Graph module? I tried using accumulator parameters, strict pairs and strict evaluation in some places, but either I used them incorrectly or the performance issue is elsewhere. Thanks in advance!
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

Answer 1

deq (Queue [] []) causes an infinite loop, I think.

Answer 2

When I’ve solved contest problems in Haskell, typically the biggest performance hog has been the slow I/O library, which operates on lazy linear linked lists of wide characters. The first thing I always do for a programming contest is replace that with fast I/O,
Here’s a version that makes minimal changes to the program logic and just replaces the I/O with Data.ByteString.Lazy.Char8, implemented with a lazily-evaluated list of strict byte arrays, and Data.ByteString.Builder, which builds a function to fill an output buffer. It should be useful to calculate the speed-up from fast I/O alone.
{-# 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'

Answer 3

With help from #Davislor with doing IO using ByteString and a few other things I managed to get 100 points on the problem. In the end, what I did to optimize it was:
Using ByteString IO as #Davislor suggested
Since I knew integers in the input were valid, I wrote my own parseInt function that does not perform unnecessary checks.
Instead of lazy Map, I used Array to create an adjacency list. I do not know what the asymptotic complexity of constructing an Array using accumArray is (I believe it should be O(n)), but lookup in the array should be O(1), instead of the O(log n) for the Map.
Here is the final solution:
{-# 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'
There could still be room for improvement, the Set for visited nodes could be changed to a bit array, Int32 can be used instead of Int, BangPatterns could be applied, although I feel like I can't really make sense of the execution order of Haskell programs.