module Tgraph.Relabelling
(
fullUnion
, tryFullUnion
, commonFaces
, sameGraph
, Relabelling(..)
, newRelabelling
, relabelToMatch
, tryRelabelToMatch
, relabelToMatchIgnore
, relabelGraph
, checkRelabelGraph
, relabelFace
, relabelV
, prepareFixAvoid
, relabelContig
, renumberFaces
) where
import Data.List (intersect, (\\), union,find,partition,nub)
import qualified Data.IntMap.Strict as VMap (IntMap, findWithDefault, fromList, fromAscList, union)
import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member)
import Tgraph.Prelude
fullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph
fullUnion :: (Tgraph, (Vertex, Vertex)) -> (Tgraph, (Vertex, Vertex)) -> Tgraph
fullUnion (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2) = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryFullUnion (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2)
tryFullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph
tryFullUnion :: (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryFullUnion (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2) = String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
"tryFullUnion:\n" (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$
do Tgraph
g3 <- (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryRelabelToMatch (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2)
let fcs :: [TileFace]
fcs = Tgraph -> [TileFace]
faces Tgraph
g1 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`union` Tgraph -> [TileFace]
faces Tgraph
g3
touchVs :: [(Vertex, Vertex)]
touchVs = [TileFace] -> [(Vertex, Vertex)]
touchingVertices [TileFace]
fcs
if [(Vertex, Vertex)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Vertex, Vertex)]
touchVs
then Tgraph -> Try Tgraph
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tgraph -> Try Tgraph) -> Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
fcs
else let vertg1 :: VertexSet
vertg1 = Tgraph -> VertexSet
vertexSet Tgraph
g1
correct :: (Vertex, Vertex) -> (Vertex, Vertex)
correct e :: (Vertex, Vertex)
e@(Vertex
a,Vertex
b) = if Vertex
a Vertex -> VertexSet -> Bool
`IntSet.member` VertexSet
vertg1 then (Vertex
b,Vertex
a) else (Vertex, Vertex)
e
newrel :: Relabelling
newrel = [(Vertex, Vertex)] -> Relabelling
newRelabelling ([(Vertex, Vertex)] -> Relabelling)
-> [(Vertex, Vertex)] -> Relabelling
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> (Vertex, Vertex))
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> (Vertex, Vertex)
correct [(Vertex, Vertex)]
touchVs
in [TileFace] -> Try Tgraph
tryTgraphProps ([TileFace] -> Try Tgraph) -> [TileFace] -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a]
nub ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> TileFace) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Relabelling -> TileFace -> TileFace
relabelFace Relabelling
newrel) [TileFace]
fcs
commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace]
commonFaces :: (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> [TileFace]
commonFaces (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2) = Tgraph -> [TileFace]
faces Tgraph
g1 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TileFace]
relFaces where
g3 :: Tgraph
g3 = (Tgraph, (Vertex, Vertex)) -> (Tgraph, (Vertex, Vertex)) -> Tgraph
relabelToMatchIgnore (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2)
fcs :: [TileFace]
fcs = Tgraph -> [TileFace]
faces Tgraph
g1 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`union` Tgraph -> [TileFace]
faces Tgraph
g3
touchVs :: [(Vertex, Vertex)]
touchVs = [TileFace] -> [(Vertex, Vertex)]
touchingVerticesGen [TileFace]
fcs
relFaces :: [TileFace]
relFaces = (TileFace -> TileFace) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Relabelling -> TileFace -> TileFace
relabelFace (Relabelling -> TileFace -> TileFace)
-> Relabelling -> TileFace -> TileFace
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> Relabelling
newRelabelling ([(Vertex, Vertex)] -> Relabelling)
-> [(Vertex, Vertex)] -> Relabelling
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> (Vertex, Vertex))
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> (Vertex, Vertex)
correct [(Vertex, Vertex)]
touchVs) (Tgraph -> [TileFace]
faces Tgraph
g3)
vertg1 :: VertexSet
vertg1 = Tgraph -> VertexSet
vertexSet Tgraph
g1
correct :: (Vertex, Vertex) -> (Vertex, Vertex)
correct e :: (Vertex, Vertex)
e@(Vertex
a,Vertex
b) = if Vertex
a Vertex -> VertexSet -> Bool
`IntSet.member` VertexSet
vertg1 then (Vertex
b,Vertex
a) else (Vertex, Vertex)
e
sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool
sameGraph :: (Tgraph, (Vertex, Vertex)) -> (Tgraph, (Vertex, Vertex)) -> Bool
sameGraph (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2) = [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length (Tgraph -> [TileFace]
faces Tgraph
g1) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length (Tgraph -> [TileFace]
faces Tgraph
g2) Bool -> Bool -> Bool
&&
Bool -> Try Bool -> Bool
forall a. a -> Try a -> a
ifFail Bool
False Try Bool
tryResult where
tryResult :: Try Bool
tryResult = do Tgraph
g <- (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryRelabelToMatch (Tgraph
g1,(Vertex, Vertex)
e1) (Tgraph
g2,(Vertex, Vertex)
e2)
Bool -> Try Bool
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tgraph -> VertexSet
vertexSet Tgraph
g VertexSet -> VertexSet -> Bool
forall a. Eq a => a -> a -> Bool
== Tgraph -> VertexSet
vertexSet Tgraph
g1)
newtype Relabelling = Relabelling (VMap.IntMap Vertex)
newRelabelling :: [(Vertex,Vertex)] -> Relabelling
newRelabelling :: [(Vertex, Vertex)] -> Relabelling
newRelabelling [(Vertex, Vertex)]
prs
| [Vertex] -> Bool
forall {a}. (Ord a, Num a) => [a] -> Bool
wrong (((Vertex, Vertex) -> Vertex) -> [(Vertex, Vertex)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd [(Vertex, Vertex)]
prs) = String -> Relabelling
forall a. HasCallStack => String -> a
error (String -> Relabelling) -> String -> Relabelling
forall a b. (a -> b) -> a -> b
$ String
"newRelabelling: Not 1-1 or Non-positive label in range " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
prs
| Bool
otherwise = IntMap Vertex -> Relabelling
Relabelling (IntMap Vertex -> Relabelling) -> IntMap Vertex -> Relabelling
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> IntMap Vertex
forall a. [(Vertex, a)] -> IntMap a
VMap.fromList ([(Vertex, Vertex)] -> IntMap Vertex)
-> [(Vertex, Vertex)] -> IntMap Vertex
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [(a, a)] -> [(a, a)]
differing [(Vertex, Vertex)]
prs
where wrong :: [a] -> Bool
wrong [a]
vs = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
1) [a]
vs Bool -> Bool -> Bool
|| Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> [a]
forall a. Eq a => [a] -> [a]
duplicates [a]
vs))
relabellingFrom :: Int -> VertexSet -> Relabelling
relabellingFrom :: Vertex -> VertexSet -> Relabelling
relabellingFrom Vertex
n VertexSet
vs
| Vertex
nVertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
<Vertex
1 = String -> Relabelling
forall a. HasCallStack => String -> a
error (String -> Relabelling) -> String -> Relabelling
forall a b. (a -> b) -> a -> b
$ String
"relabellingFrom: Label not positive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
n
| Bool
otherwise = IntMap Vertex -> Relabelling
Relabelling (IntMap Vertex -> Relabelling) -> IntMap Vertex -> Relabelling
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> IntMap Vertex
forall a. [(Vertex, a)] -> IntMap a
VMap.fromAscList ([(Vertex, Vertex)] -> IntMap Vertex)
-> [(Vertex, Vertex)] -> IntMap Vertex
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [(a, a)] -> [(a, a)]
differing ([(Vertex, Vertex)] -> [(Vertex, Vertex)])
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [Vertex] -> [(Vertex, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip (VertexSet -> [Vertex]
IntSet.elems VertexSet
vs) [Vertex
n..]
relabellingTo :: TileFace -> TileFace -> Relabelling
TileFace
f1 relabellingTo :: TileFace -> TileFace -> Relabelling
`relabellingTo` TileFace
f2 = [(Vertex, Vertex)] -> Relabelling
newRelabelling ([(Vertex, Vertex)] -> Relabelling)
-> [(Vertex, Vertex)] -> Relabelling
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [Vertex] -> [(Vertex, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TileFace -> [Vertex]
faceVList TileFace
f1) (TileFace -> [Vertex]
faceVList TileFace
f2)
relabelUnion:: Relabelling -> Relabelling -> Relabelling
relabelUnion :: Relabelling -> Relabelling -> Relabelling
relabelUnion (Relabelling IntMap Vertex
r1) (Relabelling IntMap Vertex
r2) = IntMap Vertex -> Relabelling
Relabelling (IntMap Vertex -> Relabelling) -> IntMap Vertex -> Relabelling
forall a b. (a -> b) -> a -> b
$ IntMap Vertex -> IntMap Vertex -> IntMap Vertex
forall a. IntMap a -> IntMap a -> IntMap a
VMap.union IntMap Vertex
r1 IntMap Vertex
r2
relabelToMatch:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph
relabelToMatch :: (Tgraph, (Vertex, Vertex)) -> (Tgraph, (Vertex, Vertex)) -> Tgraph
relabelToMatch (Tgraph, (Vertex, Vertex))
ge1 (Tgraph, (Vertex, Vertex))
ge2 = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryRelabelToMatch (Tgraph, (Vertex, Vertex))
ge1 (Tgraph, (Vertex, Vertex))
ge2
tryRelabelToMatch :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph
tryRelabelToMatch :: (Tgraph, (Vertex, Vertex))
-> (Tgraph, (Vertex, Vertex)) -> Try Tgraph
tryRelabelToMatch (Tgraph
g1,(Vertex
x1,Vertex
y1)) (Tgraph
g2,(Vertex
x2,Vertex
y2)) = String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
"tryRelabelToMatch:\n" (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$
do let g2prepared :: Tgraph
g2prepared = [Vertex] -> VertexSet -> Tgraph -> Tgraph
prepareFixAvoid [Vertex
x2,Vertex
y2] (Tgraph -> VertexSet
vertexSet Tgraph
g1) Tgraph
g2
TileFace
fc2 <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> (Vertex, Vertex) -> Bool
`hasDedge` (Vertex
x2,Vertex
y2)) (Tgraph -> [TileFace]
faces Tgraph
g2prepared)
Maybe TileFace -> String -> Try TileFace
forall b. Maybe b -> String -> Try b
`nothingFail` (String
"No face found for edge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
x2,Vertex
y2))
Maybe TileFace
maybef <- TileFace -> Tgraph -> Try (Maybe TileFace)
tryMatchFace (Relabelling -> TileFace -> TileFace
relabelFace ([(Vertex, Vertex)] -> Relabelling
newRelabelling [(Vertex
x2,Vertex
x1),(Vertex
y2,Vertex
y1)]) TileFace
fc2) Tgraph
g1
TileFace
fc1 <- Maybe TileFace
maybef Maybe TileFace -> String -> Try TileFace
forall b. Maybe b -> String -> Try b
`nothingFail`
(String
"No matching face found at edge "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
x1,Vertex
y1)String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\nfor relabelled face " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
fc2)
(Tgraph, TileFace) -> (Tgraph, TileFace) -> Try Tgraph
tryRelabelFromFaces (Tgraph
g1,TileFace
fc1) (Tgraph
g2prepared,TileFace
fc2)
tryRelabelFromFaces :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Try Tgraph
tryRelabelFromFaces :: (Tgraph, TileFace) -> (Tgraph, TileFace) -> Try Tgraph
tryRelabelFromFaces (Tgraph
g1,TileFace
fc1) (Tgraph
g2,TileFace
fc2) = String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
"tryRelabelFromFaces:\n" (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$
do Relabelling
rlab <- Tgraph
-> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling
tryGrowRelabel Tgraph
g1 [TileFace
fc2] (Tgraph -> [TileFace]
faces Tgraph
g2 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TileFace
fc2]) (TileFace
fc2 TileFace -> TileFace -> Relabelling
`relabellingTo` TileFace
fc1)
Tgraph -> Try Tgraph
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tgraph -> Try Tgraph) -> Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ Relabelling -> Tgraph -> Tgraph
relabelGraph Relabelling
rlab Tgraph
g2
tryGrowRelabel:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling
tryGrowRelabel :: Tgraph
-> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling
tryGrowRelabel Tgraph
_ [] [TileFace]
_ Relabelling
rlab = Relabelling -> Try Relabelling
forall a b. b -> Either a b
Right Relabelling
rlab
tryGrowRelabel Tgraph
g (TileFace
fc:[TileFace]
fcs) [TileFace]
awaiting Relabelling
rlab =
do Maybe TileFace
maybef <- TileFace -> Tgraph -> Try (Maybe TileFace)
tryMatchFace (Relabelling -> TileFace -> TileFace
relabelFace Relabelling
rlab TileFace
fc) Tgraph
g
case Maybe TileFace
maybef of
Maybe TileFace
Nothing -> Tgraph
-> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling
tryGrowRelabel Tgraph
g [TileFace]
fcs [TileFace]
awaiting Relabelling
rlab
Just TileFace
orig -> Tgraph
-> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling
tryGrowRelabel Tgraph
g ([TileFace]
fcs[TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++[TileFace]
fcs') [TileFace]
awaiting' Relabelling
rlab'
where ([TileFace]
fcs', [TileFace]
awaiting') = (TileFace -> Bool) -> [TileFace] -> ([TileFace], [TileFace])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TileFace -> TileFace -> Bool
edgeNb TileFace
fc) [TileFace]
awaiting
rlab' :: Relabelling
rlab' = Relabelling -> Relabelling -> Relabelling
relabelUnion (TileFace
fc TileFace -> TileFace -> Relabelling
`relabellingTo` TileFace
orig) Relabelling
rlab
relabelToMatchIgnore :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph
relabelToMatchIgnore :: (Tgraph, (Vertex, Vertex)) -> (Tgraph, (Vertex, Vertex)) -> Tgraph
relabelToMatchIgnore (Tgraph
g1,(Vertex
x1,Vertex
y1)) (Tgraph
g2,(Vertex
x2,Vertex
y2)) = (Tgraph, TileFace) -> (Tgraph, TileFace) -> Tgraph
relabelFromFacesIgnore (Tgraph
g1,TileFace
fc1) (Tgraph
g2prepared,TileFace
fc2) where
g2prepared :: Tgraph
g2prepared = [Vertex] -> VertexSet -> Tgraph -> Tgraph
prepareFixAvoid [Vertex
x2,Vertex
y2] (Tgraph -> VertexSet
vertexSet Tgraph
g1) Tgraph
g2
fc2 :: TileFace
fc2 = case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> (Vertex, Vertex) -> Bool
`hasDedge` (Vertex
x2,Vertex
y2)) (Tgraph -> [TileFace]
faces Tgraph
g2prepared) of
Maybe TileFace
Nothing -> String -> TileFace
forall a. HasCallStack => String -> a
error (String -> TileFace) -> String -> TileFace
forall a b. (a -> b) -> a -> b
$ String
"No face found for edge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
x2,Vertex
y2)
Just TileFace
f -> TileFace
f
fc1 :: TileFace
fc1 = case TileFace -> Tgraph -> Maybe TileFace
matchFaceIgnore (Relabelling -> TileFace -> TileFace
relabelFace ([(Vertex, Vertex)] -> Relabelling
newRelabelling [(Vertex
x2,Vertex
x1),(Vertex
y2,Vertex
y1)]) TileFace
fc2) Tgraph
g1 of
Maybe TileFace
Nothing -> String -> TileFace
forall a. HasCallStack => String -> a
error (String -> TileFace) -> String -> TileFace
forall a b. (a -> b) -> a -> b
$ String
"No matching face found at edge "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
x1,Vertex
y1)String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\nfor relabelled face " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
fc2
Just TileFace
f -> TileFace
f
relabelFromFacesIgnore :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Tgraph
relabelFromFacesIgnore :: (Tgraph, TileFace) -> (Tgraph, TileFace) -> Tgraph
relabelFromFacesIgnore (Tgraph
g1,TileFace
fc1) (Tgraph
g2,TileFace
fc2) = Relabelling -> Tgraph -> Tgraph
relabelGraph Relabelling
rlab Tgraph
g2 where
rlab :: Relabelling
rlab = Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling
growRelabelIgnore Tgraph
g1 [TileFace
fc2] (Tgraph -> [TileFace]
faces Tgraph
g2 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TileFace
fc2]) (TileFace
fc2 TileFace -> TileFace -> Relabelling
`relabellingTo` TileFace
fc1)
growRelabelIgnore:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling
growRelabelIgnore :: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling
growRelabelIgnore Tgraph
_ [] [TileFace]
_ Relabelling
rlab = Relabelling
rlab
growRelabelIgnore Tgraph
g (TileFace
fc:[TileFace]
fcs) [TileFace]
awaiting Relabelling
rlab =
case TileFace -> Tgraph -> Maybe TileFace
matchFaceIgnore (Relabelling -> TileFace -> TileFace
relabelFace Relabelling
rlab TileFace
fc) Tgraph
g of
Maybe TileFace
Nothing -> Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling
growRelabelIgnore Tgraph
g [TileFace]
fcs [TileFace]
awaiting Relabelling
rlab
Just TileFace
orig -> Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling
growRelabelIgnore Tgraph
g ([TileFace]
fcs[TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++[TileFace]
fcs') [TileFace]
awaiting' Relabelling
rlab'
where ([TileFace]
fcs', [TileFace]
awaiting') = (TileFace -> Bool) -> [TileFace] -> ([TileFace], [TileFace])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TileFace -> TileFace -> Bool
edgeNb TileFace
fc) [TileFace]
awaiting
rlab' :: Relabelling
rlab' = Relabelling -> Relabelling -> Relabelling
relabelUnion (TileFace
fc TileFace -> TileFace -> Relabelling
`relabellingTo` TileFace
orig) Relabelling
rlab
relabelGraph:: Relabelling -> Tgraph -> Tgraph
relabelGraph :: Relabelling -> Tgraph -> Tgraph
relabelGraph Relabelling
rlab Tgraph
g = [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
newFaces where
newFaces :: [TileFace]
newFaces = (TileFace -> TileFace) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Relabelling -> TileFace -> TileFace
relabelFace Relabelling
rlab) (Tgraph -> [TileFace]
faces Tgraph
g)
checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph
checkRelabelGraph :: Relabelling -> Tgraph -> Tgraph
checkRelabelGraph Relabelling
rlab Tgraph
g = [TileFace] -> Tgraph
checkedTgraph [TileFace]
newFaces where
newFaces :: [TileFace]
newFaces = (TileFace -> TileFace) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Relabelling -> TileFace -> TileFace
relabelFace Relabelling
rlab) (Tgraph -> [TileFace]
faces Tgraph
g)
relabelFace:: Relabelling -> TileFace -> TileFace
relabelFace :: Relabelling -> TileFace -> TileFace
relabelFace Relabelling
rlab = ((Vertex, Vertex, Vertex) -> (Vertex, Vertex, Vertex))
-> TileFace -> TileFace
forall a b. (a -> b) -> HalfTile a -> HalfTile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Vertex -> Vertex)
-> (Vertex, Vertex, Vertex) -> (Vertex, Vertex, Vertex)
forall {t} {c}. (t -> c) -> (t, t, t) -> (c, c, c)
all3 (Relabelling -> Vertex -> Vertex
relabelV Relabelling
rlab)) where
all3 :: (t -> c) -> (t, t, t) -> (c, c, c)
all3 t -> c
f (t
a,t
b,t
c) = (t -> c
f t
a,t -> c
f t
b,t -> c
f t
c)
relabelV:: Relabelling -> Vertex -> Vertex
relabelV :: Relabelling -> Vertex -> Vertex
relabelV (Relabelling IntMap Vertex
r) Vertex
v = Vertex -> Vertex -> IntMap Vertex -> Vertex
forall a. a -> Vertex -> IntMap a -> a
VMap.findWithDefault Vertex
v Vertex
v IntMap Vertex
r
relabelAvoid :: VertexSet -> Tgraph -> Tgraph
relabelAvoid :: VertexSet -> Tgraph -> Tgraph
relabelAvoid VertexSet
avoid Tgraph
g = Relabelling -> Tgraph -> Tgraph
relabelGraph Relabelling
rlab Tgraph
g where
gverts :: VertexSet
gverts = Tgraph -> VertexSet
vertexSet Tgraph
g
avoidMax :: Vertex
avoidMax = if VertexSet -> Bool
IntSet.null VertexSet
avoid then Vertex
0 else VertexSet -> Vertex
IntSet.findMax VertexSet
avoid
vertsToChange :: VertexSet
vertsToChange = VertexSet
gverts VertexSet -> VertexSet -> VertexSet
`IntSet.intersection` VertexSet
avoid
rlab :: Relabelling
rlab = Vertex -> VertexSet -> Relabelling
relabellingFrom (Vertex
1Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+ Vertex -> Vertex -> Vertex
forall a. Ord a => a -> a -> a
max (Tgraph -> Vertex
maxV Tgraph
g) Vertex
avoidMax) VertexSet
vertsToChange
prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph
prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph
prepareFixAvoid [Vertex]
fix VertexSet
avoid = VertexSet -> Tgraph -> Tgraph
relabelAvoid (VertexSet
avoid VertexSet -> VertexSet -> VertexSet
IntSet.\\ [Vertex] -> VertexSet
IntSet.fromList [Vertex]
fix)
relabelContig :: Tgraph -> Tgraph
relabelContig :: Tgraph -> Tgraph
relabelContig Tgraph
g = Relabelling -> Tgraph -> Tgraph
relabelGraph Relabelling
rlab Tgraph
g where
rlab :: Relabelling
rlab = Vertex -> VertexSet -> Relabelling
relabellingFrom Vertex
1 (Tgraph -> VertexSet
vertexSet Tgraph
g)
renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace]
renumberFaces :: [(Vertex, Vertex)] -> [TileFace] -> [TileFace]
renumberFaces [(Vertex, Vertex)]
prs = (TileFace -> TileFace) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> TileFace
renumberFace where
mapping :: IntMap Vertex
mapping = [(Vertex, Vertex)] -> IntMap Vertex
forall a. [(Vertex, a)] -> IntMap a
VMap.fromList ([(Vertex, Vertex)] -> IntMap Vertex)
-> [(Vertex, Vertex)] -> IntMap Vertex
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [(a, a)] -> [(a, a)]
differing [(Vertex, Vertex)]
prs
renumberFace :: TileFace -> TileFace
renumberFace = ((Vertex, Vertex, Vertex) -> (Vertex, Vertex, Vertex))
-> TileFace -> TileFace
forall a b. (a -> b) -> HalfTile a -> HalfTile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Vertex -> Vertex)
-> (Vertex, Vertex, Vertex) -> (Vertex, Vertex, Vertex)
forall {t} {c}. (t -> c) -> (t, t, t) -> (c, c, c)
all3 Vertex -> Vertex
renumber)
all3 :: (t -> c) -> (t, t, t) -> (c, c, c)
all3 t -> c
f (t
a,t
b,t
c) = (t -> c
f t
a,t -> c
f t
b,t -> c
f t
c)
renumber :: Vertex -> Vertex
renumber Vertex
v = Vertex -> Vertex -> IntMap Vertex -> Vertex
forall a. a -> Vertex -> IntMap a -> a
VMap.findWithDefault Vertex
v Vertex
v IntMap Vertex
mapping
tryMatchFace:: TileFace -> Tgraph -> Try (Maybe TileFace)
tryMatchFace :: TileFace -> Tgraph -> Try (Maybe TileFace)
tryMatchFace TileFace
face Tgraph
g = String -> Try (Maybe TileFace) -> Try (Maybe TileFace)
forall a. String -> Try a -> Try a
onFail String
"tryMatchFace:\n" (Try (Maybe TileFace) -> Try (Maybe TileFace))
-> Try (Maybe TileFace) -> Try (Maybe TileFace)
forall a b. (a -> b) -> a -> b
$
case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> [(Vertex, Vertex)] -> Bool
`hasDedgeIn` TileFace -> [(Vertex, Vertex)]
faceDedges TileFace
face) (Tgraph -> [TileFace]
faces Tgraph
g) of
Maybe TileFace
Nothing -> Maybe TileFace -> Try (Maybe TileFace)
forall a b. b -> Either a b
Right Maybe TileFace
forall a. Maybe a
Nothing
Just TileFace
corresp -> if TileFace -> TileFace -> Bool
twoVMatch TileFace
corresp TileFace
face
then Maybe TileFace -> Try (Maybe TileFace)
forall a b. b -> Either a b
Right (Maybe TileFace -> Try (Maybe TileFace))
-> Maybe TileFace -> Try (Maybe TileFace)
forall a b. (a -> b) -> a -> b
$ TileFace -> Maybe TileFace
forall a. a -> Maybe a
Just TileFace
corresp
else String -> Try (Maybe TileFace)
forall a b. a -> Either a b
Left (String -> Try (Maybe TileFace)) -> String -> Try (Maybe TileFace)
forall a b. (a -> b) -> a -> b
$ String
"Found non matching faces " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TileFace, TileFace) -> String
forall a. Show a => a -> String
show (TileFace
corresp, TileFace
face) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
twoVMatch:: TileFace -> TileFace -> Bool
twoVMatch :: TileFace -> TileFace -> Bool
twoVMatch TileFace
f1 TileFace
f2 = TileFace -> TileFace -> Bool
forall rep1 rep2. HalfTile rep1 -> HalfTile rep2 -> Bool
isMatched TileFace
f1 TileFace
f2 Bool -> Bool -> Bool
&&
if TileFace -> Vertex
firstV TileFace
f1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Vertex
firstV TileFace
f2
then TileFace -> Vertex
secondV TileFace
f1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Vertex
secondV TileFace
f2 Bool -> Bool -> Bool
|| TileFace -> Vertex
thirdV TileFace
f1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Vertex
thirdV TileFace
f2
else TileFace -> Vertex
secondV TileFace
f1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Vertex
secondV TileFace
f2 Bool -> Bool -> Bool
&& TileFace -> Vertex
thirdV TileFace
f1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Vertex
thirdV TileFace
f2
matchFaceIgnore:: TileFace -> Tgraph -> Maybe TileFace
matchFaceIgnore :: TileFace -> Tgraph -> Maybe TileFace
matchFaceIgnore TileFace
face Tgraph
g = case TileFace -> Tgraph -> Try (Maybe TileFace)
tryMatchFace TileFace
face Tgraph
g of
Right Maybe TileFace
mf -> Maybe TileFace
mf
Left String
_ -> Maybe TileFace
forall a. Maybe a
Nothing
differing :: Eq a => [(a,a)] -> [(a,a)]
differing :: forall a. Eq a => [(a, a)] -> [(a, a)]
differing = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
a,a
b) -> a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
b)