优化大向量的操作

Question

这是我之前关于处理5.1米边缘有向图的矢量表示的问题的后续内容.我正在尝试实现Kosaraju的图算法,因此需要按照边缘反转的深度优先搜索(DFS)的完成时间的顺序重新排列我的Vector.我的代码在小数据集上运行,但在完整数据集上无法在10分钟内返回.(我不能排除大图出现循环,但我的测试数据没有迹象表明.)

DFS需要避免重新访问节点,因此我需要某种"状态"进行搜索(目前是一个元组,我应该使用State Monad吗？).第一次搜索应该返回一个重新排序的Vector,但是我现在通过返回重新排序的Node索引列表来保持简单,这样我就可以随后一次处理Vector.

我认为问题在于dfsInner.下面的代码"记住"访问的节点更新每个节点(第三个防护)的探索字段.虽然我试图使其尾递归,但代码似乎相当快地增加了内存使用. 我是否需要强制执行某些严格性,如果是,请如何执行？(我在单个搜索搜索中使用了另一个版本,它通过查看堆栈上未开发边缘的起始节点和已完成的节点列表来检查先前的访问.这不会增长得那么快,但是没有为任何连接良好的节点返回.)

但是,它也可能是foldr',但我怎么能检测出来？

这应该是Coursera的家庭作业,但我不再确定我可以勾选荣誉代码按钮!学习更重要,所以我真的不想复制/粘贴答案.我所拥有的并不是非常优雅 - 它也有一种迫切的感觉,这是由于保持某种状态的问题所致 - 见第三后卫.我欢迎对设计模式的评论.

type NodeName = Int
type Edges    = [NodeName]
type Explored = Bool
type Stack    = [(Int, Int)]

data Node  = Node NodeName Explored Edges Edges deriving (Eq, Show)
type Graph = Vector Node

main = do
    edges <- V.fromList `fmap` getEdges "SCC.txt"
    let 
        maxIndex = fst $ V.last edges
        gr = createGraph maxIndex edges
        res = dfsOuter gr
    --return gr
    putStrLn $ show res

dfsOuter gr = 
    let tmp = V.foldr' callInner (gr,[]) gr
    in snd tmp

callInner :: Node -> (Graph, Stack) -> (Graph, Stack)
callInner (Node idx _ fwd bwd) (gr,acc) = 
    let (Node _ explored _ _) = gr V.! idx
    in case explored of
        True  -> (gr, acc)
        False ->
            let
                initialStack = map (\l -> (idx, l)) bwd
                gr' = gr V.// [(idx, Node idx True fwd bwd)]
                (gr'', newScc) = dfsInner idx initialStack (length acc) (gr', [])
            in (gr'', newScc++acc)

dfsInner :: NodeName -> Stack -> Int -> (Graph, [(Int, Int)]) -> (Graph, [(Int, Int)])
dfsInner start [] finishCounter (gr, acc) = (gr, (start, finishCounter):acc)
dfsInner start stack finishCounter (gr, acc)
    | nextStart /= start =                      -- no more places to go from this node
        dfsInner nextStart stack (finishCounter + 1) $ (gr, (start, finishCounter):acc)
    | nextExplored = 
-- nextExplored || any (\(y,_) -> y == stack0Head) stack || any (\(x,_) -> x == stack0Head) acc =
        dfsInner start (tail stack) finishCounter (gr, acc)
    | otherwise =
        dfsInner nextEnd (add2Stack++stack) finishCounter (gr V.// [(nextEnd, Node idx True nextLHS nextRHS)], acc)
--      dfsInner gr stack0Head (add2Stack++stack) finishCounter acc

    where
        (nextStart, nextEnd) = head stack
        (Node idx nextExplored nextLHS nextRHS) = gr V.! nextEnd
        add2Stack = map (\l -> (nextEnd, l)) nextRHS

Answer 1

基于@andras要点，我重写了我的代码，如下所示。我没有使用箭头函数，因为我不熟悉它们，并且我的第二次深度优先搜索在风格上与第一个搜索相同（而不是 @Andras filterM 方法）。最终结果是它的完成时间是 Andras 代码的 20%（21 秒而不是 114 秒）。

import qualified Data.Vector as V
import qualified Data.IntSet as IS
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
--import Criterion.Main

--getEdges :: String -> IO [(Int, Int)]
getEdges file = do
    lines <- (map BS.words . BS.lines) `fmap` BS.readFile file
    let 
        pairs = (map . map) (maybe (error "can't read Int") fst . BS.readInt) lines
        pairs' = [(a, b) | [a, b] <- pairs]         -- adds 9 seconds
        maxIndex = fst $ last pairs'
        graph = createGraph maxIndex pairs'
    return graph

main = do
    graph <- getEdges "SCC.txt"
    --let 
        --maxIndex = fst $ V.last edges
    let 
        fts = bwdLoop graph
        leaders = fst $ execState (fwdLoop graph fts) ([], IS.empty)
    print $ length leaders

type Connections = [Int]
data Node = Node {fwd, bwd :: Connections} deriving (Show)
type Graph = V.Vector Node

type Visited = IS.IntSet
type FinishTime = Int
type FinishTimes = [FinishTime]
type Leaders = [Int]

createGraph :: Int -> [(Int, Int)] -> Graph
createGraph maxIndex pairs = 
    let
        graph  = V.replicate (maxIndex+1) (Node [] [])
        graph' = V.accum (\(Node f b) x -> Node (x:f) b) graph  pairs
    in           V.accum (\(Node f b) x -> Node f (x:b)) graph' $ map (\(a,b) -> (b,a)) pairs

bwdLoop :: Graph -> FinishTimes
bwdLoop g = fst $ execState (mapM_ go $ reverse [0 .. V.length g - 1]) ([], IS.empty) where
    go :: Int -> State (FinishTimes, Visited) ()
    go i = do
        (fTimes, vs) <- get
        let visited = IS.member i vs
        if not visited then do
            put (fTimes, IS.insert i vs)
            mapM_ go $ bwd $ g V.! i
            -- get state again after changes from mapM_
            (fTimes', vs') <- get
            put (i : fTimes', vs')
        else return ()

fwdLoop :: Graph -> FinishTimes -> State (Leaders, Visited) ()
fwdLoop _ [] = return ()
fwdLoop g (i:fts) = do
    (ls, vs) <- get
    let visited = IS.member i vs
    if not visited then do
        put (i:ls, IS.insert i vs)
        mapM_ go $ fwd $ g V.! i
    else return ()
    fwdLoop g fts

    where
        go :: Int -> State (Leaders, Visited) ()
        go i = do
            (ls, vs) <- get
            let visited = IS.member i vs
            if not visited then do
                put (ls, IS.insert i vs)
                mapM_ go $ fwd $ g V.! i
            else return ()