{-# OPTIONS -cpp #-} {- warshall*.hs Finding Shortest Paths in a Graph using the Warshall algorithm and a ring topology. author: Rita Loogen, Jost Berthold Philipps-Universität Marburg based on a concurrent Clean program in \cite{CleanBook} Version for recursive ring skeleton and GpH-style ring, to use in IFL08 paper on Parallel-Haskell-on-multicore. ------------------------------------------------- -} module Main(main) where import System.Environment import Data.List -- import Eden -- import EdenRing(badRing',ring,ringRec) -- import EdiRing(edirings,ediringnames) -- import PipeRings #ifdef EAGER import StrategiesEager(parList) #else import Control.Parallel.Strategies #endif --rings = {- [seqring,badRing',ring,ringRec] ++ edirings ++ piperings -- ++ -} [gphRing] -- ring size parameter == total no. of sparks -- ringnames = {- ["seq. ring","Eden badRing'","Eden ring","Eden ringRec"] -- ++ ediringnames ++ piperingNames ++ -} ["GpH ring"] -- gph ring, simply by sparking all ring process outputs -- (granularity control by ring size) gphRing np splitIn combOut ringF input = combOut (outs `using` parList rdeepseq) where ringIns = splitIn np input (outs,rComm) = foldl' fld ([],rComm) ringIns -- fld :: ([o],[r]) -> i -> ([o],[r]) fld (outs,rIn) inp = let (out,rOut) = ringF (inp,rIn) in (out:outs, rOut) -- reference: sequential version seqring np splitIn combOut ringF input = combOut outs where ringIns = splitIn np input (outs,rComm) = foldl' fld ([],rComm) ringIns -- fld :: ([o],[r]) -> i -> ([o],[r]) fld (outs,rIn) inp = let (out,rOut) = ringF (inp,rIn) in (out:outs, rOut) type Matrix a = [[a]] dim :: Matrix a -> Int dim = length -- warshallRing' :: Int -> Matrix Int -> Matrix Int -- warshallRing' _ mat = warshallRing (mat, dim mat) -- -- -- ring size = matrix dimension -- warshallRing :: (Matrix Int,Int) -> Matrix Int -- warshallRing (mat,n) = ring (length mat) split concat rf (mat,n) -- where -- split n (mat,_) = zip (splitIntoN n mat) [1..n] -- rf (([row],k), inpleft) = ([sol],outp) -- where (sol,outp) = ring_iterate (length row) k 1 row inpleft -- ring size = parameter np wr2 :: Int -> Matrix Int -> Matrix Int --wr2 v _ mat | (v == length ringnames - 1) -- -- treat as a special case, want many more sparks! -- = wr_ gphRing (length mat) mat wr2 np mat = wr_ gphRing np mat -- wr_ :: ring skel type -> Int -> Matrix Int -> Matrix Int wr_ ring np mat = ring np split concat ringf (mat,0) -- ring type issue, 0 is dummy parameter where split :: Int -> (Matrix Int, Int) -> [ (Matrix Int, Int )] -- ring size all input [ (some rows ,no. of 1st row)] split n (mat,_) = let inputrows = splitIntoN n mat -- [[r1..rk],[r(k+1)..r(2k)]..[r(i*k)..r(dim mat)]] in zip inputrows (scanl (+) 1 (map length inputrows)) -- should be "(init (scanl (+)...)" ringf :: ((Matrix Int, Int), [[Int]] ) -> ( Matrix Int , [[Int]]) -- ((some rows,start),more rows) -> ( result rows , rows for ring) ringf ((rows,startrow), fromLeft) = create_procs (length $ head rows) startrow rows fromLeft -- -- sequential version from Clean book warshall :: Int -> Matrix Int -> Matrix Int warshall _ mat = solution where (solution, output) = create_procs (length mat) 1 mat output create_procs :: Int -> Int -> Matrix Int -> [[Int]] -> ([[Int]],[[Int]]) create_procs size k [rowN] inputleft = ([rowNsolution], output) where (rowNsolution, output) = ring_iterate size k 1 rowN inputleft create_procs size k (rowk:restmat) inputleft = (rowksolution:restsolutions, outputN) where (rowksolution, outputk) = ring_iterate size k 1 rowk inputleft (restsolutions, outputN) = create_procs size (k+1) restmat outputk ring_iterate :: Int -> Int -> Int -> [Int] -> [[Int]] -> ([Int],[[Int]]) ring_iterate size k i rowk rows | i > size = (rowk, []) --iterations_finished | i == k = (solution, rowk:restoutput) -- start_sending_this_row | otherwise = (solution, rowi:restoutput) where rowi:xs = rows (solution, restoutput) = rnf nextrowk `seq` ring_iterate size k (i+1) nextrowk xs nextrowk | i == k = rowk -- no update for own row | otherwise = updaterow rowk rowi distki distki = rowk!!(i-1) --updaterow :: updaterow [] rowi distij = [] updaterow (distjk:restrowj) (distik:restrowi) distji = min distjk (distji + distik):updaterow restrowj restrowi distji ------------------------------------------------------------------------------- usage :: String usage = "Usage:\n" ++ "\t #> warshall <..rest is ignored..>\n" main = do [size,noPe] <- fmap (map read) getArgs let res = wr2 noPe (m1 size) -- print res rnf res `seq` putStrLn "done" test6 :: Matrix Int test6 = [[ 0, 100, 100, 13, 100, 100], [100, 0, 100, 100, 4,9], [11, 100, 0, 100, 100, 100], [100, 3, 100, 0, 100, 7], [15, 5, 100, 1, 0, 100], [11, 100, 100, 14, 100, 0]] {- Adjacency Matrix Shortest Paths: - - To - - [[ 0 , 100, 100, 13, 100, 100], [[ 0,16,100,13,20,20], F [100 , 0, 100, 100, 4, 9], [19, 0,100, 5, 4, 9], r [ 11 , 100, 0, 100, 100, 100], [11,27, 0,24,31,31], o [100 , 3, 100, 0, 100, 7], [18, 3,100, 0, 7, 7], m [ 15 , 5, 100, 1, 0, 100], [15, 4,100, 1, 0, 8], [ 11 , 100, 100, 14, 100, 0]] [11,17,100,14,21, 0]] -} test3 :: [[Int]] test3 = [[0,1,100],[1,0,1],[100,1,0]] m1 size = replicate size [1..size] m2 size = listToListList size [1..size*size] mA size = if size <= 4000 then m1 size else listToListList size (concat (take 20 (repeat [1..(size*size `div` 20)]))) mB size = if size <= 4000 then m1 size else listToListList size (concat (take 20 (repeat [0,2.. ((size*size) `div` 20)-2]))) listToListList c m | length m <= c = [m] | otherwise = c1 : listToListList c resto where (c1,resto) = splitAt c m --------------------- splitIntoN :: Int -> [a] -> [[a]] splitIntoN n xs = takeIter parts xs where l = length xs parts = zipWith (+) ((replicate (l `mod` n) 1) ++ repeat 0) (replicate n (l `div` n)) takeIter :: [Int] -> [a] -> [[a]] takeIter [] [] = [] takeIter [] _ = error "elements left over" takeIter (t:ts) xs = hs : takeIter ts rest where (hs,rest) = splitAt t xs unshuffle :: Int -> [a] -> [[a]] unshuffle n xs = [takeEach n (drop i xs) | i <- [0..n-1]] where takeEach n [] = [] takeEach n (x:xs) = x : takeEach n (drop (n-1) xs) -- inverse to unshuffle shuffle :: [[a]] -> [a] shuffle = concat . transpose