diff --git a/hgraph.cabal b/hgraph.cabal index a289d57..fd12d5d 100644 --- a/hgraph.cabal +++ b/hgraph.cabal @@ -26,8 +26,10 @@ executable hgraph buildable: True hs-source-dirs: src other-modules: - DCB, - Util + Util, + DCB.DCB, + DCB.Structures, + DCB.IO ghc-options: -eventlog -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 extensions: BangPatterns, @@ -43,4 +45,8 @@ test-suite test-hgraph cpp-options: -DMAIN_FUNCTION=testMain hs-source-dirs: src ghc-options: -threaded -rtsopts -eventlog - other-modules: Util + other-modules: + Util, + DCB.Structures, + DCB.DCB, + DCB.IO diff --git a/src/DCB.hs b/src/DCB/DCB.hs similarity index 79% rename from src/DCB.hs rename to src/DCB/DCB.hs index 513c493..9f4e3d2 100644 --- a/src/DCB.hs +++ b/src/DCB/DCB.hs @@ -13,14 +13,15 @@ -- Portability : -- -- | --- ------------------------------------------------------------------------------ +--DCB.DCB--------------------------------------------------------------------------- -module DCB where +module DCB.DCB where import Util +import DCB.Structures +import DCB.IO import Prelude hiding ((++)) -import qualified Prelude ((++)) +import qualified Prelude as P ((++)) import Control.Monad.Par import Data.Array.Repa ((:.) (..), Array, (!), (*^), (++), (+^), @@ -33,36 +34,8 @@ import qualified Data.List as L import Data.Maybe import qualified Data.Vector.Unboxed as V import Debug.Trace +import qualified Data.ByteString.Char8 as B --- | a one-dimensional array -type Vector r e = Array r DIM1 e --- | a two-dimensional array -type Matrix r e = Array r DIM2 e - --- | A 'Matrix' of attribute values assigned to a graph’s nodes. --- Each row contains the corresponding node’s attribute values. -type Attr = Matrix A.U Double --- | Adjacency-Matrix -type Adj = Matrix A.U Int8 - --- | Matrix storing the extent of a 'Graph'’s constraints fulfillment. --- It stores the minimum (zeroth column) and maximum (first column) value of all --- the 'Graph'’s nodes per attribute. --- The 'Vector' stores values of @1@ if the bounds are within the allowed range --- ragarding the corresponding attribute, or @0@ if not. -type Constraints = (Vector A.U Int, Matrix A.U Double) --- | A 'Vector' of weights indicating how much divergence is allowed in which dimension. --- Each dimension represents an attribute. -type MaxDivergence = Vector A.U Double --- | A graph’s density. -type Density = Double - --- | consists of a 'Vector' denoting which columns of the 'Matrix' represents which originating --- column in the global adjancency-matrix, a 'Matrix' of 'Constraints' and a scalar denoting the graph’s 'Density' -type Graph = (Vector A.U Int, Constraints, Density) - -instance Ord Graph where - (nodes, _, _) `compare` (nodes', _, _) = (A.size $ A.extent nodes) `compare` (A.size $ A.extent nodes') @@ -93,13 +66,13 @@ testReq = 3 ::Int --TODO: Do we have to filter? step :: [Graph] -> Adj -> Attr -> Density -> MaxDivergence -> Int -> [Graph] -step gs a b c d e = filterLayer $ concat $ map (expand a b c d e ) gs +step gs@((ind,_,_):_) a b c d e = trace ("step from " P.++ show (A.extent ind) ) $ filterLayer $ concat $ map (expand a b c d e ) gs -- | calculates all possible additions to one Graph, yielding a list of valid expansions -- i.e. constraint a == Just Constraints for all returned Graphs expand :: Adj -> Attr -> Density -> MaxDivergence -> Int -> Graph -> [Graph] -expand adj attr d div req g@(ind,_,_) = catMaybes $ map +expand adj attr d div req g@(ind,_,_) = trace ("expanding graph "P.++ B.unpack (outputGraph [g])) catMaybes $ map (addPoint adj attr d div req g) (V.toList $ V.findIndices (==True) $ A.toUnboxed $ addablePoints adj g) @@ -120,7 +93,7 @@ preprocess adj attr div req = finalGraphs = lefts results mask = A.fromUnboxed (A.extent adj) $V.replicate (nNodes*nNodes) False V.// ((map (\(i,j) -> (i*nNodes + (mod j nNodes), True)) $rights results) - Prelude.++ (map (\(i,j) -> (j*nNodes + (mod i nNodes), True)) $rights results)) + P.++ (map (\(i,j) -> (j*nNodes + (mod i nNodes), True)) $rights results)) adj' = A.computeS $A.fromFunction (A.extent adj) (\sh -> if mask!sh then 0 else adj!sh) in (adj', finalGraphs) @@ -181,6 +154,7 @@ constraint attr div req (_, (fulfill, constr), _) newNode = 0 -> min (f sh) (attr!sh) 1 -> max (f sh) (attr!sh) constrNew = A.computeUnboxedS $A.traverse constr id updateConstr + --TODO: filfillNew is bogus.. fulfillNew = A.zipWith (\i b -> if i == 1 && b then 1::Int else 0::Int) fulfill $A.zipWith (\thediv dist -> abs dist <= thediv) div $A.foldS (-) 0 constrNew nrHit = A.foldAllS (+) (0::Int) $A.map fromIntegral fulfillNew @@ -194,11 +168,32 @@ updateDensity :: Adj -- ^ global adjacency matrix of all nodes -> Density -- ^ new density of expanded graph updateDensity adj nodes newNode dens = let - neighbours = A.foldAllS (+) (0::Int) - $A.traverse nodes id (\f sh -> fromIntegral $adj!(ix2 (f sh) newNode)) + neighbourSlice = A.traverse + (A.slice (A.map fromIntegral adj) (A.Any :. newNode)) -- Array + id -- same Size + (\f sh@(_ :. i) -> + if V.any (==i) (A.toUnboxed nodes) then --if connected to graph + (f sh) --return connection + else + 0) --never connect to nodes not extisting + neighbours = A.foldAllS (+) (0::Int) (trace (show $ A.computeUnboxedS neighbourSlice) neighbourSlice) + + {- A.traverse adj (reduceDim) (\f (Z :. i) -> + if not $ V.any (==i) $ A.toUnboxed nodes then + fromIntegral $adj!(ix2 i newNode) + else + 0)-} (Z:.n') = A.extent nodes n = fromIntegral n' - in (dens * (n*(n+1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n+2)) + newdens = (dens * (n*(n+1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n+2)) + in newdens + + trace ( + (show dens) P.++ " ("P.++(show (dens * (n*(n+1)) / 2)) P.++"/"P.++ (show ((n*(n+1))/(2::Double))) P.++ ") -> " + P.++ (show newdens) P.++ " ("P.++(show (newdens * ((n+2)*(n+1)) / 2)) P.++"/"P.++ (show (((n+2)*(n+1))/(2::Double))) P.++ ") \n" + P.++ (show newNode) + P.++ " -> " + P.++ (show neighbours)) + 0 -- | Checks a 'Graph' expansion with a single node regarding both the attribute constraints @@ -223,6 +218,9 @@ addPoint adj attr d div req g@(nodes, _, dens) n = True -> Just (A.computeS $nodes ++ A.fromListUnboxed (ix1 1) [n], c, densNew) False -> Nothing +reduceDim :: (A.Shape sh, Integral a) => (sh :. a) -> sh +reduceDim (a :. b) = a --A.shapeOfList $ tail $ A.listOfShape a + -- | yields all valid addititons (=neighbours) to a Graph addablePoints :: Adj -> Graph -> Vector A.U Bool addablePoints adj (ind,_,_) = A.computeS $ @@ -232,8 +230,6 @@ addablePoints adj (ind,_,_) = A.computeS $ (foldOr ind)) where - reduceDim :: (A.Shape sh, Integral a) => (sh :. a) -> sh - reduceDim (a :. b) = a --A.shapeOfList $ tail $ A.listOfShape a foldOr :: (A.Shape sh') => Vector A.U Int -> ((sh' :. Int :. Int) -> Int8) -> (sh' :. Int) -> Bool foldOr indlist lookup ind@(a :. pos) = case V.any (== pos) $ A.toUnboxed indlist of diff --git a/src/DCB/IO.hs b/src/DCB/IO.hs new file mode 100644 index 0000000..13143f7 --- /dev/null +++ b/src/DCB/IO.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module DCB.IO where + +import Control.Parallel.Strategies +import Data.Array.Repa as A hiding ((++)) +import Data.Array.Repa.Repr.Unboxed +import Data.Array.Repa.Repr.Vector +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.List as L +import qualified Data.Vector.Unboxed as V +import DCB.Structures +import Util + + + +-- | creates a default-formatted output with \",\" in between elements +-- and \"\\n\" in between dimensions +-- +-- calls '_outputArray' with preset properties +outputArray :: (Unbox a, Show a) => Array U DIM2 a -> B.ByteString +outputArray a = _outputArray a "\t" "\n" + +-- | creates a formatted output from a DIM2 repa-Array +-- +-- * First String is the between-element-separator +-- +-- * Second String is the between-dimensions-separator +_outputArray :: (Unbox a, Show a) => Array U DIM2 a -> String -> String -> B.ByteString +_outputArray a itt lt = B.concat $ + (B.pack $ "Matrix "++(show $ listOfShape $ extent a)++ "\n") + : (L.map B.pack (_outputArray' (extent a) a itt lt)) + where + _outputArray' :: (Unbox a, Show a) => DIM2 -> Array U DIM2 a -> String -> String -> [String] + _outputArray' shape@(Z :. si :. sj) a itt lt = [(_outputArray'' shape i 0 a itt) ++ lt | i <- [0..(si - 1)]] + + _outputArray'' :: (Unbox a, Show a) => DIM2 -> Int -> Int -> Array U DIM2 a -> String -> String + _outputArray'' shape@(Z :. si :. sj) i j a itt + | sj-1 == j = show (a!(ix2 i j)) -- no "," for last one.. + | otherwise = show (a!(ix2 i j)) ++ itt ++ (_outputArray'' shape i (j+1) a itt) + +outputGraph :: [Graph] -> B.ByteString +outputGraph gs = B.concat $ L.map (flipto3 _outputGraph "," "\n") (L.sort gs) + +|| (parBuffer 25 rseq) --run parallel + +_outputGraph :: Graph -> String -> String -> B.ByteString +_outputGraph (indices, (constdim, constmat), dens) itt lt = + let + plt = B.pack lt + pitt = B.pack itt + in + B.concat $ + [ + (B.pack $ "Density: " ++ lt ++ show dens), + plt, + (B.pack $ "Indices used:" ++ lt ++ V.foldl (appendS itt) "" (toUnboxed indices)), + plt, + (B.pack $ "Attribute-Dimensions satisfied:" ++ lt ++ V.foldl (appendS itt) "" (toUnboxed constdim)), + plt, + outputArray $ computeS $ transpose constmat, + plt, + plt + ] + diff --git a/src/DCB/Structures.hs b/src/DCB/Structures.hs new file mode 100644 index 0000000..e9ae9e1 --- /dev/null +++ b/src/DCB/Structures.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module DCB.Structures where + +import Data.Array.Repa as A hiding ((++)) +import Data.Int +import Util + + +-- | a one-dimensional array +type Vector r e = Array r DIM1 e +-- | a two-dimensional array +type Matrix r e = Array r DIM2 e + +-- | A 'Matrix' of attribute values assigned to a graph’s nodes. +-- Each row contains the corresponding node’s attribute values. +type Attr = Matrix A.U Double +-- | Adjacency-Matrix +type Adj = Matrix A.U Int8 + +-- | Matrix storing the extent of a 'Graph'’s constraints fulfillment. +-- It stores the minimum (zeroth column) and maximum (first column) value of all +-- the 'Graph'’s nodes per attribute. +-- The 'Vector' stores values of @1@ if the bounds are within the allowed range +-- ragarding the corresponding attribute, or @0@ if not. +type Constraints = (Vector A.U Int, Matrix A.U Double) +-- | A 'Vector' of weights indicating how much divergence is allowed in which dimension. +-- Each dimension represents an attribute. +type MaxDivergence = Vector A.U Double +-- | A graph’s density. +type Density = Double + +-- | consists of a 'Vector' denoting which columns of the 'Matrix' represents which originating +-- column in the global adjancency-matrix, a 'Matrix' of 'Constraints' and a scalar denoting the graph’s 'Density' +type Graph = (Vector A.U Int, Constraints, Density) + +instance Ord Graph where + (nodes, _, _) `compare` (nodes', _, _) = (A.size $ A.extent nodes) `compare` (A.size $ A.extent nodes') + + diff --git a/src/Main.hs b/src/Main.hs index e9728ef..122bd48 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,9 +17,10 @@ -- ----------------------------------------------------------------------------- -module Main where +module DCB.DCBn where -import DCB +import DCB.DCB +import DCB.IO import Util import Control.DeepSeq @@ -118,7 +119,7 @@ emptyLine a --doCalculation :: Matrix Int -> B.ByteString doCalculation adj attr = let - dens = 0.7 + dens = 0.75 omega = (A.fromListUnboxed (ix1 3) [0.5,0.5,0.5]) delta = 2 (adj_, graph_) = preprocess adj attr {--0.8--} omega delta @@ -126,9 +127,9 @@ doCalculation adj attr = B.concat $ [ outputArray $ trace ("After: "++ show (sumAllS adj_)++"\n") adj_, - outputGraph $ L.sort $ doAll graph_ adj attr dens omega delta, - outputGraph $ L.sort $ (step graph_ adj attr dens omega delta) ++ - (step (step graph_ adj attr dens omega delta) adj attr dens omega delta) + outputGraph $ L.sort $ doAll graph_ adj_ attr dens omega delta +-- outputGraph $ L.sort $ (step graph_ adj attr dens omega delta) +-- ++ (step (step graph_ adj attr dens omega delta) adj attr dens omega delta) ] where doAll [] _ _ _ _ _ = [] @@ -136,57 +137,6 @@ doCalculation adj attr = doAll' [] _ _ _ _ _ = [] doAll' gs a b c d e = gs ++ doAll' (step gs a b c d e) a b c d e --- | creates a default-formatted output with \",\" in between elements --- and \"\\n\" in between dimensions --- --- calls '_outputArray' with preset properties -outputArray :: (Unbox a, Show a) => Array U DIM2 a -> B.ByteString -outputArray a = _outputArray a "\t" "\n" - --- | creates a formatted output from a DIM2 repa-Array --- --- * First String is the between-element-separator --- --- * Second String is the between-dimensions-separator -_outputArray :: (Unbox a, Show a) => Array U DIM2 a -> String -> String -> B.ByteString -_outputArray a itt lt = B.concat $ - (B.pack $ "Matrix "++(show $ listOfShape $ extent a)++ "\n") - : (L.map B.pack (_outputArray' (extent a) a itt lt)) - where - _outputArray' :: (Unbox a, Show a) => DIM2 -> Array U DIM2 a -> String -> String -> [String] - _outputArray' shape@(Z :. si :. sj) a itt lt = [(_outputArray'' shape i 0 a itt) ++ lt | i <- [0..(si - 1)]] - - _outputArray'' :: (Unbox a, Show a) => DIM2 -> Int -> Int -> Array U DIM2 a -> String -> String - _outputArray'' shape@(Z :. si :. sj) i j a itt - | sj-1 == j = show (a!(ix2 i j)) -- no "," for last one.. - | otherwise = show (a!(ix2 i j)) ++ itt ++ (_outputArray'' shape i (j+1) a itt) - -outputGraph :: [Graph] -> B.ByteString -outputGraph gs = B.concat $ L.map (flipto3 _outputGraph "," "\n") (L.sort gs) - +|| (parBuffer 25 rseq) --run parallel - -_outputGraph :: Graph -> String -> String -> B.ByteString -_outputGraph (indices, (constdim, constmat), dens) itt lt = - let - plt = B.pack lt - pitt = B.pack itt - in - B.concat $ - [ - (B.pack $ "Density: " ++ lt ++ show dens), - plt, - (B.pack $ "Indices used:" ++ lt ++ V.foldl (appendS itt) "" (toUnboxed indices)), - plt, - (B.pack $ "Attribute-Dimensions satisfied:" ++ lt ++ V.foldl (appendS itt) "" (toUnboxed constdim)), - plt, - outputArray $ computeS $ transpose constmat, - plt, - plt - ] - -appendS :: (Show a) => String -> String -> a -> String -appendS sep a b = (a ++ show b) ++ sep - -- | gets the length of the Left a. -- -- 0 if Left a empty or no valid constructor. @@ -212,13 +162,6 @@ showHelp = do "\n" exitSuccess -infixl 1 +|| - --- | short for a `using` b. We don't need brackets this way and are able to comment out parallelism. -(+||) :: a -> Strategy a -> a -a +|| b = a `using` b - - -- | checks if the submitted Text is empty. If not it will be printed out and the program aborts checkError :: T.Text -> IO () checkError a diff --git a/src/Util.hs b/src/Util.hs index a2c5879..486c6a4 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,5 +1,7 @@ module Util where +import Control.Parallel.Strategies + -- | Move first argument to first place (for style uniformity) flip1 :: (a -> b) -> (a -> b) flip1 = id @@ -72,3 +74,13 @@ flipto8 fun b c d e f g h a = fun a b c d e f g h -- | Move first argument to last (ninth) place flipto9 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> b -> c -> d -> e -> f -> g -> h -> i -> a -> j flipto9 fun b c d e f g h i a = fun a b c d e f g h i + +infixl 1 +|| + +-- | short for a `using` b. We don't need brackets this way and are able to comment out parallelism. +(+||) :: a -> Strategy a -> a +a +|| b = a `using` b + +appendS :: (Show a) => String -> String -> a -> String +appendS sep a b = (a ++ show b) ++ sep +