module Persistence.SimplicialComplex (
Simplex
, SimplicialComplex
, Graph
, sc2String
, getDim
, encodeWeightedGraph
, wGraph2sc
, makeNbrhdGraph
, makeNbrhdGraphPar
, makeCliqueComplex
, makeCliqueComplexPar
, makeRipsComplexFast
, makeRipsComplexFastPar
, makeRipsComplexLight
, makeRipsComplexLightPar
, bettiNumbers
, bettiNumbersPar
) where
import Persistence.Util
import Persistence.Matrix
import Data.List as L
import Data.Vector as V
import Data.IntSet as S
import Control.Parallel.Strategies
import Data.Algorithm.MaximalCliques
type Simplex = (Vector Int, Vector Int)
type SimplicialComplex = (Int, Vector (Vector Simplex))
type Graph a = Vector (Vector (a, Bool))
sc2String :: SimplicialComplex -> String
sc2String (v, allSimplices) =
if V.null allSimplices then (show v) L.++ " vertices"
else
let edges = V.head allSimplices
simplices = V.tail allSimplices
showSimplex s =
'\n':(intercalate "\n" $ V.toList $ V.map show s)
showAll sc =
if V.null sc then '\n':(show v) L.++ " vertices"
else showSimplex (V.head sc) L.++ ('\n':(showAll (V.tail sc)))
in (intercalate "\n" $ V.toList $ V.map (show . fst) edges) L.++ ('\n':(showAll simplices))
getDim :: SimplicialComplex -> Int
getDim = L.length . snd
encodeWeightedGraph :: Int -> (Int -> Int -> (a, Bool)) -> Graph a
encodeWeightedGraph numVerts edge =
mapWithIndex (\i r -> mapWithIndex (\j _ -> edge i j) r) $ V.replicate numVerts (V.replicate numVerts ())
wGraph2sc :: Graph a -> SimplicialComplex
wGraph2sc graph =
let numVerts = V.length graph
getEdges index result =
if index == numVerts then result
else
V.map (\(i, b) ->
(V.fromList [index, i], V.empty)) $ V.filter snd
$ mapWithIndex (\i (_, b) -> (i, b)) $ V.take (numVerts - index) $ graph ! index
in (numVerts, (getEdges 0 V.empty) `cons` V.empty)
makeNbrhdGraph :: (Ord a, Eq b) => a -> (b -> b -> a) -> Either (Vector b) [b] -> Graph a
makeNbrhdGraph scale metric dataSet =
let vector = case dataSet of Left v -> v; Right l -> V.fromList l
in V.map (\x -> V.map (\y -> let d = metric x y in (d, d <= scale)) vector) vector
makeNbrhdGraphPar :: (Ord a, Eq b) => a -> (b -> b -> a) -> Either (Vector b) [b] -> Graph a
makeNbrhdGraphPar scale metric dataSet =
let vector = case dataSet of Left v -> v; Right l -> V.fromList l
in parMapVec (\x -> V.map (\y -> let d = metric x y in (d, d <= scale)) vector) vector
makeCliqueComplex :: Graph a -> SimplicialComplex
makeCliqueComplex graph =
let numVerts = V.length graph
organizeCliques 1 _ = []
organizeCliques i cliques =
let helper = V.partition (\simplex -> i == V.length simplex) cliques
in (fst helper):(organizeCliques (i - 1) $ snd helper)
makePair simplices =
case simplices of
(x:_) ->
let dim = V.length x
in (dim, organizeCliques dim $ V.fromList simplices)
[] -> (1, [])
maxCliques :: (Int, Vector (Vector (Vector Int)))
maxCliques =
(\(x, y) -> (x, V.fromList y)) $ makePair
$ sortVecs $ L.map V.fromList $ L.filter (\c -> L.length c > 1)
$ getMaximalCliques (\i j -> snd $ graph ! i ! j) [0..numVerts - 1]
combos :: Int
-> Int
-> Vector (Vector (Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
combos i max sc result =
if i == max then
(V.map (\s -> (s, V.empty)) $ V.last sc) `cons` result
else
let i1 = i + 1
current = sc ! i
next = sc ! i1
len = V.length next
allCombos = V.map getCombos current
uCombos = bigU allCombos
indices = V.map (V.map (\face -> len + (elemIndexUnsafe face uCombos))) allCombos
in combos i1 max (replaceElem i1 (next V.++ uCombos) sc)
$ (V.zip current indices) `cons` result
fstmc2 = fst maxCliques - 2
in
if fstmc2 == (-1) then (numVerts, V.empty)
else
let sc = combos 0 fstmc2 (snd maxCliques) V.empty
in (numVerts, sc)
makeCliqueComplexPar :: Graph a -> SimplicialComplex
makeCliqueComplexPar graph =
let numVerts = V.length graph
organizeCliques 1 _ = []
organizeCliques i cliques =
let helper = V.partition (\simplex -> i == V.length simplex) cliques
in (fst helper):(organizeCliques (i - 1) $ snd helper)
makePair simplices =
case simplices of
(x:_) ->
let dim = V.length x
in (dim, organizeCliques dim $ V.fromList simplices)
[] -> (1, [])
maxCliques :: (Int, Vector (Vector (Vector Int)))
maxCliques =
(\(x, y) -> (x, V.fromList y)) $ makePair
$ sortVecs $ L.map V.fromList $ L.filter (\c -> L.length c > 1)
$ getMaximalCliques (\i j -> snd $ graph ! i ! j) [0..numVerts - 1]
combos :: Int
-> Int
-> Vector (Vector (Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
combos i max sc result =
if i == max then
(V.map (\s -> (s, V.empty)) $ V.last sc) `cons` result
else
let i1 = i + 1
current = sc ! i
next = sc ! i1
len = V.length next
allCombos = V.map getCombos current
uCombos = bigU allCombos
indices =
parMapVec (V.map (\face -> len + (elemIndexUnsafe face uCombos))) allCombos
in combos i1 max (replaceElem i1 (next V.++ uCombos) sc)
$ (V.zip current indices) `cons` result
fstmc2 = fst maxCliques - 2
in
if fstmc2 == (-1) then (numVerts, V.empty)
else
let sc = combos 0 fstmc2 (snd maxCliques) V.empty
in (numVerts, sc)
makeRipsComplexFast :: (Ord a, Eq b)
=> a
-> (b -> b -> a)
-> Either (Vector b) [b]
-> (SimplicialComplex, Graph a)
makeRipsComplexFast scale metric dataSet =
let graph = makeNbrhdGraph scale metric dataSet
sc = makeCliqueComplex graph
in (sc, graph)
makeRipsComplexFastPar :: (Ord a, Eq b)
=> a
-> (b -> b -> a)
-> Either (Vector b) [b]
-> (SimplicialComplex, Graph a)
makeRipsComplexFastPar scale metric dataSet =
let graph = makeNbrhdGraphPar scale metric dataSet
sc = makeCliqueComplexPar graph
in (sc, graph)
makeRipsComplexLight :: (Ord a, Eq b)
=> a
-> (b -> b -> a)
-> Either (Vector b) [b]
-> SimplicialComplex
makeRipsComplexLight scale metric dataSet =
let vector = case dataSet of Left v -> v; Right l -> V.fromList l
numVerts = L.length vector
organizeCliques 1 _ = []
organizeCliques i cliques =
let helper = V.partition (\simplex -> i == V.length simplex) cliques
in (fst helper):(organizeCliques (i - 1) $ snd helper)
makePair simplices =
case simplices of
(x:_) ->
let dim = V.length x
in (dim, organizeCliques dim $ V.fromList simplices)
[] -> (1, [])
maxCliques :: (Int, Vector (Vector (Vector Int)))
maxCliques =
(\(x, y) -> (x, V.fromList y)) $ makePair $ sortVecs
$ L.map V.fromList $ L.filter (\c -> L.length c > 1)
$ getMaximalCliques (\i j -> metric (vector ! i) (vector ! j) <= scale) [0..numVerts-1]
combos :: Int
-> Int
-> Vector (Vector (Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
combos i max sc result =
if i == max then
(V.map (\s -> (s, V.empty)) $ V.last sc) `cons` result
else
let i1 = i + 1
current = sc ! i
next = sc ! i1
len = V.length next
allCombos = V.map getCombos current
uCombos = bigU allCombos
indices = V.map (V.map (\face ->
len + (elemIndexUnsafe face uCombos))) allCombos
in combos i1 max (replaceElem i1 (next V.++ uCombos) sc)
$ (V.zip current indices) `cons` result
fstmc2 = fst maxCliques - 2
in
if fstmc2 == (-1) then (numVerts, V.empty)
else
let sc = combos 0 fstmc2 (snd maxCliques) V.empty
in (numVerts, sc)
makeRipsComplexLightPar :: (Ord a, Eq b)
=> a
-> (b -> b -> a)
-> Either (Vector b) [b]
-> SimplicialComplex
makeRipsComplexLightPar scale metric dataSet =
let numVerts = L.length dataSet
vector = case dataSet of Left v -> v; Right l -> V.fromList l
organizeCliques 1 _ = []
organizeCliques i cliques =
let helper = V.partition (\simplex -> i == V.length simplex) cliques
in (fst helper):(organizeCliques (i - 1) $ snd helper)
makePair simplices =
case simplices of
(x:_) ->
let dim = V.length x
in (dim, organizeCliques dim $ V.fromList simplices)
[] -> (1, [])
maxCliques :: (Int, Vector (Vector (Vector Int)))
maxCliques =
(\(x, y) -> (x, V.fromList y)) $ makePair
$ sortVecs $ L.map V.fromList $ L.filter (\c -> L.length c > 1)
$ getMaximalCliques (\i j -> metric (vector ! i) (vector ! j) <= scale) [0..numVerts-1]
combos :: Int
-> Int
-> Vector (Vector (Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
-> Vector (Vector (Vector Int, Vector Int))
combos i max sc result =
if i == max then
(V.map (\s -> (s, V.empty)) $ V.last sc) `cons` result
else
let i1 = i + 1
current = sc ! i
next = sc ! i1
len = V.length next
allCombos = V.map getCombos current
uCombos = bigU allCombos
indices = parMapVec (V.map (\face ->
len + (elemIndexUnsafe face uCombos))) allCombos
in combos i1 max (replaceElem i1 (next V.++ uCombos) sc)
$ (V.zip current indices) `cons` result
fstmc2 = fst maxCliques - 2
in
if fstmc2 == (-1) then (numVerts, V.empty)
else
let sc = combos 0 fstmc2 (snd maxCliques) V.empty
in (numVerts, sc)
makeEdgeBoundariesBool :: SimplicialComplex -> BMatrix
makeEdgeBoundariesBool sc =
let mat =
V.map (\edge ->
V.map (\vert -> vert == V.head edge || vert == V.last edge) $ 0 `range` (fst sc - 1))
$ V.map fst $ V.head $ snd sc
in
case transposeMat mat of
Just m -> m
Nothing -> error "error in makeEdgeBoundariesBool"
makeSimplexBoundaryBool :: Int -> SimplicialComplex -> (Vector Int, Vector Int) -> Vector Bool
makeSimplexBoundaryBool dim simplices (simplex, indices) =
mapWithIndex (\i s -> V.elem i indices) (V.map fst $ (snd simplices) ! (dim - 2))
makeBoundaryOperatorBool :: Int -> SimplicialComplex -> BMatrix
makeBoundaryOperatorBool dim sc =
let mat = V.map (makeSimplexBoundaryBool dim sc) $ (snd sc) ! (dim - 1)
in
case transposeMat mat of
Just m -> m
Nothing -> error "error in makeBoundaryOperatorBool"
makeBoundaryOperatorsBool :: SimplicialComplex -> Vector BMatrix
makeBoundaryOperatorsBool sc =
let dim = getDim sc
calc i
| i > dim = V.empty
| i == 1 = (makeEdgeBoundariesBool sc) `cons` (calc 2)
| otherwise = (makeBoundaryOperatorBool i sc) `cons` (calc (i + 1))
in calc 1
bettiNumbers :: SimplicialComplex -> [Int]
bettiNumbers sc =
let dim = (getDim sc) + 1
boundOps = makeBoundaryOperatorsBool sc
ranks = (0, V.length $ V.head boundOps)
`cons` (V.map (\op -> let rank = rankBool op
in (rank, (V.length $ V.head op) - rank)) boundOps)
calc 1 = [(snd $ ranks ! 0) - (fst $ ranks ! 1)]
calc i =
let i1 = i - 1
in
if i == dim then (snd $ V.last ranks):(calc i1)
else ((snd $ ranks ! i1) - (fst $ ranks ! i)):(calc i1)
in
if L.null $ snd sc then [fst sc]
else L.reverse $ calc dim
bettiNumbersPar :: SimplicialComplex -> [Int]
bettiNumbersPar sc =
let dim = (getDim sc) + 1
boundOps = makeBoundaryOperatorsBool sc
ranks = (0, V.length $ V.head boundOps)
`cons` (parMapVec (\op -> let rank = rankBool op
in (rank, (V.length $ V.head op) - rank)) boundOps)
calc 1 = [(snd $ ranks ! 0) - (fst $ ranks ! 1)]
calc i =
let i1 = i - 1
in
if i == dim then evalPar (snd $ V.last ranks) (calc i1)
else evalPar ((snd $ ranks ! i1) - (fst $ ranks ! i)) (calc i1)
in
if L.null $ snd sc then [fst sc]
else L.reverse $ calc dim
makeEdgeBoundariesInt :: SimplicialComplex -> IMatrix
makeEdgeBoundariesInt sc =
let mat =
V.map (\e -> let edge = fst e in
replaceElem (V.head edge) (-1) $
replaceElem (V.last edge) 1 $
V.replicate (fst sc) 0) $
V.head $ snd sc
in
case transposeMat mat of
Just m -> m
Nothing -> error "error in makeEdgeBoundariesInt"
makeSimplexBoundaryInt :: Vector (Vector Int, Vector Int) -> (Vector Int, Vector Int) -> Vector Int
makeSimplexBoundaryInt simplices (_, indices) =
let calc1 ixs result =
if V.null ixs then result
else calc2 (V.tail ixs) $ replaceElem (V.head ixs) (-1) result
calc2 ixs result =
if V.null ixs then result
else calc1 (V.tail ixs) $ replaceElem (V.head ixs) 1 result
in calc1 indices $ V.replicate (V.length simplices) 0
makeBoundaryOperatorInt :: Int -> SimplicialComplex -> IMatrix
makeBoundaryOperatorInt dim sc =
let mat = V.map (makeSimplexBoundaryInt ((snd sc) ! (dim - 2))) $ (snd sc) ! (dim - 1)
in
case transposeMat mat of
Just m -> m
Nothing -> error $ show mat
makeBoundaryOperatorsInt :: SimplicialComplex -> Vector IMatrix
makeBoundaryOperatorsInt sc =
let dim = getDim sc
calc 1 = (makeEdgeBoundariesInt sc) `cons` (calc 2)
calc i =
if i > dim then V.empty
else (makeBoundaryOperatorInt i sc) `cons` (calc $ i + 1)
in calc 1
simplicialHomology :: SimplicialComplex -> [[Int]]
simplicialHomology sc =
let dim = getDim sc
boundOps = makeBoundaryOperatorsInt sc
calc 0 = [getUnsignedDiagonal $ normalFormInt (boundOps ! 0)]
calc i =
if i == dim then
let op = V.last boundOps
in (L.replicate ((V.length $ V.head op) - (rankInt op)) 0):(calc $ i - 1)
else
let i1 = i - 1
in (getUnsignedDiagonal $ normalFormInt $ imgInKerInt (boundOps ! i1) (boundOps ! i)):(calc i1)
in
if L.null $ snd sc then [L.replicate (fst sc) 0]
else L.reverse $ L.map (L.filter (/=1)) $ calc dim
simplicialHomologyPar :: SimplicialComplex -> [[Int]]
simplicialHomologyPar sc =
let dim = getDim sc
boundOps = makeBoundaryOperatorsInt sc
calc 0 = [getUnsignedDiagonal $ normalFormInt (boundOps ! 0)]
calc i =
if i == dim then
let op = V.last boundOps
in evalPar (L.replicate ((V.length $ V.head op) - (rankInt op)) 0) $ calc $ i - 1
else
let i1 = i - 1
in evalPar (getUnsignedDiagonal $ normalFormIntPar $
imgInKerIntPar (boundOps ! i1) (boundOps ! i)) $ calc i1
in
if L.null $ snd sc then [L.replicate (fst sc) 0]
else L.reverse $ L.map (L.filter (/=1)) $ calc dim