{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Tgraphs
( module Tgraph.Prelude
, module Tgraph.Decompose
, module Tgraph.Compose
, module Tgraph.Force
, module Tgraph.Relabelling
, makeTgraph
, tryMakeTgraph
, tryCorrectTouchingVs
, smart
, boundaryJoinFaces
, drawJoinsFor
, smartdraw
, restrictSmart
, smartRotateBefore
, smartAlignBefore
, drawPCompose
, drawForce
, drawSuperForce
, drawWithMax
, addBoundaryAfter
, drawCommonFaces
, emphasizeFaces
, composeK
, compForce
, allCompForce
, maxCompForce
, forceDecomp
, allForceDecomps
, emplaceChoices
, forcedBoundaryECovering
, forcedBoundaryVCovering
, boundaryECovering
, boundaryEdgeSet
, commonBdry
, boundaryVCovering
, boundaryVertexSet
, internalVertexSet
, tryDartAndKiteForced
, tryDartAndKite
, drawFBCovering
, empire1
, empire2
, empire2Plus
, drawEmpire
, showEmpire1
, showEmpire2
, superForce
, trySuperForce
, singleChoiceEdges
, boundaryLoopsG
, boundaryLoops
, findLoops
, pathFromBoundaryLoops
, TrackedTgraph(..)
, newTrackedTgraph
, makeTrackedTgraph
, trackFaces
, unionTwoTracked
, addHalfDartTracked
, addHalfKiteTracked
, decomposeTracked
, drawTrackedTgraph
, drawTrackedTgraphRotated
, drawTrackedTgraphAligned
) where
import Tgraph.Prelude
import Tgraph.Decompose
import Tgraph.Compose
import Tgraph.Force
import Tgraph.Relabelling
import Diagrams.Prelude hiding (union)
import TileLib
import Data.List (intersect, union, (\\), find, foldl',nub, transpose)
import qualified Data.Set as Set (Set,fromList,null,intersection,deleteFindMin)
import qualified Data.IntSet as IntSet (fromList,member,(\\))
import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!))
makeTgraph :: [TileFace] -> Tgraph
makeTgraph :: [TileFace] -> Tgraph
makeTgraph [TileFace]
fcs = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
"makeTgraph: (failed):\n" (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Try Tgraph
tryMakeTgraph [TileFace]
fcs
tryMakeTgraph :: [TileFace] -> Try Tgraph
tryMakeTgraph :: [TileFace] -> Try Tgraph
tryMakeTgraph [TileFace]
fcs =
do Tgraph
g <- [TileFace] -> Try Tgraph
tryTgraphProps [TileFace]
fcs
let touchVs :: [Dedge]
touchVs = [TileFace] -> [Dedge]
touchingVertices (Tgraph -> [TileFace]
faces Tgraph
g)
if [Dedge] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Dedge]
touchVs
then Tgraph -> Try Tgraph
forall a b. b -> Either a b
Right Tgraph
g
else String -> Try Tgraph
forall a b. a -> Either a b
Left (String
"Found touching vertices: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dedge] -> String
forall a. Show a => a -> String
show [Dedge]
touchVs
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nwith faces:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TileFace] -> String
forall a. Show a => a -> String
show [TileFace]
fcs
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n(To fix, use: tryCorrectTouchingVs)\n\n"
)
tryCorrectTouchingVs :: [TileFace] -> Try Tgraph
tryCorrectTouchingVs :: [TileFace] -> Try Tgraph
tryCorrectTouchingVs [TileFace]
fcs =
String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail (String
"tryCorrectTouchingVs:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dedge] -> String
forall a. Show a => a -> String
show [Dedge]
touchVs) (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$
[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
$ [Dedge] -> [TileFace] -> [TileFace]
renumberFaces [Dedge]
touchVs [TileFace]
fcs
where touchVs :: [Dedge]
touchVs = [TileFace] -> [Dedge]
touchingVertices [TileFace]
fcs
smart :: Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
smart :: forall b.
Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
smart VPatch -> Diagram2D b
dr Tgraph
g = [TileFace] -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
[TileFace] -> VPatch -> Diagram2D b
drawJoinsFor (Tgraph -> [TileFace]
boundaryJoinFaces Tgraph
g) VPatch
vp Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram2D b
dr VPatch
vp
where vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g
boundaryJoinFaces :: Tgraph -> [TileFace]
boundaryJoinFaces :: Tgraph -> [TileFace]
boundaryJoinFaces Tgraph
g = ((Dedge, TileFace) -> TileFace)
-> [(Dedge, TileFace)] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dedge, TileFace) -> TileFace
forall a b. (a, b) -> b
snd ([(Dedge, TileFace)] -> [TileFace])
-> [(Dedge, TileFace)] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ UFinder
incompleteHalves BoundaryState
bdry ([Dedge] -> [(Dedge, TileFace)]) -> [Dedge] -> [(Dedge, TileFace)]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> [Dedge]
boundary BoundaryState
bdry where
bdry :: BoundaryState
bdry = Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
drawJoinsFor:: Renderable (Path V2 Double) b =>
[TileFace] -> VPatch -> Diagram2D b
drawJoinsFor :: forall b.
Renderable (Path V2 Double) b =>
[TileFace] -> VPatch -> Diagram2D b
drawJoinsFor [TileFace]
fcs VPatch
vp = (Piece -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
(Piece -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
(Piece -> Diagram2D b) -> a -> Diagram2D b
drawWith Piece -> Diagram2D b
forall b. Renderable (Path V2 Double) b => Piece -> Diagram2D b
dashjOnly (VPatch -> [TileFace] -> VPatch
subVP VPatch
vp [TileFace]
fcs)
smartdraw :: Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
smartdraw :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
smartdraw = (VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
smart VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw
restrictSmart :: Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart :: forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
dr VPatch
vp = [TileFace] -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
[TileFace] -> VPatch -> Diagram2D b
drawJoinsFor (Tgraph -> [TileFace]
boundaryJoinFaces Tgraph
g) VPatch
rvp Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram2D b
dr VPatch
rvp
where rvp :: VPatch
rvp = VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp ([TileFace] -> VPatch) -> [TileFace] -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
faces Tgraph
g
smartRotateBefore :: Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Angle Double -> Tgraph -> Diagram2D b
smartRotateBefore :: forall b.
Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Angle Double -> Tgraph -> Diagram2D b
smartRotateBefore VPatch -> Diagram2D b
vfun Angle Double
angle Tgraph
g = (VPatch -> Diagram2D b) -> Angle Double -> Tgraph -> Diagram2D b
forall a. (VPatch -> a) -> Angle Double -> Tgraph -> a
rotateBefore (Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
vfun) Angle Double
angle Tgraph
g
smartAlignBefore :: Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> (Vertex,Vertex) -> Tgraph -> Diagram2D b
smartAlignBefore :: forall b.
Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Dedge -> Tgraph -> Diagram2D b
smartAlignBefore VPatch -> Diagram2D b
vfun (Vertex
a,Vertex
b) Tgraph
g = (VPatch -> Diagram2D b) -> Dedge -> Tgraph -> Diagram2D b
forall a. (VPatch -> a) -> Dedge -> Tgraph -> a
alignBefore (Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
vfun) (Vertex
a,Vertex
b) Tgraph
g
drawPCompose :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
drawPCompose :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
drawPCompose Tgraph
g =
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g' VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp
Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
drawj (VPatch -> [TileFace] -> VPatch
subVP VPatch
vp [TileFace]
remainder) Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
lime
where ([TileFace]
remainder,Tgraph
g') = Tgraph -> ([TileFace], Tgraph)
partCompose Tgraph
g
vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g
drawForce :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
drawForce :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
drawForce Tgraph
g =
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
red Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium
Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp
where vp :: VPatch
vp = Tgraph -> VPatch
makeVP (Tgraph -> VPatch) -> Tgraph -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> Tgraph
forall a. Forcible a => a -> a
force Tgraph
g
drawSuperForce :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
drawSuperForce :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
drawSuperForce Tgraph
g = (Diagram2D b
dg Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
red) Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> Diagram2D b
dfg Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> (Diagram2D b
dsfg Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
blue) where
sfg :: Tgraph
sfg = Tgraph -> Tgraph
forall a. Forcible a => a -> a
superForce Tgraph
g
fg :: Tgraph
fg = Tgraph -> Tgraph
forall a. Forcible a => a -> a
force Tgraph
g
vp :: VPatch
vp = Tgraph -> VPatch
makeVP (Tgraph -> VPatch) -> Tgraph -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> Tgraph
forall a. Forcible a => a -> a
superForce Tgraph
g
dfg :: Diagram2D b
dfg = VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
selectFacesVP VPatch
vp (Tgraph -> [TileFace]
faces Tgraph
fg [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
faces Tgraph
g)
dg :: Diagram2D b
dg = Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp
dsfg :: Diagram2D b
dsfg = VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
selectFacesVP VPatch
vp (Tgraph -> [TileFace]
faces Tgraph
sfg [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
faces Tgraph
fg)
drawWithMax :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
drawWithMax :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
drawWithMax Tgraph
g = (Diagram2D b
dmax Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
red Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium) Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> Diagram2D b
dg where
vp :: VPatch
vp = Tgraph -> VPatch
makeVP (Tgraph -> VPatch) -> Tgraph -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> Tgraph
forall a. Forcible a => a -> a
force Tgraph
g
dg :: Diagram2D b
dg = Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
restrictSmart Tgraph
g VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp
maxg :: Tgraph
maxg = Tgraph -> Tgraph
maxCompForce Tgraph
g
dmax :: Diagram2D b
dmax = VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
subVP VPatch
vp (Tgraph -> [TileFace]
faces Tgraph
maxg)
addBoundaryAfter :: Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
addBoundaryAfter :: forall b.
Renderable (Path V2 Double) b =>
(VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b
addBoundaryAfter VPatch -> Diagram2D b
f Tgraph
g = (VPatch -> [Dedge] -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
VPatch -> [Dedge] -> Diagram2D b
drawEdgesVP VPatch
vp [Dedge]
edges Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
lime) Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram2D b
f VPatch
vp where
vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g
edges :: [Dedge]
edges = Tgraph -> [Dedge]
graphBoundary Tgraph
g
drawCommonFaces :: Renderable (Path V2 Double) b =>
(Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram2D b
drawCommonFaces :: forall b.
Renderable (Path V2 Double) b =>
(Tgraph, Dedge) -> (Tgraph, Dedge) -> Diagram2D b
drawCommonFaces (Tgraph
g1,Dedge
e1) (Tgraph
g2,Dedge
e2) = [TileFace] -> Tgraph -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
[TileFace] -> Tgraph -> Diagram2D b
emphasizeFaces ((Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g1,Dedge
e1) (Tgraph
g2,Dedge
e2)) Tgraph
g1
emphasizeFaces :: Renderable (Path V2 Double) b =>
[TileFace] -> Tgraph -> Diagram2D b
emphasizeFaces :: forall b.
Renderable (Path V2 Double) b =>
[TileFace] -> Tgraph -> Diagram2D b
emphasizeFaces [TileFace]
fcs Tgraph
g = (VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
drawj VPatch
emphvp Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin) Diagram2D b -> Diagram2D b -> Diagram2D b
forall a. Semigroup a => a -> a -> a
<> (VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw VPatch
vp Diagram2D b -> (Diagram2D b -> Diagram2D b) -> Diagram2D b
forall a b. a -> (a -> b) -> b
# Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
ultraThin) where
vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g
emphvp :: VPatch
emphvp = VPatch -> [TileFace] -> VPatch
subVP VPatch
vp ([TileFace]
fcs [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` Tgraph -> [TileFace]
faces Tgraph
g)
composeK :: Tgraph -> Tgraph
composeK :: Tgraph -> Tgraph
composeK Tgraph
g = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Try Tgraph
tryConnectedNoCross [TileFace]
newfaces where
dwInfo :: DartWingInfo
dwInfo = Tgraph -> DartWingInfo
getDartWingInfo Tgraph
g
changedInfo :: DartWingInfo
changedInfo = DartWingInfo
dwInfo{ largeKiteCentres :: [Vertex]
largeKiteCentres = DartWingInfo -> [Vertex]
largeKiteCentres DartWingInfo
dwInfo [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
++ DartWingInfo -> [Vertex]
unknowns DartWingInfo
dwInfo
, unknowns :: [Vertex]
unknowns = []
}
compositions :: [(TileFace, [TileFace])]
compositions = DartWingInfo -> [(TileFace, [TileFace])]
composedFaceGroups DartWingInfo
changedInfo
newfaces :: [TileFace]
newfaces = ((TileFace, [TileFace]) -> TileFace)
-> [(TileFace, [TileFace])] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map (TileFace, [TileFace]) -> TileFace
forall a b. (a, b) -> a
fst [(TileFace, [TileFace])]
compositions
compForce:: Tgraph -> Tgraph
compForce :: Tgraph -> Tgraph
compForce = Tgraph -> Tgraph
uncheckedCompose (Tgraph -> Tgraph) -> (Tgraph -> Tgraph) -> Tgraph -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Tgraph
forall a. Forcible a => a -> a
force
allCompForce:: Tgraph -> [Tgraph]
allCompForce :: Tgraph -> [Tgraph]
allCompForce = (Tgraph -> Bool) -> [Tgraph] -> [Tgraph]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Tgraph -> Bool) -> Tgraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Bool
nullGraph) ([Tgraph] -> [Tgraph])
-> (Tgraph -> [Tgraph]) -> Tgraph -> [Tgraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tgraph -> Tgraph) -> Tgraph -> [Tgraph]
forall a. (a -> a) -> a -> [a]
iterate Tgraph -> Tgraph
uncheckedCompose (Tgraph -> [Tgraph]) -> (Tgraph -> Tgraph) -> Tgraph -> [Tgraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Tgraph
forall a. Forcible a => a -> a
force
maxCompForce:: Tgraph -> Tgraph
maxCompForce :: Tgraph -> Tgraph
maxCompForce Tgraph
g | Tgraph -> Bool
nullGraph Tgraph
g = Tgraph
g
| Bool
otherwise = [Tgraph] -> Tgraph
forall a. HasCallStack => [a] -> a
last ([Tgraph] -> Tgraph) -> [Tgraph] -> Tgraph
forall a b. (a -> b) -> a -> b
$ Tgraph -> [Tgraph]
allCompForce Tgraph
g
forceDecomp:: Tgraph -> Tgraph
forceDecomp :: Tgraph -> Tgraph
forceDecomp = Tgraph -> Tgraph
forall a. Forcible a => a -> a
force (Tgraph -> Tgraph) -> (Tgraph -> Tgraph) -> Tgraph -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Tgraph
decompose
allForceDecomps:: Tgraph -> [Tgraph]
allForceDecomps :: Tgraph -> [Tgraph]
allForceDecomps = (Tgraph -> Tgraph) -> Tgraph -> [Tgraph]
forall a. (a -> a) -> a -> [a]
iterate Tgraph -> Tgraph
forceDecomp
emplaceChoices:: Tgraph -> [Tgraph]
emplaceChoices :: Tgraph -> [Tgraph]
emplaceChoices Tgraph
g = BoundaryState -> [Tgraph]
emplaceChoices' (BoundaryState -> [Tgraph]) -> BoundaryState -> [Tgraph]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> BoundaryState
forall a. Forcible a => a -> a
force (BoundaryState -> BoundaryState) -> BoundaryState -> BoundaryState
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
emplaceChoices':: BoundaryState -> [Tgraph]
emplaceChoices' :: BoundaryState -> [Tgraph]
emplaceChoices' BoundaryState
startbd | Tgraph -> Bool
nullGraph Tgraph
g' = BoundaryState -> Tgraph
recoverGraph (BoundaryState -> Tgraph) -> [BoundaryState] -> [Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BoundaryState] -> [BoundaryState]
choices [BoundaryState
startbd]
| Bool
otherwise = Tgraph -> Tgraph
forceDecomp (Tgraph -> Tgraph) -> [Tgraph] -> [Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoundaryState -> [Tgraph]
emplaceChoices' (Tgraph -> BoundaryState
makeBoundaryState Tgraph
g')
where
g' :: Tgraph
g' = Tgraph -> Tgraph
compose (Tgraph -> Tgraph) -> Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Tgraph
recoverGraph BoundaryState
startbd
startunknowns :: [Vertex]
startunknowns = DartWingInfo -> [Vertex]
unknowns (DartWingInfo -> [Vertex]) -> DartWingInfo -> [Vertex]
forall a b. (a -> b) -> a -> b
$ Tgraph -> DartWingInfo
getDartWingInfo (Tgraph -> DartWingInfo) -> Tgraph -> DartWingInfo
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Tgraph
recoverGraph BoundaryState
startbd
choices :: [BoundaryState] -> [BoundaryState]
choices [] = []
choices (BoundaryState
bd:[BoundaryState]
bds)
= case [Vertex]
startunknowns [Vertex] -> [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` DartWingInfo -> [Vertex]
unknowns (Tgraph -> DartWingInfo
getDartWingInfo (Tgraph -> DartWingInfo) -> Tgraph -> DartWingInfo
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Tgraph
recoverGraph BoundaryState
bd) of
[] -> BoundaryState
bdBoundaryState -> [BoundaryState] -> [BoundaryState]
forall a. a -> [a] -> [a]
:[BoundaryState] -> [BoundaryState]
choices [BoundaryState]
bds
(Vertex
u:[Vertex]
_) -> [BoundaryState] -> [BoundaryState]
choices ([Try BoundaryState] -> [BoundaryState]
forall a. [Try a] -> [a]
atLeastOne (Dedge -> BoundaryState -> [Try BoundaryState]
forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced (Vertex -> BoundaryState -> Dedge
findDartLongForWing Vertex
u BoundaryState
bd) BoundaryState
bd)[BoundaryState] -> [BoundaryState] -> [BoundaryState]
forall a. [a] -> [a] -> [a]
++[BoundaryState]
bds)
findDartLongForWing :: Vertex -> BoundaryState -> Dedge
findDartLongForWing Vertex
v BoundaryState
bd
= case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v) of
Just TileFace
d -> TileFace -> Dedge
longE TileFace
d
Maybe TileFace
Nothing -> String -> Dedge
forall a. HasCallStack => String -> a
error (String -> Dedge) -> String -> Dedge
forall a b. (a -> b) -> a -> b
$ String
"emplaceChoices': dart not found for dart wing vertex " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
v
forcedBoundaryECovering:: Tgraph -> [Tgraph]
forcedBoundaryECovering :: Tgraph -> [Tgraph]
forcedBoundaryECovering Tgraph
g = BoundaryState -> Tgraph
recoverGraph (BoundaryState -> Tgraph) -> [BoundaryState] -> [Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoundaryState -> [BoundaryState]
boundaryECovering BoundaryState
gforcedBdry where
gforcedBdry :: BoundaryState
gforcedBdry = Try BoundaryState -> BoundaryState
forall a. Try a -> a
runTry (Try BoundaryState -> BoundaryState)
-> Try BoundaryState -> BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try BoundaryState -> Try BoundaryState
forall a. String -> Try a -> Try a
onFail String
"forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" (Try BoundaryState -> Try BoundaryState)
-> Try BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$
BoundaryState -> Try BoundaryState
forall a. Forcible a => a -> Try a
tryForce (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
forcedBoundaryVCovering:: Tgraph -> [Tgraph]
forcedBoundaryVCovering :: Tgraph -> [Tgraph]
forcedBoundaryVCovering Tgraph
g = BoundaryState -> Tgraph
recoverGraph (BoundaryState -> Tgraph) -> [BoundaryState] -> [Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoundaryState -> [BoundaryState]
boundaryVCovering BoundaryState
gforcedBdry where
gforcedBdry :: BoundaryState
gforcedBdry = Try BoundaryState -> BoundaryState
forall a. Try a -> a
runTry (Try BoundaryState -> BoundaryState)
-> Try BoundaryState -> BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try BoundaryState -> Try BoundaryState
forall a. String -> Try a -> Try a
onFail String
"forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" (Try BoundaryState -> Try BoundaryState)
-> Try BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$
BoundaryState -> Try BoundaryState
forall a. Forcible a => a -> Try a
tryForce (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
boundaryECovering:: BoundaryState -> [BoundaryState]
boundaryECovering :: BoundaryState -> [BoundaryState]
boundaryECovering BoundaryState
bstate = [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [(BoundaryState
bstate, BoundaryState -> Set Dedge
boundaryEdgeSet BoundaryState
bstate)] where
covers:: [(BoundaryState, Set.Set Dedge)] -> [BoundaryState]
covers :: [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [] = []
covers ((BoundaryState
bs,Set Dedge
es):[(BoundaryState, Set Dedge)]
opens)
| Set Dedge -> Bool
forall a. Set a -> Bool
Set.null Set Dedge
es = BoundaryState
bsBoundaryState -> [BoundaryState] -> [BoundaryState]
forall a. a -> [a] -> [a]
:[(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [(BoundaryState, Set Dedge)]
opens
| Bool
otherwise = [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers ([(BoundaryState, Set Dedge)]
newcases [(BoundaryState, Set Dedge)]
-> [(BoundaryState, Set Dedge)] -> [(BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++ [(BoundaryState, Set Dedge)]
opens)
where (Dedge
de,Set Dedge
des) = Set Dedge -> (Dedge, Set Dedge)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set Dedge
es
newcases :: [(BoundaryState, Set Dedge)]
newcases = (BoundaryState -> (BoundaryState, Set Dedge))
-> [BoundaryState] -> [(BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\BoundaryState
b -> (BoundaryState
b, Set Dedge -> BoundaryState -> Set Dedge
commonBdry Set Dedge
des BoundaryState
b))
([Try BoundaryState] -> [BoundaryState]
forall a. [Try a] -> [a]
atLeastOne ([Try BoundaryState] -> [BoundaryState])
-> [Try BoundaryState] -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ Dedge -> BoundaryState -> [Try BoundaryState]
forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced Dedge
de BoundaryState
bs)
boundaryEdgeSet:: BoundaryState -> Set.Set Dedge
boundaryEdgeSet :: BoundaryState -> Set Dedge
boundaryEdgeSet = [Dedge] -> Set Dedge
forall a. Ord a => [a] -> Set a
Set.fromList ([Dedge] -> Set Dedge)
-> (BoundaryState -> [Dedge]) -> BoundaryState -> Set Dedge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundaryState -> [Dedge]
boundary
commonBdry:: Set.Set Dedge -> BoundaryState -> Set.Set Dedge
commonBdry :: Set Dedge -> BoundaryState -> Set Dedge
commonBdry Set Dedge
des BoundaryState
b = Set Dedge
des Set Dedge -> Set Dedge -> Set Dedge
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` BoundaryState -> Set Dedge
boundaryEdgeSet BoundaryState
b
boundaryVCovering:: BoundaryState -> [BoundaryState]
boundaryVCovering :: BoundaryState -> [BoundaryState]
boundaryVCovering BoundaryState
bd = [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [(BoundaryState
bd, Set Dedge
startbds)] where
startbds :: Set Dedge
startbds = BoundaryState -> Set Dedge
boundaryEdgeSet BoundaryState
bd
startbvs :: VertexSet
startbvs = BoundaryState -> VertexSet
boundaryVertexSet BoundaryState
bd
covers :: [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [] = []
covers ((BoundaryState
open,Set Dedge
es):[(BoundaryState, Set Dedge)]
opens)
| Set Dedge -> Bool
forall a. Set a -> Bool
Set.null Set Dedge
es = case (Dedge -> Bool) -> [Dedge] -> Maybe Dedge
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Vertex
a,Vertex
_) -> Vertex -> VertexSet -> Bool
IntSet.member Vertex
a VertexSet
startbvs) (BoundaryState -> [Dedge]
boundary BoundaryState
open) of
Maybe Dedge
Nothing -> BoundaryState
openBoundaryState -> [BoundaryState] -> [BoundaryState]
forall a. a -> [a] -> [a]
:[(BoundaryState, Set Dedge)] -> [BoundaryState]
covers [(BoundaryState, Set Dedge)]
opens
Just Dedge
dedge -> [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers ([(BoundaryState, Set Dedge)] -> [BoundaryState])
-> [(BoundaryState, Set Dedge)] -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ (BoundaryState -> (BoundaryState, Set Dedge))
-> [BoundaryState] -> [(BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\BoundaryState
b -> (BoundaryState
b, Set Dedge
es)) ([Try BoundaryState] -> [BoundaryState]
forall a. [Try a] -> [a]
atLeastOne ([Try BoundaryState] -> [BoundaryState])
-> [Try BoundaryState] -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ Dedge -> BoundaryState -> [Try BoundaryState]
forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced Dedge
dedge BoundaryState
open) [(BoundaryState, Set Dedge)]
-> [(BoundaryState, Set Dedge)] -> [(BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++[(BoundaryState, Set Dedge)]
opens
| Bool
otherwise = [(BoundaryState, Set Dedge)] -> [BoundaryState]
covers ([(BoundaryState, Set Dedge)] -> [BoundaryState])
-> [(BoundaryState, Set Dedge)] -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ (BoundaryState -> (BoundaryState, Set Dedge))
-> [BoundaryState] -> [(BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\BoundaryState
b -> (BoundaryState
b, Set Dedge -> BoundaryState -> Set Dedge
commonBdry Set Dedge
des BoundaryState
b)) ([Try BoundaryState] -> [BoundaryState]
forall a. [Try a] -> [a]
atLeastOne ([Try BoundaryState] -> [BoundaryState])
-> [Try BoundaryState] -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ Dedge -> BoundaryState -> [Try BoundaryState]
forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced Dedge
de BoundaryState
open) [(BoundaryState, Set Dedge)]
-> [(BoundaryState, Set Dedge)] -> [(BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++[(BoundaryState, Set Dedge)]
opens
where (Dedge
de,Set Dedge
des) = Set Dedge -> (Dedge, Set Dedge)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set Dedge
es
boundaryVertexSet :: BoundaryState -> VertexSet
boundaryVertexSet :: BoundaryState -> VertexSet
boundaryVertexSet BoundaryState
bd = [Vertex] -> VertexSet
IntSet.fromList ([Vertex] -> VertexSet) -> [Vertex] -> VertexSet
forall a b. (a -> b) -> a -> b
$ (Dedge -> Vertex) -> [Dedge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Vertex
forall a b. (a, b) -> a
fst (BoundaryState -> [Dedge]
boundary BoundaryState
bd)
internalVertexSet :: BoundaryState -> VertexSet
internalVertexSet :: BoundaryState -> VertexSet
internalVertexSet BoundaryState
bd = Tgraph -> VertexSet
vertexSet (BoundaryState -> Tgraph
recoverGraph BoundaryState
bd) VertexSet -> VertexSet -> VertexSet
IntSet.\\ BoundaryState -> VertexSet
boundaryVertexSet BoundaryState
bd
tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced :: forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKiteForced Dedge
de a
b =
[ String -> Try a -> Try a
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKiteForced: Dart on edge: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
de String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (Try a -> Try a) -> Try a -> Try a
forall a b. (a -> b) -> a -> b
$
Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfDart Dedge
de a
b Try a -> (a -> Try a) -> Try a
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Try a
forall a. Forcible a => a -> Try a
tryForce
, String -> Try a -> Try a
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKiteForced: Kite on edge: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
de String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (Try a -> Try a) -> Try a -> Try a
forall a b. (a -> b) -> a -> b
$
Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfKite Dedge
de a
b Try a -> (a -> Try a) -> Try a
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Try a
forall a. Forcible a => a -> Try a
tryForce
]
tryDartAndKite:: Forcible a => Dedge -> a -> [Try a]
tryDartAndKite :: forall a. Forcible a => Dedge -> a -> [Try a]
tryDartAndKite Dedge
de a
b =
[ String -> Try a -> Try a
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKite: Dart on edge: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
de String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (Try a -> Try a) -> Try a -> Try a
forall a b. (a -> b) -> a -> b
$
Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfDart Dedge
de a
b
, String -> Try a -> Try a
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKite: Kite on edge: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
de String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (Try a -> Try a) -> Try a -> Try a
forall a b. (a -> b) -> a -> b
$
Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfKite Dedge
de a
b
]
drawFBCovering :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
drawFBCovering :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
drawFBCovering Tgraph
g = Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
ultraThin (Diagram2D b -> Diagram2D b) -> Diagram2D b -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ Double -> [Diagram2D b] -> Diagram2D b
forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
Monoid' a) =>
n -> [a] -> a
vsep Double
1 (Tgraph -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw (Tgraph -> Diagram2D b) -> [Tgraph] -> [Diagram2D b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tgraph -> [Tgraph]
forcedBoundaryVCovering Tgraph
g)
empire1:: Tgraph -> TrackedTgraph
empire1 :: Tgraph -> TrackedTgraph
empire1 Tgraph
g = Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs,Tgraph -> [TileFace]
faces Tgraph
g] where
covers :: [Tgraph]
covers = Tgraph -> [Tgraph]
forcedBoundaryVCovering Tgraph
g
g0 :: Tgraph
g0 = [Tgraph] -> Tgraph
forall a. HasCallStack => [a] -> a
head [Tgraph]
covers
others :: [Tgraph]
others = [Tgraph] -> [Tgraph]
forall a. HasCallStack => [a] -> [a]
tail [Tgraph]
covers
fcs :: [TileFace]
fcs = ([TileFace] -> [TileFace] -> [TileFace])
-> [TileFace] -> [[TileFace]] -> [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Tgraph -> [TileFace]
faces Tgraph
g0) ([[TileFace]] -> [TileFace]) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Tgraph -> [TileFace]) -> [Tgraph] -> [[TileFace]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tgraph -> [TileFace]
g0Intersect [Tgraph]
others
de :: Dedge
de = Tgraph -> Dedge
defaultAlignment Tgraph
g
g0Intersect :: Tgraph -> [TileFace]
g0Intersect Tgraph
g1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Tgraph
g1,Dedge
de)
empire2:: Tgraph -> TrackedTgraph
empire2 :: Tgraph -> TrackedTgraph
empire2 Tgraph
g = Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs, Tgraph -> [TileFace]
faces Tgraph
g] where
covers1 :: [BoundaryState]
covers1 = BoundaryState -> [BoundaryState]
boundaryECovering (BoundaryState -> [BoundaryState])
-> BoundaryState -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ Try BoundaryState -> BoundaryState
forall a. Try a -> a
runTry (Try BoundaryState -> BoundaryState)
-> Try BoundaryState -> BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try BoundaryState -> Try BoundaryState
forall a. String -> Try a -> Try a
onFail String
"empire2:Initial force failed (incorrect Tgraph)\n"
(Try BoundaryState -> Try BoundaryState)
-> Try BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Try BoundaryState
forall a. Forcible a => a -> Try a
tryForce (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
covers2 :: [BoundaryState]
covers2 = (BoundaryState -> [BoundaryState])
-> [BoundaryState] -> [BoundaryState]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BoundaryState -> [BoundaryState]
boundaryECovering [BoundaryState]
covers1
gcovers :: [Tgraph]
gcovers = (BoundaryState -> Tgraph) -> [BoundaryState] -> [Tgraph]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundaryState -> Tgraph
recoverGraph [BoundaryState]
covers2
g0 :: Tgraph
g0 = [Tgraph] -> Tgraph
forall a. HasCallStack => [a] -> a
head [Tgraph]
gcovers
others :: [Tgraph]
others = [Tgraph] -> [Tgraph]
forall a. HasCallStack => [a] -> [a]
tail [Tgraph]
gcovers
fcs :: [TileFace]
fcs = ([TileFace] -> [TileFace] -> [TileFace])
-> [TileFace] -> [[TileFace]] -> [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Tgraph -> [TileFace]
faces Tgraph
g0) ([[TileFace]] -> [TileFace]) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Tgraph -> [TileFace]) -> [Tgraph] -> [[TileFace]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tgraph -> [TileFace]
g0Intersect [Tgraph]
others
de :: Dedge
de = Tgraph -> Dedge
defaultAlignment Tgraph
g
g0Intersect :: Tgraph -> [TileFace]
g0Intersect Tgraph
g1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Tgraph
g1,Dedge
de)
empire2Plus:: Tgraph -> TrackedTgraph
empire2Plus :: Tgraph -> TrackedTgraph
empire2Plus Tgraph
g = Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs, Tgraph -> [TileFace]
faces Tgraph
g] where
covers1 :: [BoundaryState]
covers1 = BoundaryState -> [BoundaryState]
boundaryVCovering (BoundaryState -> [BoundaryState])
-> BoundaryState -> [BoundaryState]
forall a b. (a -> b) -> a -> b
$ Try BoundaryState -> BoundaryState
forall a. Try a -> a
runTry (Try BoundaryState -> BoundaryState)
-> Try BoundaryState -> BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try BoundaryState -> Try BoundaryState
forall a. String -> Try a -> Try a
onFail String
"empire2:Initial force failed (incorrect Tgraph)\n"
(Try BoundaryState -> Try BoundaryState)
-> Try BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Try BoundaryState
forall a. Forcible a => a -> Try a
tryForce (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
covers2 :: [BoundaryState]
covers2 = (BoundaryState -> [BoundaryState])
-> [BoundaryState] -> [BoundaryState]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BoundaryState -> [BoundaryState]
boundaryVCovering [BoundaryState]
covers1
gcovers :: [Tgraph]
gcovers = (BoundaryState -> Tgraph) -> [BoundaryState] -> [Tgraph]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundaryState -> Tgraph
recoverGraph [BoundaryState]
covers2
g0 :: Tgraph
g0 = [Tgraph] -> Tgraph
forall a. HasCallStack => [a] -> a
head [Tgraph]
gcovers
others :: [Tgraph]
others = [Tgraph] -> [Tgraph]
forall a. HasCallStack => [a] -> [a]
tail [Tgraph]
gcovers
fcs :: [TileFace]
fcs = ([TileFace] -> [TileFace] -> [TileFace])
-> [TileFace] -> [[TileFace]] -> [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Tgraph -> [TileFace]
faces Tgraph
g0) ([[TileFace]] -> [TileFace]) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Tgraph -> [TileFace]) -> [Tgraph] -> [[TileFace]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tgraph -> [TileFace]
g0Intersect [Tgraph]
others
de :: Dedge
de = Tgraph -> Dedge
defaultAlignment Tgraph
g
g0Intersect :: Tgraph -> [TileFace]
g0Intersect Tgraph
g1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Tgraph
g1,Dedge
de)
drawEmpire :: Renderable (Path V2 Double) b =>
TrackedTgraph -> Diagram2D b
drawEmpire :: forall b.
Renderable (Path V2 Double) b =>
TrackedTgraph -> Diagram2D b
drawEmpire =
[VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b
forall b. [VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b
drawTrackedTgraph [ Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
ultraThin (Diagram2D b -> Diagram2D b)
-> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw
, Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin (Diagram2D b -> Diagram2D b)
-> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> Colour Double -> VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
Colour Double -> Colour Double -> a -> Diagram2D b
fillDK Colour Double
forall a. (Ord a, Floating a) => Colour a
lightgrey Colour Double
forall a. (Ord a, Floating a) => Colour a
lightgrey
, Measure Double -> Diagram2D b -> Diagram2D b
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin (Diagram2D b -> Diagram2D b)
-> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> Diagram2D b -> Diagram2D b
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
red (Diagram2D b -> Diagram2D b)
-> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
a -> Diagram2D b
draw
]
showEmpire1 :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
showEmpire1 :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
showEmpire1 = TrackedTgraph -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
TrackedTgraph -> Diagram2D b
drawEmpire (TrackedTgraph -> Diagram2D b)
-> (Tgraph -> TrackedTgraph) -> Tgraph -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> TrackedTgraph
empire1
showEmpire2 :: Renderable (Path V2 Double) b =>
Tgraph -> Diagram2D b
showEmpire2 :: forall b. Renderable (Path V2 Double) b => Tgraph -> Diagram2D b
showEmpire2 = TrackedTgraph -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
TrackedTgraph -> Diagram2D b
drawEmpire (TrackedTgraph -> Diagram2D b)
-> (Tgraph -> TrackedTgraph) -> Tgraph -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> TrackedTgraph
empire2
superForce:: Forcible a => a -> a
superForce :: forall a. Forcible a => a -> a
superForce a
g = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> Try a -> a
forall a b. (a -> b) -> a -> b
$ a -> Try a
forall a. Forcible a => a -> Try a
trySuperForce a
g
trySuperForce:: Forcible a => a -> Try a
trySuperForce :: forall a. Forcible a => a -> Try a
trySuperForce = (ForceState -> Try ForceState) -> a -> Try a
forall a.
Forcible a =>
(ForceState -> Try ForceState) -> a -> Try a
tryFSOp ForceState -> Try ForceState
trySuperForceFS where
trySuperForceFS :: ForceState -> Try ForceState
trySuperForceFS :: ForceState -> Try ForceState
trySuperForceFS ForceState
fs =
do ForceState
forcedFS <- String -> Try ForceState -> Try ForceState
forall a. String -> Try a -> Try a
onFail String
"trySuperForceFS: force failed (incorrect Tgraph)\n" (Try ForceState -> Try ForceState)
-> Try ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$
ForceState -> Try ForceState
forall a. Forcible a => a -> Try a
tryForce ForceState
fs
case BoundaryState -> [(Dedge, HalfTileLabel)]
singleChoiceEdges (BoundaryState -> [(Dedge, HalfTileLabel)])
-> BoundaryState -> [(Dedge, HalfTileLabel)]
forall a b. (a -> b) -> a -> b
$ ForceState -> BoundaryState
boundaryState ForceState
forcedFS of
[] -> ForceState -> Try ForceState
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ForceState
forcedFS
((Dedge, HalfTileLabel)
elpr:[(Dedge, HalfTileLabel)]
_) -> do ForceState
extended <- (Dedge, HalfTileLabel) -> ForceState -> Try ForceState
forall {a} {rep}. Forcible a => (Dedge, HalfTile rep) -> a -> Try a
addSingle (Dedge, HalfTileLabel)
elpr ForceState
forcedFS
ForceState -> Try ForceState
trySuperForceFS ForceState
extended
addSingle :: (Dedge, HalfTile rep) -> a -> Try a
addSingle (Dedge
e,HalfTile rep
l) a
fs = if HalfTile rep -> Bool
forall rep. HalfTile rep -> Bool
isDart HalfTile rep
l then Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfDart Dedge
e a
fs else Dedge -> a -> Try a
forall a. Forcible a => Dedge -> a -> Try a
tryAddHalfKite Dedge
e a
fs
singleChoiceEdges :: BoundaryState -> [(Dedge,HalfTileLabel)]
singleChoiceEdges :: BoundaryState -> [(Dedge, HalfTileLabel)]
singleChoiceEdges BoundaryState
bstate = [BoundaryState] -> [Dedge] -> [(Dedge, HalfTileLabel)]
commonToCovering (BoundaryState -> [BoundaryState]
boundaryECovering BoundaryState
bstate) (BoundaryState -> [Dedge]
boundary BoundaryState
bstate)
where
commonToCovering :: [BoundaryState] -> [Dedge] -> [(Dedge, HalfTileLabel)]
commonToCovering [BoundaryState]
bds [Dedge]
edgeList = [Dedge] -> [[HalfTileLabel]] -> [(Dedge, HalfTileLabel)]
forall {b} {a}. Eq b => [a] -> [[b]] -> [(a, b)]
common [Dedge]
edgeList ([[HalfTileLabel]] -> [[HalfTileLabel]]
forall a. [[a]] -> [[a]]
transpose [[HalfTileLabel]]
labellists) where
labellists :: [[HalfTileLabel]]
labellists = (BoundaryState -> [HalfTileLabel])
-> [BoundaryState] -> [[HalfTileLabel]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BoundaryState -> [Dedge] -> [HalfTileLabel]
`reportCover` [Dedge]
edgeList) [BoundaryState]
bds
common :: [a] -> [[b]] -> [(a, b)]
common [] [] = []
common [] ([b]
_:[[b]]
_) = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
"singleChoiceEdges:commonToCovering: label list is longer than edge list"
common (a
_:[a]
_) [] = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
"singleChoiceEdges:commonToCovering: label list is shorter than edge list"
common (a
e:[a]
more) ([b]
ls:[[b]]
lls) = if [b] -> Bool
forall {a}. Eq a => [a] -> Bool
matchingLabels [b]
ls
then (a
e,[b] -> b
forall a. HasCallStack => [a] -> a
head [b]
ls)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[a] -> [[b]] -> [(a, b)]
common [a]
more [[b]]
lls
else [a] -> [[b]] -> [(a, b)]
common [a]
more [[b]]
lls
matchingLabels :: [a] -> Bool
matchingLabels [] = String -> Bool
forall a. HasCallStack => String -> a
error String
"singleChoiceEdges:commonToCovering: empty list of labels"
matchingLabels (a
l:[a]
ls) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
l) [a]
ls
reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel]
reportCover BoundaryState
bd [Dedge]
des = (Dedge -> HalfTileLabel) -> [Dedge] -> [HalfTileLabel]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TileFace -> HalfTileLabel
forall a. HalfTile a -> HalfTileLabel
tileLabel (TileFace -> HalfTileLabel)
-> (Dedge -> TileFace) -> Dedge -> HalfTileLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dedge -> TileFace
getf) [Dedge]
des where
efmap :: Map Dedge TileFace
efmap = [Dedge] -> [TileFace] -> Map Dedge TileFace
dedgesFacesMap [Dedge]
des (BoundaryState -> [TileFace]
allFaces BoundaryState
bd)
getf :: Dedge -> TileFace
getf Dedge
e = TileFace -> (TileFace -> TileFace) -> Maybe TileFace -> TileFace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> TileFace
forall a. HasCallStack => String -> a
error (String -> TileFace) -> String -> TileFace
forall a b. (a -> b) -> a -> b
$ String
"singleChoiceEdges:reportCover: no face found with directed edge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
e)
TileFace -> TileFace
forall a. a -> a
id
(Dedge -> Map Dedge TileFace -> Maybe TileFace
faceForEdge Dedge
e Map Dedge TileFace
efmap)
boundaryLoopsG:: Tgraph -> [[Vertex]]
boundaryLoopsG :: Tgraph -> [[Vertex]]
boundaryLoopsG = [Dedge] -> [[Vertex]]
findLoops ([Dedge] -> [[Vertex]])
-> (Tgraph -> [Dedge]) -> Tgraph -> [[Vertex]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [Dedge]
graphBoundary
boundaryLoops:: BoundaryState -> [[Vertex]]
boundaryLoops :: BoundaryState -> [[Vertex]]
boundaryLoops = [Dedge] -> [[Vertex]]
findLoops ([Dedge] -> [[Vertex]])
-> (BoundaryState -> [Dedge]) -> BoundaryState -> [[Vertex]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundaryState -> [Dedge]
boundary
findLoops:: [Dedge] -> [[Vertex]]
findLoops :: [Dedge] -> [[Vertex]]
findLoops = IntMap Vertex -> [[Vertex]]
collectLoops (IntMap Vertex -> [[Vertex]])
-> ([Dedge] -> IntMap Vertex) -> [Dedge] -> [[Vertex]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dedge] -> IntMap Vertex
forall a. [(Vertex, a)] -> IntMap a
VMap.fromList where
collectLoops :: IntMap Vertex -> [[Vertex]]
collectLoops IntMap Vertex
vmap
| IntMap Vertex -> Bool
forall a. IntMap a -> Bool
VMap.null IntMap Vertex
vmap = []
| Bool
otherwise = Vertex -> IntMap Vertex -> [Vertex] -> [[Vertex]]
chase Vertex
startV IntMap Vertex
vmap [Vertex
startV]
where
(Vertex
startV,Vertex
_) = IntMap Vertex -> Dedge
forall a. IntMap a -> (Vertex, a)
VMap.findMin IntMap Vertex
vmap
chase :: Vertex -> IntMap Vertex -> [Vertex] -> [[Vertex]]
chase Vertex
a IntMap Vertex
vm [Vertex]
sofar
= case Vertex -> IntMap Vertex -> Maybe Vertex
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
a IntMap Vertex
vm of
Just Vertex
b -> Vertex -> IntMap Vertex -> [Vertex] -> [[Vertex]]
chase Vertex
b (Vertex -> IntMap Vertex -> IntMap Vertex
forall a. Vertex -> IntMap a -> IntMap a
VMap.delete Vertex
a IntMap Vertex
vm) (Vertex
bVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
sofar)
Maybe Vertex
Nothing -> if Vertex
a Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
startV
then [Vertex] -> [Vertex]
forall a. [a] -> [a]
reverse [Vertex]
sofar[Vertex] -> [[Vertex]] -> [[Vertex]]
forall a. a -> [a] -> [a]
: IntMap Vertex -> [[Vertex]]
collectLoops IntMap Vertex
vm
else String -> [[Vertex]]
forall a. HasCallStack => String -> a
error (String -> [[Vertex]]) -> String -> [[Vertex]]
forall a b. (a -> b) -> a -> b
$ String
"findLoops (collectLoops): non looping boundary component, starting at "
String -> String -> String
forall a. [a] -> [a] -> [a]
++Vertex -> String
forall a. Show a => a -> String
show Vertex
startVString -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" and finishing at "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
a String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\nwith loop vertices "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show ([Vertex] -> [Vertex]
forall a. [a] -> [a]
reverse [Vertex]
sofar) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
pathFromBoundaryLoops:: VertexLocMap -> [[Vertex]] -> Path V2 Double
pathFromBoundaryLoops :: VertexLocMap -> [[Vertex]] -> Path V2 Double
pathFromBoundaryLoops VertexLocMap
vlocs [[Vertex]]
loops = [Located (Trail V2 Double)]
-> Path
(V [Located (Trail V2 Double)]) (N [Located (Trail V2 Double)])
forall t.
(ToPath t, Metric (V t), OrderedField (N t)) =>
t -> Path (V t) (N t)
toPath ([Located (Trail V2 Double)]
-> Path
(V [Located (Trail V2 Double)]) (N [Located (Trail V2 Double)]))
-> [Located (Trail V2 Double)]
-> Path
(V [Located (Trail V2 Double)]) (N [Located (Trail V2 Double)])
forall a b. (a -> b) -> a -> b
$ ([Vertex] -> Located (Trail V2 Double))
-> [[Vertex]] -> [Located (Trail V2 Double)]
forall a b. (a -> b) -> [a] -> [b]
map ([Point V2 Double] -> Located (Trail V2 Double)
forall {v :: * -> *} {n}.
(Metric v, Floating n, Ord n) =>
[Point v n] -> Located (Trail v n)
locateLoop ([Point V2 Double] -> Located (Trail V2 Double))
-> ([Vertex] -> [Point V2 Double])
-> [Vertex]
-> Located (Trail V2 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> Point V2 Double) -> [Vertex] -> [Point V2 Double]
forall a b. (a -> b) -> [a] -> [b]
map (VertexLocMap
vlocs VertexLocMap -> Vertex -> Point V2 Double
forall a. IntMap a -> Vertex -> a
VMap.!)) [[Vertex]]
loops where
locateLoop :: [Point v n] -> Located (Trail v n)
locateLoop [Point v n]
pts = (Trail v n
-> Point (V (Trail v n)) (N (Trail v n)) -> Located (Trail v n)
forall a. a -> Point (V a) (N a) -> Located a
`at` [Point v n] -> Point v n
forall a. HasCallStack => [a] -> a
head [Point v n]
pts) (Trail v n -> Located (Trail v n))
-> Trail v n -> Located (Trail v n)
forall a b. (a -> b) -> a -> b
$ Trail v n -> Trail v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Trail v n
glueTrail (Trail v n -> Trail v n) -> Trail v n -> Trail v n
forall a b. (a -> b) -> a -> b
$ [Point v n] -> Trail v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Point v n] -> Trail v n
trailFromVertices [Point v n]
pts
data TrackedTgraph = TrackedTgraph{ TrackedTgraph -> Tgraph
tgraph:: Tgraph, TrackedTgraph -> [[TileFace]]
tracked::[[TileFace]]} deriving Vertex -> TrackedTgraph -> String -> String
[TrackedTgraph] -> String -> String
TrackedTgraph -> String
(Vertex -> TrackedTgraph -> String -> String)
-> (TrackedTgraph -> String)
-> ([TrackedTgraph] -> String -> String)
-> Show TrackedTgraph
forall a.
(Vertex -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Vertex -> TrackedTgraph -> String -> String
showsPrec :: Vertex -> TrackedTgraph -> String -> String
$cshow :: TrackedTgraph -> String
show :: TrackedTgraph -> String
$cshowList :: [TrackedTgraph] -> String -> String
showList :: [TrackedTgraph] -> String -> String
Show
newTrackedTgraph :: Tgraph -> TrackedTgraph
newTrackedTgraph :: Tgraph -> TrackedTgraph
newTrackedTgraph Tgraph
g = Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g []
makeTrackedTgraph :: Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph :: Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g [[TileFace]]
trackedlist = TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g, tracked :: [[TileFace]]
tracked = ([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] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` Tgraph -> [TileFace]
faces Tgraph
g) [[TileFace]]
trackedlist}
trackFaces:: TrackedTgraph -> TrackedTgraph
trackFaces :: TrackedTgraph -> TrackedTgraph
trackFaces TrackedTgraph
ttg = TrackedTgraph
ttg{ tracked :: [[TileFace]]
tracked = Tgraph -> [TileFace]
faces (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg }
unionTwoTracked:: TrackedTgraph -> TrackedTgraph
unionTwoTracked :: TrackedTgraph -> TrackedTgraph
unionTwoTracked TrackedTgraph
ttg = TrackedTgraph
ttg{ tracked :: [[TileFace]]
tracked = [[TileFace]]
newTracked } where
newTracked :: [[TileFace]]
newTracked = case TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg of
([TileFace]
a:[TileFace]
b:[[TileFace]]
more) -> [TileFace]
a [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`union` [TileFace]
b[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:[[TileFace]]
more
[[TileFace]]
_ -> String -> [[TileFace]]
forall a. HasCallStack => String -> a
error (String -> [[TileFace]]) -> String -> [[TileFace]]
forall a b. (a -> b) -> a -> b
$ String
"unionTwoTracked: Two tracked lists of faces not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TrackedTgraph -> String
forall a. Show a => a -> String
show TrackedTgraph
ttg String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
instance Forcible TrackedTgraph where
tryFSOpWith :: UpdateGenerator
-> (ForceState -> Try ForceState)
-> TrackedTgraph
-> Try TrackedTgraph
tryFSOpWith UpdateGenerator
ugen ForceState -> Try ForceState
f TrackedTgraph
ttg = do
Tgraph
g' <- UpdateGenerator
-> (ForceState -> Try ForceState) -> Tgraph -> Try Tgraph
forall a.
Forcible a =>
UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith UpdateGenerator
ugen ForceState -> Try ForceState
f (Tgraph -> Try Tgraph) -> Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg
TrackedTgraph -> Try TrackedTgraph
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return TrackedTgraph
ttg{ tgraph :: Tgraph
tgraph = Tgraph
g' }
tryInitFSWith :: UpdateGenerator -> TrackedTgraph -> Try ForceState
tryInitFSWith UpdateGenerator
ugen TrackedTgraph
ttg = UpdateGenerator -> Tgraph -> Try ForceState
forall a. Forcible a => UpdateGenerator -> a -> Try ForceState
tryInitFSWith UpdateGenerator
ugen (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)
tryChangeBoundaryWith :: UpdateGenerator
-> (BoundaryState -> Try BoundaryChange)
-> TrackedTgraph
-> Try TrackedTgraph
tryChangeBoundaryWith UpdateGenerator
ugen BoundaryState -> Try BoundaryChange
f TrackedTgraph
ttg = do
Tgraph
g' <- UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> Tgraph -> Try Tgraph
forall a.
Forcible a =>
UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundaryWith UpdateGenerator
ugen BoundaryState -> Try BoundaryChange
f (Tgraph -> Try Tgraph) -> Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg
TrackedTgraph -> Try TrackedTgraph
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return TrackedTgraph
ttg{ tgraph :: Tgraph
tgraph = Tgraph
g' }
addHalfDartTracked:: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfDartTracked :: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfDartTracked Dedge
e TrackedTgraph
ttg =
TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [TileFace]
fcs[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg}
where
g :: Tgraph
g = TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg
g' :: Tgraph
g' = Dedge -> Tgraph -> Tgraph
forall a. Forcible a => Dedge -> a -> a
addHalfDart Dedge
e Tgraph
g
fcs :: [TileFace]
fcs = Tgraph -> [TileFace]
faces Tgraph
g' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
faces Tgraph
g
addHalfKiteTracked:: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfKiteTracked :: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfKiteTracked Dedge
e TrackedTgraph
ttg =
TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [TileFace]
fcs[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg}
where
g :: Tgraph
g = TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg
g' :: Tgraph
g' = Dedge -> Tgraph -> Tgraph
forall a. Forcible a => Dedge -> a -> a
addHalfKite Dedge
e Tgraph
g
fcs :: [TileFace]
fcs = Tgraph -> [TileFace]
faces Tgraph
g' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
faces Tgraph
g
decomposeTracked :: TrackedTgraph -> TrackedTgraph
decomposeTracked :: TrackedTgraph -> TrackedTgraph
decomposeTracked TrackedTgraph
ttg =
TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [[TileFace]]
tlist}
where
g :: Tgraph
g = TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg
g' :: Tgraph
g' = [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
newFaces
newVFor :: Map Dedge Vertex
newVFor = Tgraph -> Map Dedge Vertex
phiVMap Tgraph
g
newFaces :: [TileFace]
newFaces = (TileFace -> [TileFace]) -> [TileFace] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map Dedge Vertex -> TileFace -> [TileFace]
decompFace Map Dedge Vertex
newVFor) (Tgraph -> [TileFace]
faces Tgraph
g)
tlist :: [[TileFace]]
tlist = ([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]) -> [TileFace] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map Dedge Vertex -> TileFace -> [TileFace]
decompFace Map Dedge Vertex
newVFor)) (TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg)
drawTrackedTgraph :: [VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b
drawTrackedTgraph :: forall b. [VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b
drawTrackedTgraph [VPatch -> Diagram2D b]
drawList TrackedTgraph
ttg = [Diagram2D b] -> Diagram2D b
forall a. Monoid a => [a] -> a
mconcat ([Diagram2D b] -> Diagram2D b) -> [Diagram2D b] -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ [Diagram2D b] -> [Diagram2D b]
forall a. [a] -> [a]
reverse ([Diagram2D b] -> [Diagram2D b]) -> [Diagram2D b] -> [Diagram2D b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> Diagram2D b) -> VPatch -> Diagram2D b)
-> [VPatch -> Diagram2D b] -> [VPatch] -> [Diagram2D b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram2D b]
drawList [VPatch]
vpList where
vp :: VPatch
vp = Tgraph -> VPatch
makeVP (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)
untracked :: [TileFace]
untracked = VPatch -> [TileFace]
vpFaces VPatch
vp [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg)
vpList :: [VPatch]
vpList = ([TileFace] -> VPatch) -> [[TileFace]] -> [VPatch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp) ([TileFace]
untracked[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg) [VPatch] -> [VPatch] -> [VPatch]
forall a. [a] -> [a] -> [a]
++ VPatch -> [VPatch]
forall a. a -> [a]
repeat VPatch
vp
drawTrackedTgraphRotated :: [VPatch -> Diagram2D b] -> Angle Double -> TrackedTgraph -> Diagram2D b
drawTrackedTgraphRotated :: forall b.
[VPatch -> Diagram2D b]
-> Angle Double -> TrackedTgraph -> Diagram2D b
drawTrackedTgraphRotated [VPatch -> Diagram2D b]
drawList Angle Double
a TrackedTgraph
ttg = [Diagram2D b] -> Diagram2D b
forall a. Monoid a => [a] -> a
mconcat ([Diagram2D b] -> Diagram2D b) -> [Diagram2D b] -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ [Diagram2D b] -> [Diagram2D b]
forall a. [a] -> [a]
reverse ([Diagram2D b] -> [Diagram2D b]) -> [Diagram2D b] -> [Diagram2D b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> Diagram2D b) -> VPatch -> Diagram2D b)
-> [VPatch -> Diagram2D b] -> [VPatch] -> [Diagram2D b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram2D b]
drawList [VPatch]
vpList where
vp :: VPatch
vp = Angle Double -> VPatch -> VPatch
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle Double
a (VPatch -> VPatch) -> VPatch -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> VPatch
makeVP (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)
untracked :: [TileFace]
untracked = VPatch -> [TileFace]
vpFaces VPatch
vp [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg)
vpList :: [VPatch]
vpList = ([TileFace] -> VPatch) -> [[TileFace]] -> [VPatch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp) ([TileFace]
untracked[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg) [VPatch] -> [VPatch] -> [VPatch]
forall a. [a] -> [a] -> [a]
++ VPatch -> [VPatch]
forall a. a -> [a]
repeat VPatch
vp
drawTrackedTgraphAligned :: [VPatch -> Diagram2D b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram2D b
drawTrackedTgraphAligned :: forall b.
[VPatch -> Diagram2D b] -> Dedge -> TrackedTgraph -> Diagram2D b
drawTrackedTgraphAligned [VPatch -> Diagram2D b]
drawList (Vertex
a,Vertex
b) TrackedTgraph
ttg = [Diagram2D b] -> Diagram2D b
forall a. Monoid a => [a] -> a
mconcat ([Diagram2D b] -> Diagram2D b) -> [Diagram2D b] -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ [Diagram2D b] -> [Diagram2D b]
forall a. [a] -> [a]
reverse ([Diagram2D b] -> [Diagram2D b]) -> [Diagram2D b] -> [Diagram2D b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> Diagram2D b) -> VPatch -> Diagram2D b)
-> [VPatch -> Diagram2D b] -> [VPatch] -> [Diagram2D b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram2D b]
drawList [VPatch]
vpList where
vp :: VPatch
vp = Dedge -> Tgraph -> VPatch
makeAlignedVP (Vertex
a,Vertex
b) (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)
untracked :: [TileFace]
untracked = VPatch -> [TileFace]
vpFaces VPatch
vp [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg)
vpList :: [VPatch]
vpList = ([TileFace] -> VPatch) -> [[TileFace]] -> [VPatch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp) ([TileFace]
untracked[TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
:TrackedTgraph -> [[TileFace]]
tracked TrackedTgraph
ttg) [VPatch] -> [VPatch] -> [VPatch]
forall a. [a] -> [a] -> [a]
++ VPatch -> [VPatch]
forall a. a -> [a]
repeat VPatch
vp