2013-12-02 22:46:14 +01:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE OverlappingInstances #-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
2013-11-27 13:17:21 +01:00
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
--
|
|
|
|
-- Module : DCB
|
|
|
|
-- Copyright :
|
|
|
|
-- License : AllRightsReserved
|
|
|
|
--
|
|
|
|
-- Maintainer :
|
|
|
|
-- Stability :
|
|
|
|
-- Portability :
|
|
|
|
--
|
|
|
|
-- |
|
|
|
|
--
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
|
|
|
|
module DCB where
|
|
|
|
|
2013-11-29 20:42:03 +01:00
|
|
|
import Prelude hiding ((++))
|
|
|
|
import qualified Prelude ((++))
|
2013-11-27 23:34:22 +01:00
|
|
|
|
2013-11-29 19:09:05 +01:00
|
|
|
import Control.Monad.Par
|
2013-11-29 20:42:03 +01:00
|
|
|
import Data.Array.Repa ((:.) (..), Array, (!), (*^), (++), (+^),
|
|
|
|
(-^), (/^))
|
|
|
|
import qualified Data.Array.Repa as A
|
2013-11-29 19:09:05 +01:00
|
|
|
import Data.Array.Repa.Index
|
2013-11-29 20:34:52 +01:00
|
|
|
import Data.Either
|
2013-11-29 19:09:05 +01:00
|
|
|
import Data.Int
|
2013-12-01 16:55:32 +01:00
|
|
|
import qualified Data.Vector.Unboxed as V
|
|
|
|
import Debug.Trace
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-11-29 15:30:09 +01:00
|
|
|
type Vector r e = Array r DIM1 e
|
|
|
|
type Matrix r e = Array r DIM2 e
|
|
|
|
|
|
|
|
type Attr = Matrix A.U Double
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | Adjacency-Matrix
|
2013-12-01 19:46:19 +01:00
|
|
|
type Adj = Matrix A.U Int16
|
2013-12-01 15:29:48 +01:00
|
|
|
|
|
|
|
-- | Matrix of constraints
|
|
|
|
|
|
|
|
--TODO: Haddoc!
|
2013-12-01 19:46:19 +01:00
|
|
|
type Constraints = (Vector A.U Int16, Matrix A.U Double)
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | A vector of weights indicating how much divergence is allowed in which dimension
|
2013-11-29 15:54:36 +01:00
|
|
|
type MaxDivergence = Vector A.U Double
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | Make this special Scalar explicitly visible
|
2013-11-29 15:30:09 +01:00
|
|
|
type Density = Double
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | 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 density
|
2013-11-29 15:30:09 +01:00
|
|
|
type Graph = (Vector A.U Int, Constraints, Density)
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-12-02 22:46:14 +01:00
|
|
|
instance Ord Graph where
|
|
|
|
(nodes, _, _) `compare` (nodes', _, _) = (A.size $ A.extent nodes) `compare` (A.size $ A.extent nodes')
|
|
|
|
|
2013-12-01 16:55:32 +01:00
|
|
|
|
|
|
|
|
|
|
|
testAdj :: Adj
|
|
|
|
testAdj = A.fromListUnboxed (ix2 10 10) [0,1,1,1,0,0,1,0,0,1,{----}1,0,0,0,1,0,1,1,0,0,
|
|
|
|
1,0,0,1,0,0,0,1,0,1,{----}1,0,1,0,1,1,1,0,0,0,
|
|
|
|
0,1,0,1,0,0,1,1,0,0,{----}0,0,0,1,0,0,1,0,1,1,
|
|
|
|
1,1,0,1,1,1,0,0,1,0,{----}0,1,1,0,1,0,0,0,0,1,
|
|
|
|
0,0,0,0,0,1,1,0,0,1,{----}1,0,1,0,0,1,0,1,1,0]
|
|
|
|
testAttr :: Attr
|
2013-12-01 17:22:13 +01:00
|
|
|
testAttr = A.fromListUnboxed (ix2 10 5) [ 0.2, 1.3, -1.4, 0.3, 0.0,
|
|
|
|
-0.3, 33.0, 0.0, -2.3, 0.1,
|
|
|
|
-1.1,-12.0, 2.3, 1.1, 3.2,
|
|
|
|
0.1, 1.7, 3.1, 0.7, 2.5,
|
|
|
|
1.4, 35.1, -1.1, 1.6, 1.4,
|
|
|
|
0.5, 13.4, -0.4, 0.5, 2.3,
|
|
|
|
0.9, 13.6, 1.1, 0.1, 1.9,
|
|
|
|
1.2, 12.9, -0.5, -0.3, 3.3,
|
|
|
|
3.1, 2.4, -0.1, 0.7, 0.4,
|
|
|
|
2.6, -7.4, -0.4, 1.3, 1.2]
|
2013-12-01 16:55:32 +01:00
|
|
|
testDivergence :: MaxDivergence
|
2013-12-01 17:22:13 +01:00
|
|
|
testDivergence = A.fromListUnboxed (ix1 5) [3.0, 0.0, 300.0, 2.0, 10.0]
|
2013-12-01 16:55:32 +01:00
|
|
|
|
|
|
|
testDensity = 0.7::Density;
|
|
|
|
testReq = 3 ::Int
|
|
|
|
|
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | 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 -> Graph -> [Graph]
|
2013-11-29 15:54:36 +01:00
|
|
|
expand adj attr g = undefined -- addablePoints -> for each: addPoint -> filterLayer
|
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
--TODO: Haddoc!
|
|
|
|
--Was macht der Int?
|
2013-11-29 20:34:52 +01:00
|
|
|
preprocess :: Adj -> Attr -> Density -> MaxDivergence -> Int -> (Adj, [Graph])
|
|
|
|
preprocess adj attr d div req =
|
|
|
|
let
|
|
|
|
(Z:.nNodes:._) = A.extent adj
|
2013-12-01 16:55:32 +01:00
|
|
|
results = map (initGraph attr div req) [(i, j) | i <- [0..(nNodes-1)], j <- [(i+1)..(nNodes-1)], adj!(ix2 i j) /= 0]
|
2013-11-29 20:34:52 +01:00
|
|
|
finalGraphs = lefts results
|
2013-12-01 16:55:32 +01:00
|
|
|
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))
|
2013-11-29 20:34:52 +01:00
|
|
|
adj' = A.computeS $A.fromFunction (A.extent adj) (\sh -> if mask!sh then 0 else adj!sh)
|
|
|
|
in (adj', finalGraphs)
|
2013-11-29 19:09:05 +01:00
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | initializes a seed graph if it fulfills the constraints
|
|
|
|
-- assumption: given nodes i, j are connected
|
2013-11-29 20:34:52 +01:00
|
|
|
initGraph :: Attr -> MaxDivergence -> Int -> (Int, Int) -> Either Graph (Int, Int)
|
|
|
|
initGraph attr div req (i, j) =
|
2013-11-29 19:09:05 +01:00
|
|
|
let
|
|
|
|
constr = constraintInit attr div req i j
|
|
|
|
in case constr of
|
2013-11-29 20:34:52 +01:00
|
|
|
Nothing -> Right (i, j)
|
|
|
|
Just c -> Left $(A.computeS $A.fromFunction (ix1 2)
|
2013-11-29 19:09:05 +01:00
|
|
|
(\(Z:.i) -> if i == 0 then i else j), c, 1)
|
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | checks constraints of an initializing seed
|
2013-11-29 19:09:05 +01:00
|
|
|
constraintInit :: Attr -> MaxDivergence -> Int -> Int -> Int -> Maybe Constraints
|
|
|
|
constraintInit attr div req i j =
|
|
|
|
let
|
|
|
|
(Z:._:.nAttr) = A.extent attr
|
|
|
|
fConstr (Z:.a:.c) =
|
|
|
|
let
|
|
|
|
col = A.slice attr (A.Any:.a)
|
|
|
|
in case c of
|
|
|
|
0 -> min (attr!(ix2 i a)) (attr!(ix2 j a))
|
|
|
|
1 -> max (attr!(ix2 i a)) (attr!(ix2 j a))
|
|
|
|
constr = A.computeS $A.fromFunction (ix2 nAttr 2) fConstr
|
|
|
|
fulfill = A.zipWith (\thediv dist -> if abs dist <= thediv then 1 else 0) div
|
|
|
|
$A.foldS (-) 0 constr
|
|
|
|
nrHit = A.foldAllS (+) (0::Int) $A.map fromIntegral fulfill
|
|
|
|
in if nrHit >= req then Just (A.computeS fulfill, constr) else Nothing
|
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | removes all duplicate graphs
|
2013-11-29 15:54:36 +01:00
|
|
|
filterLayer :: Vector A.U Graph -> Vector A.U Graph
|
2013-11-29 19:09:05 +01:00
|
|
|
filterLayer gs = undefined -- TODO
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | gets a Graph and an Attribute-Matrix and yields true, if the Graph still fulfills
|
|
|
|
-- all constraints defined via the Attribute-Matrix.
|
2013-11-29 19:09:05 +01:00
|
|
|
constraint :: Attr -> MaxDivergence -> Int -> Graph -> Int -> Maybe Constraints
|
|
|
|
constraint attr div req (_, (fulfill, constr), _) newNode =
|
|
|
|
let
|
|
|
|
updateConstr :: (DIM2 -> Double) -> DIM2 -> Double
|
|
|
|
updateConstr f sh@(Z:._:.c) =
|
|
|
|
case c of
|
|
|
|
0 -> min (f sh) (attr!sh)
|
|
|
|
1 -> max (f sh) (attr!sh)
|
|
|
|
constrNew = A.computeUnboxedS $A.traverse constr id updateConstr
|
2013-12-01 19:46:19 +01:00
|
|
|
fulfillNew = A.zipWith (\i b -> if i == 1 && b then 1::Int16 else 0::Int16) fulfill
|
2013-11-29 19:09:05 +01:00
|
|
|
$A.zipWith (\thediv dist -> abs dist <= thediv) div $A.foldS (-) 0 constrNew
|
|
|
|
nrHit = A.foldAllS (+) (0::Int) $A.map fromIntegral fulfillNew
|
|
|
|
in if nrHit >= req then Just (A.computeS fulfillNew, constrNew) else Nothing
|
|
|
|
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-11-29 19:09:05 +01:00
|
|
|
updateDensity :: Adj -> Vector A.U Int -> Int -> Density -> Density
|
|
|
|
updateDensity adj nodes newNode dens =
|
|
|
|
let
|
|
|
|
neighbours = A.foldAllS (+) (0::Int)
|
|
|
|
$A.traverse nodes id (\f sh -> fromIntegral $adj!(ix2 (f sh) newNode))
|
|
|
|
(Z:.n') = A.extent nodes
|
|
|
|
n = fromIntegral n'
|
|
|
|
in (dens * (n*(n+1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n+2))
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | gets a graph and a tuple of an adjecancy-Vector with an int wich column of the
|
|
|
|
-- Adjacency-Matrix the Vector should represent to generate further Graphs
|
2013-11-29 15:54:36 +01:00
|
|
|
addPoint :: Adj -> Attr -> Density -> MaxDivergence -> Int -> Graph -> Int -> Maybe Graph
|
2013-11-29 19:09:05 +01:00
|
|
|
addPoint adj attr d div req g@(nodes, _, dens) n =
|
|
|
|
let
|
|
|
|
constr = constraint attr div req g n
|
|
|
|
densNew = updateDensity adj nodes n dens
|
|
|
|
in
|
|
|
|
case constr of
|
|
|
|
Nothing -> Nothing
|
|
|
|
(Just c) ->
|
|
|
|
case dens >= d of
|
|
|
|
True -> Just (A.computeS $nodes ++ A.fromFunction (ix1 1) (\i -> n), c, densNew)
|
|
|
|
False -> Nothing
|
2013-11-27 13:17:21 +01:00
|
|
|
|
2013-12-01 15:29:48 +01:00
|
|
|
-- | yields all valid addititons (=neighbours) to a Graph
|
2013-11-29 15:30:09 +01:00
|
|
|
addablePoints :: Adj -> Graph -> Vector A.U Int
|
2013-11-29 19:09:05 +01:00
|
|
|
addablePoints adj g = undefined --TODO
|