/usr/lib/hugs/packages/fgl/Data/Graph/Inductive/Monad/IOArray.hs is in libhugs-fgl-bundled 98.200609.21-5.3ubuntu1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | -- (c) 2002 by Martin Erwig [see file COPYRIGHT]
-- | Static IOArray-based Graphs
module Data.Graph.Inductive.Monad.IOArray(
-- * Graph Representation
SGr(..), GraphRep, Context', USGr,
defaultGraphSize, emptyN,
-- * Utilities
removeDel,
) where
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Monad
import Control.Monad
import Data.Array
import Data.Array.IO
import System.IO.Unsafe
import Data.Maybe
----------------------------------------------------------------------
-- GRAPH REPRESENTATION
----------------------------------------------------------------------
data SGr a b = SGr (GraphRep a b)
type GraphRep a b = (Int,Array Node (Context' a b),IOArray Node Bool)
type Context' a b = Maybe (Adj b,a,Adj b)
type USGr = SGr () ()
----------------------------------------------------------------------
-- CLASS INSTANCES
----------------------------------------------------------------------
-- Show
--
showGraph :: (Show a,Show b) => GraphRep a b -> String
showGraph (_,a,m) = concatMap showAdj (indices a)
where showAdj v | unsafePerformIO (readArray m v) = ""
| otherwise = case a!v of
Nothing -> ""
Just (_,l,s) -> '\n':show v++":"++show l++"->"++show s'
where s' = unsafePerformIO (removeDel m s)
instance (Show a,Show b) => Show (SGr a b) where
show (SGr g) = showGraph g
instance (Show a,Show b) => Show (IO (SGr a b)) where
show g = unsafePerformIO (do {(SGr g') <- g; return (showGraph g')})
{-
run :: Show (IO a) => IO a -> IO ()
run x = seq x (print x)
-}
-- GraphM
--
instance GraphM IO SGr where
emptyM = emptyN defaultGraphSize
isEmptyM g = do {SGr (n,_,_) <- g; return (n==0)}
matchM v g = do g'@(SGr (n,a,m)) <- g
case a!v of
Nothing -> return (Nothing,g')
Just (pr,l,su) ->
do b <- readArray m v
if b then return (Nothing,g') else
do s <- removeDel m su
p' <- removeDel m pr
let p = filter ((/=v).snd) p'
writeArray m v True
return (Just (p,v,l,s),SGr (n-1,a,m))
mkGraphM vs es = do m <- newArray (1,n) False
return (SGr (n,pr,m))
where nod = array bnds (map (\(v,l)->(v,Just ([],l,[]))) vs)
su = accum addSuc nod (map (\(v,w,l)->(v,(l,w))) es)
pr = accum addPre su (map (\(v,w,l)->(w,(l,v))) es)
bnds = (minimum vs',maximum vs')
vs' = map fst vs
n = length vs
addSuc (Just (p,l',s)) (l,w) = Just (p,l',(l,w):s)
addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"
addPre (Just (p,l',s)) (l,w) = Just ((l,w):p,l',s)
addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"
labNodesM g = do (SGr (_,a,m)) <- g
let getLNode vs (_,Nothing) = return vs
getLNode vs (v,Just (_,l,_)) =
do b <- readArray m v
return (if b then vs else (v,l):vs)
foldM getLNode [] (assocs a)
defaultGraphSize :: Int
defaultGraphSize = 100
emptyN :: Int -> IO (SGr a b)
emptyN n = do m <- newArray (1,n) False
return (SGr (0,array (1,n) [(i,Nothing) | i <- [1..n]],m))
----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------
-- | filter list (of successors\/predecessors) through a boolean ST array
-- representing deleted marks
removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})
|