completed sequential project. Testdata are looking right.

This commit is contained in:
Nicole Dresselhaus 2013-12-03 15:04:52 +01:00
parent 726516cfb1
commit 9abbf0f508
2 changed files with 52 additions and 20 deletions

View File

@ -66,13 +66,15 @@ testReq = 3 ::Int
--TODO: Do we have to filter?
step :: [Graph] -> Adj -> Attr -> Density -> MaxDivergence -> Int -> [Graph]
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
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,_,_) = trace ("expanding graph "P.++ B.unpack (outputGraph [g])) 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)
@ -146,19 +148,34 @@ constraint :: Attr -> MaxDivergence -> Int -- ^ required number of consistent at
-> Graph -- ^ base graph
-> Int -- ^ node to extend base graph by
-> Maybe Constraints
constraint attr div req (_, (fulfill, constr), _) newNode =
constraint attr div req (ind, (fulfill, constr), _) newNode =
let
--TODO: UGLY hack... this has to be somewhere .. -.-
posInf = read "Infinity" :: Double
negInf = read "-Infinity" :: Double
-- convert into Vector of new Indices after appending new node-index
totalInd = A.toUnboxed $ A.computeUnboxedS $ ind ++ A.fromListUnboxed (ix1 1) [newNode]
updateConstr :: (DIM2 -> Double) -> DIM2 -> Double
updateConstr f sh@(Z:._:.c) =
updateConstr f sh@(Z:.i:.c) =
let
slice = A.slice attr (A.Any :. i)
mins = A.traverse slice id (\g sh'@(Z :. j)-> if V.any (==j) totalInd then (g sh') else posInf)
maxs = A.traverse slice id (\g sh'@(Z :. j)-> if V.any (==j) totalInd then (g sh') else negInf)
in
-- trace (show i P.++ show (A.toList slice) P.++ show c P.++ "\n " P.++ show (A.foldAllS (max) negInf $ maxs)) $
case c of
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
0 -> A.foldAllS (min) posInf mins
1 -> A.foldAllS (max) negInf maxs
_ -> error "attr wrong"
! constrNew = A.computeUnboxedS $ A.traverse constr id updateConstr
--fulfill is borked..
! 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
in if nrHit >= req then Just (A.computeS fulfillNew, constrNew) else Nothing
! nrHit = A.foldAllS (+) (0::Int) $A.map fromIntegral fulfillNew
in if nrHit >= req then Just {-$ trace ("returning const-matrix for "P.++ show (A.toList ind) P.++"\n" P.++ (B.unpack $ outputArray constrNew))-}
(A.computeS fulfillNew, constrNew) else Nothing
-- updates the density of a graph extended by a single node
updateDensity :: Adj -- ^ global adjacency matrix of all nodes
@ -176,7 +193,7 @@ updateDensity adj nodes newNode dens =
(f sh) --return connection
else
0) --never connect to nodes not extisting
neighbours = A.foldAllS (+) (0::Int) (trace (show $ A.computeUnboxedS neighbourSlice) neighbourSlice)
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
@ -185,15 +202,15 @@ updateDensity adj nodes newNode dens =
0)-}
(Z:.n') = A.extent nodes
n = fromIntegral n'
newdens = (dens * (n*(n+1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n+2))
newdens = (dens * ((n)*(n-1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n))
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"
{-+ 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)*(n+1)) / 2)) P.++"/"P.++ (show (((n)*(n+1))/(2::Double))) P.++ ") \n"
P.++ (show newNode)
P.++ " -> "
P.++ (show neighbours))
0
0-}
-- | Checks a 'Graph' expansion with a single node regarding both the attribute constraints
@ -213,9 +230,11 @@ addPoint adj attr d div req g@(nodes, _, dens) n =
in
case constr of
Nothing -> Nothing
(Just c) ->
(Just c@(ful,constr)) ->
--trace (B.unpack $ outputArray constr) $
case densNew >= d of
True -> Just (A.computeS $nodes ++ A.fromListUnboxed (ix1 1) [n], c, densNew)
True -> Just {-$ trace ("submitting graph:\n================\n " P.++ (B.unpack $ outputGraph [(A.computeS $nodes ++ A.fromListUnboxed (ix1 1) [n], c, densNew)])) -}
(A.computeS $nodes ++ A.fromListUnboxed (ix1 1) [n], c, densNew)
False -> Nothing
reduceDim :: (A.Shape sh, Integral a) => (sh :. a) -> sh

View File

@ -35,7 +35,20 @@ type Density = Double
-- column in the global adjancency-matrix, a 'Matrix' of 'Constraints' and a scalar denoting the graphs 'Density'
type Graph = (Vector A.U Int, Constraints, Density)
-- | inverse sorting on graphs.
--
-- "smallest" graph has max number of Nodes
--
-- If Nodecount is identical we prioritize the number of fulfilled Constraints
instance Ord Graph where
(nodes, _, _) `compare` (nodes', _, _) = (A.size $ A.extent nodes) `compare` (A.size $ A.extent nodes')
(nodes, (const,_), _) `compare` (nodes', (const',_), _) =
let
s1 = (A.size $ A.extent nodes')
s2 = (A.size $ A.extent nodes)
in
if s1 == s2 then
(A.sumAllS const') `compare` (A.sumAllS const)
else
s1 `compare` s2