{-|
Module      : Tgraph.Extras
Description : Additional Tgraph functions
Copyright   : (c) Chris Reade, 2024
License     : BSD-style
Maintainer  : chrisreade@mac.com
Stability   : experimental

This module defines several functions for producing overlaid diagrams for Tgraphs
(including smart drawing) and combinations such as compForce,
experimental combinations such as
boundaryECovering, boundaryVCovering, empire1, empire2, superForce, boundaryLoopsG.

It also defines experimental TrackedTgraphs (used for tracking subsets of faces of a Tgraph).

-}

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch
{-# LANGUAGE TupleSections             #-}

module Tgraph.Extras
  ( smart
  , boundaryJoinFaces
  , drawBoundaryJoins
  , drawJoinsFor
  , smartdraw
  , restrictSmart
  , smartRotateBefore
  , smartAlignBefore
    -- * Overlaid drawing tools for Tgraphs
  , drawPCompose
  , drawForce
  , drawSuperForce
  , drawWithMax
  , addBoundaryAfter
  , drawCommonFaces
  , emphasizeFaces
    -- * Combining force, compose, decompose
  , composeK
  , compForce
  , allCompForce
  , maxCompForce
--  , forceDecomp
  , allForceDecomps
    -- * Boundary Covering and Empires
  , forcedBoundaryECovering
  , forcedBoundaryVCovering
  , boundaryECovering
  , boundaryVCovering
  , tryDartAndKite
  , tryDartAndKiteForced
  , tryDartAndKiteF
  , tryCheckCasesDKF
  , checkCasesDKF
  , boundaryEdgeSet
  , commonBdry
  , boundaryVertexSet
  , internalVertexSet
  , drawFBCovering
  , empire1
  , empire2
  , empire2Plus
  , drawEmpire
  , showEmpire1
  , showEmpire2
    -- * Super Force with boundary edge covers
  , superForce
  , trySuperForce
  , singleChoiceEdges
    -- * Boundary face graph
  , tryBoundaryFaceGraph
    -- * Boundary loops
  , boundaryLoops
  -- , findLoops
  , pathFromBoundaryLoops
    -- * TrackedTgraphs
  , TrackedTgraph(..)
  , newTrackedTgraph
  , makeTrackedTgraph
  , trackFaces
  , unionTwoTracked
    -- * Forcing and Decomposing TrackedTgraphs
  , addHalfDartTracked
  , addHalfKiteTracked
  , decomposeTracked
    -- *  Drawing TrackedTgraphs
  , drawTrackedTgraph
  , drawTrackedTgraphRotated
  , drawTrackedTgraphAligned
  ) where

import TileLib
import Tgraph.Prelude
import Tgraph.Decompose
import Tgraph.Compose
import Tgraph.Relabelling
import Tgraph.Force

import Diagrams.Prelude hiding (union)
import Data.List (intersect, union, (\\), find, foldl', transpose)
import qualified Data.Set as Set  (Set,fromList,null,intersection,deleteFindMin)-- used for boundary covers
import qualified Data.IntSet as IntSet (fromList,member,(\\)) -- for boundary vertex set
import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops
import qualified Data.Maybe (fromMaybe)

-- |smart dr g - uses VPatch drawing function dr after converting g to a VPatch
-- It will add boundary joins regardless of the drawing function.
-- Examples:
-- 
-- smart draw g
--
-- smart (labelled draw) g
--
-- smart (labelSize normal draw) g
smart :: OKBackend b =>
         (VPatch -> Diagram b) -> Tgraph -> Diagram b
smart :: forall b.
OKBackend b =>
(VPatch -> Diagram b) -> Tgraph -> Diagram b
smart VPatch -> Diagram b
dr Tgraph
g = Tgraph -> VPatch -> Diagram b
forall b. OKBackend b => Tgraph -> VPatch -> Diagram b
drawBoundaryJoins Tgraph
g VPatch
vp QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram b
dr VPatch
vp
  where vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g

-- |select the halftile faces of a Tgraph with a join edge on the boundary.
-- Useful for drawing join edges only on the boundary.
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]
forall a. HasFaces a => a -> [Dedge]
boundary BoundaryState
bdry where
    bdry :: BoundaryState
bdry = Tgraph -> BoundaryState
makeBoundaryState Tgraph
g

-- |draw boundary join edges of a Tgraph using a given VPatch
drawBoundaryJoins :: OKBackend b => Tgraph -> VPatch -> Diagram b
drawBoundaryJoins :: forall b. OKBackend b => Tgraph -> VPatch -> Diagram b
drawBoundaryJoins Tgraph
g VPatch
vp = VPatch -> [Dedge] -> QDiagram b (V b) (N b) Any
forall b. OKBackend b => VPatch -> [Dedge] -> Diagram b
drawEdgesVP VPatch
vp ((TileFace -> Dedge) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
map TileFace -> Dedge
joinE ([TileFace] -> [Dedge]) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
boundaryJoinFaces Tgraph
g) QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall c. (HasStyle c, N c ~ Double) => c -> c
joinDashing

-- |Given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces.
-- Will raise an error if any vertex in the faces does not have a location in the VPatch.
drawJoinsFor::  OKBackend b =>
                [TileFace] -> VPatch -> Diagram b
drawJoinsFor :: forall b. OKBackend b => [TileFace] -> VPatch -> Diagram b
drawJoinsFor [TileFace]
fcs VPatch
vp = (Piece -> QDiagram b (V b) (N b) Any)
-> VPatch -> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
(Piece -> Diagram b) -> VPatch -> Diagram b
forall a b.
(Drawable a, OKBackend b) =>
(Piece -> Diagram b) -> a -> Diagram b
drawWith Piece -> QDiagram b (V b) (N b) Any
forall b. OKBackend b => Piece -> Diagram b
dashjOnly (VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp [TileFace]
fcs)

-- |same as draw except adding dashed lines on boundary join edges. 
smartdraw :: OKBackend b => Tgraph -> Diagram b
smartdraw :: forall b. OKBackend b => Tgraph -> Diagram b
smartdraw = (VPatch -> QDiagram b (V b) (N b) Any)
-> Tgraph -> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
(VPatch -> Diagram b) -> Tgraph -> Diagram b
smart VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw

-- |restrictSmart g dr vp - assumes vp has locations for vertices in g.
-- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins.
-- This can be used instead of smart when an appropriate vp is already available.
restrictSmart :: OKBackend b =>
                 Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart :: forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> Diagram b
dr VPatch
vp = Tgraph -> VPatch -> Diagram b
forall b. OKBackend b => Tgraph -> VPatch -> Diagram b
drawBoundaryJoins Tgraph
g VPatch
rvp QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram 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]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g

-- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore.
-- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g.
--
-- Example: smartRotateBefore (labelled draw) angle g
smartRotateBefore :: OKBackend b =>
                     (VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b
smartRotateBefore :: forall b.
OKBackend b =>
(VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b
smartRotateBefore VPatch -> Diagram b
vfun Angle Double
angle Tgraph
g = (VPatch -> QDiagram b V2 Double Any)
-> Angle Double -> Tgraph -> QDiagram b V2 Double Any
forall a. (VPatch -> a) -> Angle Double -> Tgraph -> a
rotateBefore (Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> Diagram b
vfun) Angle Double
angle Tgraph
g

-- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore.
-- Uses vfun to produce a Diagram after converting g to an aligned VPatch but also adds the dashed boundary join edges of g.
-- 
-- Example: smartAlignBefore (labelled draw) (a,b) g
smartAlignBefore :: OKBackend b =>
                    (VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b
smartAlignBefore :: forall b.
OKBackend b =>
(VPatch -> Diagram b) -> Dedge -> Tgraph -> Diagram b
smartAlignBefore VPatch -> Diagram b
vfun (Vertex
a,Vertex
b) Tgraph
g = (VPatch -> QDiagram b V2 Double Any)
-> Dedge -> Tgraph -> QDiagram b V2 Double Any
forall a. (VPatch -> a) -> Dedge -> Tgraph -> a
alignBefore (Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> Diagram b
vfun) (Vertex
a,Vertex
b) Tgraph
g

-- |applies partCompose to a Tgraph g, then draws the composed graph along with the remainder faces (in lime).
-- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.)
-- This will raise an error if the composed faces have a crossing boundary or are disconnected.
drawPCompose :: OKBackend b =>
                Tgraph -> Diagram b
drawPCompose :: forall b. OKBackend b => Tgraph -> Diagram b
drawPCompose Tgraph
g =
    Tgraph
-> (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch
-> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g' VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw VPatch
vp
    QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
drawj (VPatch -> [TileFace] -> VPatch
subVP VPatch
vp [TileFace]
remainder) QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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 g is a diagram showing the argument g in red overlayed on force g.
-- It adds dashed join edges on the boundary of g.
-- It will raise an error if the force fails with an incorrect/stuck Tgraph
drawForce :: OKBackend b =>
             Tgraph -> Diagram b
drawForce :: forall b. OKBackend b => Tgraph -> Diagram b
drawForce Tgraph
g =
    Tgraph
-> (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch
-> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw VPatch
vp QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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 QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium
    QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram 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 g is a diagram showing the argument g in red overlayed on force g in black
-- overlaid on superForce g in blue.
-- It adds dashed join edges on the boundary of g.
-- It will raise an error if the initial force fails with an incorrect/stuck Tgraph
drawSuperForce :: OKBackend b =>
                  Tgraph -> Diagram b
drawSuperForce :: forall b. OKBackend b => Tgraph -> Diagram b
drawSuperForce Tgraph
g = (QDiagram b (V b) (N b) Any
QDiagram b V2 Double Any
dg QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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) QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> QDiagram b (V b) (N b) Any
QDiagram b V2 Double Any
dfg QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> (QDiagram b (V b) (N b) Any
QDiagram b V2 Double Any
dsfg QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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
    fg :: Tgraph
fg = Tgraph -> Tgraph
forall a. Forcible a => a -> a
force Tgraph
g
    sfg :: Tgraph
sfg = Tgraph -> Tgraph
forall a. Forcible a => a -> a
superForce Tgraph
fg
    vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
sfg
    dfg :: QDiagram b (V b) (N b) Any
dfg = VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch -> QDiagram b (V b) (N b) Any
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
selectFacesVP VPatch
vp (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
fg [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g) -- restrictSmart (force g) draw vp
    dg :: QDiagram b (V b) (N b) Any
dg = Tgraph
-> (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch
-> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw VPatch
vp
    dsfg :: QDiagram b (V b) (N b) Any
dsfg = VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch -> QDiagram b (V b) (N b) Any
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
selectFacesVP VPatch
vp (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
sfg [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
fg)

-- | drawWithMax g - draws g and overlays the maximal composition of force g in red.
-- This relies on g and all compositions of force g having vertices in force g.
-- It will raise an error if forcing fails (g is an incorrect Tgraph).
drawWithMax :: OKBackend b =>
               Tgraph -> Diagram b
drawWithMax :: forall b. OKBackend b => Tgraph -> Diagram b
drawWithMax Tgraph
g =  (QDiagram b (V b) (N b) Any
QDiagram b V2 Double Any
dmax QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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 QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
medium) QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> QDiagram b (V b) (N b) Any
QDiagram b V2 Double Any
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 -- duplicates force to get the locations of vertices in the forced Tgraph
    dg :: QDiagram b (V b) (N b) Any
dg = Tgraph
-> (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch
-> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b
restrictSmart Tgraph
g VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw VPatch
vp
    maxg :: Forced Tgraph
maxg = Tgraph -> Forced Tgraph
maxCompForce Tgraph
g
    dmax :: QDiagram b (V b) (N b) Any
dmax = VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw (VPatch -> QDiagram b (V b) (N b) Any)
-> VPatch -> QDiagram b (V b) (N b) Any
forall a b. (a -> b) -> a -> b
$ VPatch -> [TileFace] -> VPatch
subVP VPatch
vp ([TileFace] -> VPatch) -> [TileFace] -> VPatch
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall a b. (a -> b) -> a -> b
$ Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF Forced Tgraph
maxg

-- |addBoundaryAfter f g - displaying the boundary of a Tgraph g in lime (overlaid on g drawn with f).
addBoundaryAfter :: OKBackend b =>
                    (VPatch ->  Diagram b) -> Tgraph ->  Diagram b
addBoundaryAfter :: forall b.
OKBackend b =>
(VPatch -> Diagram b) -> Tgraph -> Diagram b
addBoundaryAfter VPatch -> Diagram b
f Tgraph
g =  (VPatch -> [Dedge] -> Diagram b
forall b. OKBackend b => VPatch -> [Dedge] -> Diagram b
drawEdgesVP VPatch
vp [Dedge]
edges QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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) QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> VPatch -> Diagram b
f VPatch
vp where
    vp :: VPatch
vp = Tgraph -> VPatch
makeVP Tgraph
g
    edges :: [Dedge]
edges = Tgraph -> [Dedge]
forall a. HasFaces a => a -> [Dedge]
boundary Tgraph
g

-- |drawCommonFaces (g1,e1) (g2,e2) uses commonFaces (g1,e1) (g2,e2) to find the common faces
-- and emphasizes them on the background g1.
drawCommonFaces :: OKBackend b =>
                   (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram b
drawCommonFaces :: forall b.
OKBackend b =>
(Tgraph, Dedge) -> (Tgraph, Dedge) -> Diagram b
drawCommonFaces (Tgraph
g1,Dedge
e1) (Tgraph
g2,Dedge
e2) = [TileFace] -> Tgraph -> QDiagram b (V b) (N b) Any
forall b. OKBackend b => [TileFace] -> Tgraph -> Diagram b
emphasizeFaces ((Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g1,Dedge
e1) (Tgraph
g2,Dedge
e2)) Tgraph
g1

-- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background draw g.
emphasizeFaces :: OKBackend b =>
                  [TileFace] -> Tgraph -> Diagram b
emphasizeFaces :: forall b. OKBackend b => [TileFace] -> Tgraph -> Diagram b
emphasizeFaces [TileFace]
fcs Tgraph
g =  (VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
drawj VPatch
emphvp QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin) QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> (VPatch -> QDiagram b (V b) (N b) Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw VPatch
vp QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)


-- | For illustrating an unsound version of composition which defaults to kites when there are unknown
-- dart wings on the boundary.
-- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph.
-- E.g. when applied to force queenGraph.
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 = largeKiteCentres dwInfo ++ unknowns dwInfo
                        , 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 is a partial function similar to (compose . force),
-- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph).
-- However it produces an explicitly Forced Tgraph, 
-- and is more efficient because it omits the check for connected, and no crossing boundaries
-- (and uses getDartWingInfoForced instead of getDartWingInfo)
-- This relies on a proof that composition does not need to be checked for a forced Tgraph.
-- (We also have a proof that the result must be a forced Tgraph when the initial force succeeds.)
-- This will raise an error if the initial force fails with an incorrect Tgraph.
compForce:: Tgraph -> Forced Tgraph
compForce :: Tgraph -> Forced Tgraph
compForce = Forced Tgraph -> Forced Tgraph
composeF (Forced Tgraph -> Forced Tgraph)
-> (Tgraph -> Forced Tgraph) -> Tgraph -> Forced Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Forced Tgraph
forall a. Forcible a => a -> Forced a
forceF


-- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g.
-- It will raise an error if the initial force fails with an incorrect Tgraph.
-- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds).
-- The definition relies on (1) a proof that the composition of a forced Tgraph is forced  and
-- (2) a proof that composition does not need to be checked for a forced Tgraph.
allCompForce:: Tgraph -> [Forced Tgraph]
allCompForce :: Tgraph -> [Forced Tgraph]
allCompForce = (Forced Tgraph -> Bool) -> [Forced Tgraph] -> [Forced Tgraph]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Forced Tgraph -> Bool) -> Forced Tgraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Bool
forall a. HasFaces a => a -> Bool
nullFaces (Tgraph -> Bool)
-> (Forced Tgraph -> Tgraph) -> Forced Tgraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF) ([Forced Tgraph] -> [Forced Tgraph])
-> (Tgraph -> [Forced Tgraph]) -> Tgraph -> [Forced Tgraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Forced Tgraph -> Forced Tgraph)
-> Forced Tgraph -> [Forced Tgraph]
forall a. (a -> a) -> a -> [a]
iterate Forced Tgraph -> Forced Tgraph
composeF (Forced Tgraph -> [Forced Tgraph])
-> (Tgraph -> Forced Tgraph) -> Tgraph -> [Forced Tgraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> Forced Tgraph
forall a. Forcible a => a -> Forced a
forceF


-- |maxCompForce g produces the maximally composed (non-null) Tgraph starting from force g, provided g is not the emptyTgraph
-- and just the emptyTgraph otherwise.
-- It will raise an error if the initial force fails with an incorrect Tgraph.
maxCompForce:: Tgraph -> Forced Tgraph
maxCompForce :: Tgraph -> Forced Tgraph
maxCompForce Tgraph
g | Tgraph -> Bool
forall a. HasFaces a => a -> Bool
nullFaces Tgraph
g = Tgraph -> Forced Tgraph
forall a. a -> Forced a
labelAsForced Tgraph
g
               | Bool
otherwise = [Forced Tgraph] -> Forced Tgraph
forall a. HasCallStack => [a] -> a
last ([Forced Tgraph] -> Forced Tgraph)
-> [Forced Tgraph] -> Forced Tgraph
forall a b. (a -> b) -> a -> b
$ Tgraph -> [Forced Tgraph]
allCompForce Tgraph
g


-- | allForceDecomps g - produces an infinite list (starting with g) 
-- of forced decompositions of g (raising an error if a force fails with an incorrect Tgraph).
allForceDecomps:: Tgraph -> [Tgraph]
allForceDecomps :: Tgraph -> [Tgraph]
allForceDecomps = (Tgraph -> Tgraph) -> Tgraph -> [Tgraph]
forall a. (a -> a) -> a -> [a]
iterate (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)

{-| forcedBoundaryECovering g - produces a list of all boundary covers of force g.
Each boundary cover is a forced Tgraph that extends force g and covers the entire boundary directed edges of force g.
(So the boundary of force g is entirely internal edges in each boundary cover).
The covers include all possible ways faces can be added on the boundary of force g
except combinations which are found to be incorrect.
The common faces of the covers constitute an empire (level 1) of g.
This will raise an error if the initial force fails with an incorrect/stuck Tgraph.
-}
forcedBoundaryECovering:: Tgraph -> [Forced Tgraph]
forcedBoundaryECovering :: Tgraph -> [Forced Tgraph]
forcedBoundaryECovering Tgraph
g = Forced BoundaryState -> Forced Tgraph
recoverGraphF (Forced BoundaryState -> Forced Tgraph)
-> [Forced BoundaryState] -> [Forced Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering Forced BoundaryState
gforcedBdry where
     gforcedBdry :: Forced BoundaryState
gforcedBdry = Try (Forced BoundaryState) -> Forced BoundaryState
forall a. Try a -> a
runTry (Try (Forced BoundaryState) -> Forced BoundaryState)
-> Try (Forced BoundaryState) -> Forced BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a. String -> Try a -> Try a
onFail String
"forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" (Try (Forced BoundaryState) -> Try (Forced BoundaryState))
-> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$
                             BoundaryState -> Try (Forced BoundaryState)
forall a. Forcible a => a -> Try (Forced a)
tryForceF (BoundaryState -> Try (Forced BoundaryState))
-> BoundaryState -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g

{-| forcedBoundaryVCovering g - produces a list of all boundary covers of force g as with
forcedBoundaryECovering g but covering all boundary vertices rather than just boundary edges.
This will raise an error if the initial force fails with an incorrect/stuck Tgraph.                      
-}
forcedBoundaryVCovering:: Tgraph -> [Forced Tgraph]
forcedBoundaryVCovering :: Tgraph -> [Forced Tgraph]
forcedBoundaryVCovering Tgraph
g = Forced BoundaryState -> Forced Tgraph
recoverGraphF (Forced BoundaryState -> Forced Tgraph)
-> [Forced BoundaryState] -> [Forced Tgraph]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forced BoundaryState -> [Forced BoundaryState]
boundaryVCovering Forced BoundaryState
gforcedBdry where
     gforcedBdry :: Forced BoundaryState
gforcedBdry = Try (Forced BoundaryState) -> Forced BoundaryState
forall a. Try a -> a
runTry (Try (Forced BoundaryState) -> Forced BoundaryState)
-> Try (Forced BoundaryState) -> Forced BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a. String -> Try a -> Try a
onFail String
"forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" (Try (Forced BoundaryState) -> Try (Forced BoundaryState))
-> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$
                             BoundaryState -> Try (Forced BoundaryState)
forall a. Forcible a => a -> Try (Forced a)
tryForceF (BoundaryState -> Try (Forced BoundaryState))
-> BoundaryState -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g

{-| boundaryECovering - for an explicitly Forced BoundaryState fbd,
produces a list of all possible covers of the boundary directed edges in fbd.
A cover is an explicitly Forced extension (of fbd) such that the original boundary directed edges of fbd are all internal edges.
Extensions are made by repeatedly adding a face to any edge on the original boundary that is still on the boundary
and forcing, repeating this until the orignal boundary is all internal edges.
The resulting covers account for all possible ways the boundary can be extended.
This can raise an error if both choices on a boundary edge fail when forced (using atLeastOne).

In which case, fbd represents an important counter example to the hypothesis that
successfully forced forcibles are correct.
-}
boundaryECovering:: Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering :: Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering Forced BoundaryState
forcedbs = [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [(Forced BoundaryState
forcedbs, BoundaryState -> Set Dedge
forall a. HasFaces a => a -> Set Dedge
boundaryEdgeSet (Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
forcedbs))] where
  covers:: [(Forced BoundaryState, Set.Set Dedge)] -> [Forced BoundaryState]
  covers :: [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [] = []
  covers ((Forced BoundaryState
fbs,Set Dedge
es):[(Forced BoundaryState, Set Dedge)]
opens)
    | Set Dedge -> Bool
forall a. Set a -> Bool
Set.null Set Dedge
es = Forced BoundaryState
fbsForced BoundaryState
-> [Forced BoundaryState] -> [Forced BoundaryState]
forall a. a -> [a] -> [a]
:[(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [(Forced BoundaryState, Set Dedge)]
opens -- bs is a completed cover
    | Bool
otherwise = [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers ([(Forced BoundaryState, Set Dedge)]
newcases [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++ [(Forced 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 :: [(Forced BoundaryState, Set Dedge)]
newcases = (Forced BoundaryState -> (Forced BoundaryState, Set Dedge))
-> [Forced BoundaryState] -> [(Forced BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Forced BoundaryState
b -> (Forced BoundaryState
b, Set Dedge -> BoundaryState -> Set Dedge
forall a. HasFaces a => Set Dedge -> a -> Set Dedge
commonBdry Set Dedge
des (Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
b)))
                             (Try [Forced BoundaryState] -> [Forced BoundaryState]
forall a. Try a -> a
runTry (Try [Forced BoundaryState] -> [Forced BoundaryState])
-> Try [Forced BoundaryState] -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ Dedge -> Forced BoundaryState -> Try [Forced BoundaryState]
forall a.
(Forcible a, Show a) =>
Dedge -> Forced a -> Try [Forced a]
tryCheckCasesDKF Dedge
de Forced BoundaryState
fbs)


-- |Make a set of the directed boundary edges from tilefaces
boundaryEdgeSet:: HasFaces a => a -> Set.Set Dedge
boundaryEdgeSet :: forall a. HasFaces a => a -> Set Dedge
boundaryEdgeSet = [Dedge] -> Set Dedge
forall a. Ord a => [a] -> Set a
Set.fromList ([Dedge] -> Set Dedge) -> (a -> [Dedge]) -> a -> Set Dedge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Dedge]
forall a. HasFaces a => a -> [Dedge]
boundary

-- | commonBdry des a - returns those directed edges in des that are boundary directed edges of a
commonBdry:: HasFaces a => Set.Set Dedge -> a -> Set.Set Dedge
commonBdry :: forall a. HasFaces a => Set Dedge -> a -> Set Dedge
commonBdry Set Dedge
des a
a = Set Dedge
des Set Dedge -> Set Dedge -> Set Dedge
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` a -> Set Dedge
forall a. HasFaces a => a -> Set Dedge
boundaryEdgeSet a
a

{-| boundaryVCovering fbd - similar to boundaryECovering, but produces a list of all possible covers of 
    the boundary vertices in fbd (rather than just boundary edges).
    This can raise an error if both choices on a boundary edge fail when forced (using atLeastOne).
 -}
boundaryVCovering:: Forced BoundaryState -> [Forced BoundaryState]
boundaryVCovering :: Forced BoundaryState -> [Forced BoundaryState]
boundaryVCovering Forced BoundaryState
fbd = [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [(Forced BoundaryState
fbd, Set Dedge
startbds)] where
  startbds :: Set Dedge
startbds = BoundaryState -> Set Dedge
forall a. HasFaces a => a -> Set Dedge
boundaryEdgeSet (BoundaryState -> Set Dedge) -> BoundaryState -> Set Dedge
forall a b. (a -> b) -> a -> b
$ Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
fbd
  startbvs :: VertexSet
startbvs = BoundaryState -> VertexSet
forall a. HasFaces a => a -> VertexSet
boundaryVertexSet (BoundaryState -> VertexSet) -> BoundaryState -> VertexSet
forall a b. (a -> b) -> a -> b
$ Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
fbd
--covers:: [(Forced BoundaryState,Set.Set Dedge)] -> [Forced BoundaryState]
  covers :: [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [] = []
  covers ((Forced BoundaryState
open,Set Dedge
es):[(Forced 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]
forall a. HasFaces a => a -> [Dedge]
boundary (BoundaryState -> [Dedge]) -> BoundaryState -> [Dedge]
forall a b. (a -> b) -> a -> b
$ Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
open) of
        Maybe Dedge
Nothing -> Forced BoundaryState
openForced BoundaryState
-> [Forced BoundaryState] -> [Forced BoundaryState]
forall a. a -> [a] -> [a]
:[(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers [(Forced BoundaryState, Set Dedge)]
opens
        Just Dedge
dedge -> [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers ([(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState])
-> [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ (Forced BoundaryState -> (Forced BoundaryState, Set Dedge))
-> [Forced BoundaryState] -> [(Forced BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Set Dedge
es) (Try [Forced BoundaryState] -> [Forced BoundaryState]
forall a. Try a -> a
runTry (Try [Forced BoundaryState] -> [Forced BoundaryState])
-> Try [Forced BoundaryState] -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ Dedge -> Forced BoundaryState -> Try [Forced BoundaryState]
forall a.
(Forcible a, Show a) =>
Dedge -> Forced a -> Try [Forced a]
tryCheckCasesDKF Dedge
dedge Forced BoundaryState
open) [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++[(Forced BoundaryState, Set Dedge)]
opens
    | Bool
otherwise =  [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
covers ([(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState])
-> [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ (Forced BoundaryState -> (Forced BoundaryState, Set Dedge))
-> [Forced BoundaryState] -> [(Forced BoundaryState, Set Dedge)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Forced BoundaryState
b -> (Forced BoundaryState
b, Set Dedge -> BoundaryState -> Set Dedge
forall a. HasFaces a => Set Dedge -> a -> Set Dedge
commonBdry Set Dedge
des (Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
b))) ([Try (Forced BoundaryState)] -> [Forced BoundaryState]
forall a. [Try a] -> [a]
atLeastOne ([Try (Forced BoundaryState)] -> [Forced BoundaryState])
-> [Try (Forced BoundaryState)] -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$  Dedge -> BoundaryState -> [Try (Forced BoundaryState)]
forall a. Forcible a => Dedge -> a -> [Try (Forced a)]
tryDartAndKiteF Dedge
de (Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
open)) [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
-> [(Forced BoundaryState, Set Dedge)]
forall a. [a] -> [a] -> [a]
++[(Forced 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


-- | returns the set of boundary vertices of a tilefaces
boundaryVertexSet :: HasFaces a => a -> VertexSet
boundaryVertexSet :: forall a. HasFaces a => a -> VertexSet
boundaryVertexSet = [Vertex] -> VertexSet
IntSet.fromList ([Vertex] -> VertexSet) -> (a -> [Vertex]) -> a -> VertexSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Vertex]
forall a. HasFaces a => a -> [Vertex]
boundaryVs

-- | returns the set of internal vertices of a tilefaces
internalVertexSet :: HasFaces a => a -> VertexSet
internalVertexSet :: forall a. HasFaces a => a -> VertexSet
internalVertexSet a
a = a -> VertexSet
forall a. HasFaces a => a -> VertexSet
vertexSet a
a VertexSet -> VertexSet -> VertexSet
IntSet.\\ a -> VertexSet
forall a. HasFaces a => a -> VertexSet
boundaryVertexSet a
a


-- | tryDartAndKite de b - returns the list of (2) results after adding a dart (respectively kite)
-- to edge de of a Forcible b. Each of the results is a Try.
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
    ]

-- | tryDartAndKiteF de b - returns the list of (2) results after adding a dart (respectively kite)
-- to edge de of a Forcible b and then tries forcing.
-- Each of the results is a Try of an explicitly Forced type.
tryDartAndKiteF:: Forcible a => Dedge -> a -> [Try (Forced a)]
tryDartAndKiteF :: forall a. Forcible a => Dedge -> a -> [Try (Forced a)]
tryDartAndKiteF Dedge
de a
b =
    [ String -> Try (Forced a) -> Try (Forced a)
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKiteF: 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 (Forced a) -> Try (Forced a))
-> Try (Forced a) -> Try (Forced 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 (Forced a)) -> Try (Forced a)
forall a b.
Either (String -> String) a
-> (a -> Either (String -> String) b)
-> Either (String -> String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Try (Forced a)
forall a. Forcible a => a -> Try (Forced a)
tryForceF
    , String -> Try (Forced a) -> Try (Forced a)
forall a. String -> Try a -> Try a
onFail (String
"tryDartAndKiteF: 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 (Forced a) -> Try (Forced a))
-> Try (Forced a) -> Try (Forced 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 (Forced a)) -> Try (Forced a)
forall a b.
Either (String -> String) a
-> (a -> Either (String -> String) b)
-> Either (String -> String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Try (Forced a)
forall a. Forcible a => a -> Try (Forced a)
tryForceF
    ]

-- | tryDartAndKiteForced de b - returns the list of (2) results after adding a dart (respectively kite)
-- to edge de of a Forcible b and then tries forcing.
-- Each of the results is a Try.
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 -> String) a
-> (a -> Either (String -> String) b)
-> Either (String -> 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 -> String) a
-> (a -> Either (String -> String) b)
-> Either (String -> 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
    ]

-- | tryCheckCasesDKF dedge fb (where fb is an explicitly forced Forcible
-- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge
-- then tries forcing each result.
-- It returns the list of only the successful Try results provided there is AT LEAST ONE.
-- If there are no successes, this may be an important counter example 
-- and it will return Left with a failure report describing the counter example
-- to the following:
--
-- Hypothesis: A successfully forced Tgraph is correct (a correct tiling).
--
-- (If both legal additions to a boundary edge are incorrect,
-- then the (Forced) Forcible must be incorrect).
tryCheckCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> Try [Forced a]
tryCheckCasesDKF :: forall a.
(Forcible a, Show a) =>
Dedge -> Forced a -> Try [Forced a]
tryCheckCasesDKF Dedge
dedge Forced a
fb = 
    String -> Try [Forced a] -> Try [Forced a]
forall a. String -> Try a -> Try a
onFail (String
"tryCheckCasesDKF: <<< Counter Example Found!! >>>\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nBoth legal extensions to directed edge " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
dedge
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \nare incorrrect for a successfully forced Forcible.\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"This shows a successfully forced forcible can still be incorrect\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"which is a counter example to the hypothesis that successful forcing\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"returns correct tilings.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The incorrect but forced forcible is:\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Forced a -> String
forall a. Show a => a -> String
show Forced a
fb
           )
    (Try [Forced a] -> Try [Forced a])
-> Try [Forced a] -> Try [Forced a]
forall a b. (a -> b) -> a -> b
$ [Try (Forced a)] -> Try [Forced a]
forall a. [Try a] -> Try [a]
tryAtLeastOne ([Try (Forced a)] -> Try [Forced a])
-> [Try (Forced a)] -> Try [Forced a]
forall a b. (a -> b) -> a -> b
$ Dedge -> a -> [Try (Forced a)]
forall a. Forcible a => Dedge -> a -> [Try (Forced a)]
tryDartAndKiteF Dedge
dedge (Forced a -> a
forall a. Forced a -> a
forgetF Forced a
fb)

-- | checkCasesDKF dedge fb (where fb is an explicitly forced Forcible
-- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge
-- then tries forcing each result.
-- It returns the list of only the successful results provided there is AT LEAST ONE.
-- If there are no successes, this may be an important counter example 
-- and it will raise an error describing the counter example
-- to the following:
--
-- Hypothesis: A successfully forced Tgraph is correct (a correct tiling).
--
-- (If both legal additions to a boundary edge are incorrect,
-- then the (Forced) Forcible must be incorrect).
checkCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> [Forced a]
checkCasesDKF :: forall a. (Forcible a, Show a) => Dedge -> Forced a -> [Forced a]
checkCasesDKF Dedge
dedge = Try [Forced a] -> [Forced a]
forall a. Try a -> a
runTry (Try [Forced a] -> [Forced a])
-> (Forced a -> Try [Forced a]) -> Forced a -> [Forced a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dedge -> Forced a -> Try [Forced a]
forall a.
(Forcible a, Show a) =>
Dedge -> Forced a -> Try [Forced a]
tryCheckCasesDKF Dedge
dedge
 
-- |A test function to draw (as a column) the list of covers resulting from forcedBoundaryVCovering
-- for a given Tgraph.
drawFBCovering :: OKBackend b =>
                  Tgraph -> Diagram b
drawFBCovering :: forall b. OKBackend b => Tgraph -> Diagram b
drawFBCovering Tgraph
g = Measure Double -> Diagram b -> Diagram 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 (Diagram b -> Diagram b) -> Diagram b -> Diagram b
forall a b. (a -> b) -> a -> b
$ Double -> [QDiagram b V2 Double Any] -> QDiagram b V2 Double Any
forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
 Monoid' a) =>
n -> [a] -> a
vsep Double
1 (Tgraph -> Diagram b
Tgraph -> QDiagram b V2 Double Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw (Tgraph -> QDiagram b V2 Double Any)
-> (Forced Tgraph -> Tgraph)
-> Forced Tgraph
-> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF (Forced Tgraph -> QDiagram b V2 Double Any)
-> [Forced Tgraph] -> [QDiagram b V2 Double Any]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tgraph -> [Forced Tgraph]
forcedBoundaryVCovering Tgraph
g)


-- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g.
-- Raises an error if force g fails with a stuck/incorrect Tgraph.
-- The tgraph of the result is the first boundary vertex cover of force g
-- which is arbitrarily chosen amongst the covers as the background setting,
-- and the tracked list of the result has the common faces of all the boundary vertex covers (of force g)
-- at the head, followed by the original faces of g.
empire1 :: Tgraph -> TrackedTgraph
empire1 :: Tgraph -> TrackedTgraph
empire1 Tgraph
g = 
    case Tgraph -> [Forced Tgraph]
forcedBoundaryVCovering Tgraph
g of
     [] -> String -> TrackedTgraph
forall a. HasCallStack => String -> a
error String
"empire1 : no forced boundary covers found\n"
     (Forced Tgraph
fg0:[Forced Tgraph]
others) -> Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs,Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g] where
          g0 :: Tgraph
g0 = Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF Forced Tgraph
fg0
          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]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g0) ([[TileFace]] -> [TileFace]) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Forced Tgraph -> [TileFace]) -> [Forced Tgraph] -> [[TileFace]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Forced Tgraph -> [TileFace]
g0Intersect [Forced Tgraph]
others
          de :: Dedge
de = Tgraph -> Dedge
forall a. HasFaces a => a -> Dedge
defaultAlignment Tgraph
g
          g0Intersect :: Forced Tgraph -> [TileFace]
g0Intersect Forced Tgraph
fg1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF Forced Tgraph
fg1,Dedge
de)

-- | empire2 g - produces a TrackedTgraph representing a level 2 empire of g.
-- Raises an error if force g fails with a stuck/incorrect Tgraph.
-- After finding all boundary edge covers of force g, 
-- boundary edge covers are then found for each boundary edge cover to form a list of doubly-extended
-- boundary edge covers.
-- The tgraph of the result is the first (doubly-extended) boundary edge cover (of force g)
-- which is arbitrarily chosen amongst the (doubly-extended) covers as the background setting,
-- and the tracked list of the result has the common faces of all the (doubly-extended) boundary edge covers
-- at the head, followed by the original faces of g.
empire2:: Tgraph -> TrackedTgraph
empire2 :: Tgraph -> TrackedTgraph
empire2 Tgraph
g = 
  case (Forced BoundaryState -> Tgraph)
-> [Forced 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 -> Tgraph)
-> (Forced BoundaryState -> BoundaryState)
-> Forced BoundaryState
-> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF) [Forced BoundaryState]
covers2 of
    [] -> String -> TrackedTgraph
forall a. HasCallStack => String -> a
error String
"empire2: empty list of secondary boundary covers found"
    (Tgraph
g0:[Tgraph]
others) -> Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs, Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g]
      where 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]
forall a. HasFaces a => a -> [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
            g0Intersect :: Tgraph -> [TileFace]
g0Intersect Tgraph
g1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Tgraph
g1,Dedge
de)
  where
     covers1 :: [Forced BoundaryState]
covers1 = Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering (Forced BoundaryState -> [Forced BoundaryState])
-> Forced BoundaryState -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ Try (Forced BoundaryState) -> Forced BoundaryState
forall a. Try a -> a
runTry (Try (Forced BoundaryState) -> Forced BoundaryState)
-> Try (Forced BoundaryState) -> Forced BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a. String -> Try a -> Try a
onFail String
"empire2:Initial force failed (incorrect Tgraph)\n"
              (Try (Forced BoundaryState) -> Try (Forced BoundaryState))
-> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Try (Forced BoundaryState)
forall a. Forcible a => a -> Try (Forced a)
tryForceF (BoundaryState -> Try (Forced BoundaryState))
-> BoundaryState -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
     covers2 :: [Forced BoundaryState]
covers2 = (Forced BoundaryState -> [Forced BoundaryState])
-> [Forced BoundaryState] -> [Forced BoundaryState]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering [Forced BoundaryState]
covers1
     de :: Dedge
de = Tgraph -> Dedge
forall a. HasFaces a => a -> Dedge
defaultAlignment Tgraph
g
     

-- | empire2Plus g - produces a TrackedTgraph representing an extended level 2 empire of g
-- similar to empire2, but using boundaryVCovering instead of boundaryECovering.
-- Raises an error if force g fails with a stuck/incorrect Tgraph.
empire2Plus:: Tgraph -> TrackedTgraph
empire2Plus :: Tgraph -> TrackedTgraph
empire2Plus Tgraph
g = 
  case (Forced BoundaryState -> Tgraph)
-> [Forced 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 -> Tgraph)
-> (Forced BoundaryState -> BoundaryState)
-> Forced BoundaryState
-> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF) [Forced BoundaryState]
covers2 of
    [] -> String -> TrackedTgraph
forall a. HasCallStack => String -> a
error String
"empire2: empty list of secondary boundary covers found"
    (Tgraph
g0:[Tgraph]
others) -> Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g0 [[TileFace]
fcs, Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g]
      where 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]
forall a. HasFaces a => a -> [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
            g0Intersect :: Tgraph -> [TileFace]
g0Intersect Tgraph
g1 = (Tgraph, Dedge) -> (Tgraph, Dedge) -> [TileFace]
commonFaces (Tgraph
g0,Dedge
de) (Tgraph
g1,Dedge
de)
  where
     covers1 :: [Forced BoundaryState]
covers1 = Forced BoundaryState -> [Forced BoundaryState]
boundaryVCovering (Forced BoundaryState -> [Forced BoundaryState])
-> Forced BoundaryState -> [Forced BoundaryState]
forall a b. (a -> b) -> a -> b
$ Try (Forced BoundaryState) -> Forced BoundaryState
forall a. Try a -> a
runTry (Try (Forced BoundaryState) -> Forced BoundaryState)
-> Try (Forced BoundaryState) -> Forced BoundaryState
forall a b. (a -> b) -> a -> b
$ String -> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a. String -> Try a -> Try a
onFail String
"empire2:Initial force failed (incorrect Tgraph)\n"
              (Try (Forced BoundaryState) -> Try (Forced BoundaryState))
-> Try (Forced BoundaryState) -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Try (Forced BoundaryState)
forall a. Forcible a => a -> Try (Forced a)
tryForceF (BoundaryState -> Try (Forced BoundaryState))
-> BoundaryState -> Try (Forced BoundaryState)
forall a b. (a -> b) -> a -> b
$ Tgraph -> BoundaryState
makeBoundaryState Tgraph
g
     covers2 :: [Forced BoundaryState]
covers2 = (Forced BoundaryState -> [Forced BoundaryState])
-> [Forced BoundaryState] -> [Forced BoundaryState]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Forced BoundaryState -> [Forced BoundaryState]
boundaryVCovering [Forced BoundaryState]
covers1
     de :: Dedge
de = Tgraph -> Dedge
forall a. HasFaces a => a -> Dedge
defaultAlignment Tgraph
g
     

-- | drawEmpire e - produces a diagram for an empire e represented as a TrackedTgraph
-- as calcultaed by e.g. empire1 or empire2 or empire2Plus.
-- The diagram draws the underlying Tgraph (the background setting), with the first tracked faces
-- (the starting Tgraph) shown red, and emphasising the second tracked faces
-- (the common  faces).
drawEmpire :: OKBackend b =>
               TrackedTgraph -> Diagram b
drawEmpire :: forall b. OKBackend b => TrackedTgraph -> Diagram b
drawEmpire =
    [VPatch -> QDiagram b (V b) (N b) Any]
-> TrackedTgraph -> QDiagram b (V b) (N b) Any
forall b.
OKBackend b =>
[VPatch -> Diagram b] -> TrackedTgraph -> Diagram b
drawTrackedTgraph  [ Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
ultraThin (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> (VPatch -> QDiagram b V2 Double Any)
-> VPatch
-> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> QDiagram b (V b) (N b) Any
VPatch -> QDiagram b V2 Double Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw
                       , Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> (VPatch -> QDiagram b V2 Double Any)
-> VPatch
-> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double
-> Colour Double -> VPatch -> QDiagram b (V b) (N b) Any
forall a b c1 c2.
(Drawable a, OKBackend b, Color c1, Color c2) =>
c1 -> c2 -> a -> Diagram 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
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure Double
forall n. OrderedField n => Measure n
thin (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> (VPatch -> QDiagram b V2 Double Any)
-> VPatch
-> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
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 (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> (VPatch -> QDiagram b V2 Double Any)
-> VPatch
-> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> QDiagram b (V b) (N b) Any
VPatch -> QDiagram b V2 Double Any
forall a b. (Drawable a, OKBackend b) => a -> Diagram b
draw
                       ]

-- | showEmpire1 g - produces a diagram emphasising the common faces of all boundary covers of force g.
-- This is drawn over one of the possible boundary covers and the faces of g are shown in red.
showEmpire1 :: OKBackend b =>
               Tgraph -> Diagram b
showEmpire1 :: forall b. OKBackend b => Tgraph -> Diagram b
showEmpire1 = TrackedTgraph -> QDiagram b (V b) (N b) Any
TrackedTgraph -> QDiagram b V2 Double Any
forall b. OKBackend b => TrackedTgraph -> Diagram b
drawEmpire (TrackedTgraph -> QDiagram b V2 Double Any)
-> (Tgraph -> TrackedTgraph) -> Tgraph -> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> TrackedTgraph
empire1

-- | showEmpire2 g - produces a diagram emphasising the common faces of a doubly-extended boundary cover of force g.
-- This is drawn over one of the possible doubly-extended boundary covers and the faces of g are shown in red.
showEmpire2 :: OKBackend b =>
               Tgraph -> Diagram b
showEmpire2 :: forall b. OKBackend b => Tgraph -> Diagram b
showEmpire2 = TrackedTgraph -> QDiagram b (V b) (N b) Any
TrackedTgraph -> QDiagram b V2 Double Any
forall b. OKBackend b => TrackedTgraph -> Diagram b
drawEmpire (TrackedTgraph -> QDiagram b V2 Double Any)
-> (Tgraph -> TrackedTgraph) -> Tgraph -> QDiagram b V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> TrackedTgraph
empire2

-- |superForce g - after forcing g this looks for single choice boundary edges.
-- That is a boundary edge for which only a dart or only a kite addition occurs in all boundary edge covers.
-- If there is at least one such edge, it makes the choice for the first such edge and recurses,
-- otherwise it returns the forced result.
-- This will raise an error if force encounters a stuck (incorrect) tiling or if
-- both forced extensions fail for some boundary edge.
-- Otherwise, the result has exactly two correct possible extensions for each boundary edge.
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 g - this looks for single choice edges after trying to force g.
-- If there is at least one, it makes that choice and recurses.
-- It returns a Left s if force fails or if both choices fail for some edge (where s is a failure report).
-- Otherwise Right g' is returned where g' is the super forced 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 - implementation of trySuperForce for force states only
    trySuperForceFS :: ForceState -> Try ForceState
    trySuperForceFS :: ForceState -> Try ForceState
trySuperForceFS ForceState
fs =
        do Forced ForceState
forcedFS <- String -> Try (Forced ForceState) -> Try (Forced ForceState)
forall a. String -> Try a -> Try a
onFail String
"trySuperForceFS: force failed (incorrect Tgraph)\n" (Try (Forced ForceState) -> Try (Forced ForceState))
-> Try (Forced ForceState) -> Try (Forced ForceState)
forall a b. (a -> b) -> a -> b
$
                       ForceState -> Try (Forced ForceState)
forall a. Forcible a => a -> Try (Forced a)
tryForceF ForceState
fs
           case Forced BoundaryState -> [(Dedge, HalfTileLabel)]
singleChoiceEdges (Forced BoundaryState -> [(Dedge, HalfTileLabel)])
-> Forced BoundaryState -> [(Dedge, HalfTileLabel)]
forall a b. (a -> b) -> a -> b
$ Forced ForceState -> Forced BoundaryState
boundaryStateF Forced ForceState
forcedFS of
              [] -> ForceState -> Try ForceState
forall a. a -> Either (String -> String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForceState -> Try ForceState) -> ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$ Forced ForceState -> ForceState
forall a. Forced a -> a
forgetF Forced 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 -> Try ForceState) -> ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$ Forced ForceState -> ForceState
forall a. Forced a -> a
forgetF Forced 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 bd - if bd is an explicitly Forced boundary state (of a forced Tgraph) this finds those boundary edges of bd
-- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of bd.
-- The result is a list of pairs of (edge,label) where edge is a boundary edge with a single choice
-- and label indicates the choice as the common face label.
singleChoiceEdges :: Forced BoundaryState -> [(Dedge,HalfTileLabel)]
singleChoiceEdges :: Forced BoundaryState -> [(Dedge, HalfTileLabel)]
singleChoiceEdges Forced BoundaryState
bstate = [BoundaryState] -> [Dedge] -> [(Dedge, HalfTileLabel)]
forall {a}.
HasFaces a =>
[a] -> [Dedge] -> [(Dedge, HalfTileLabel)]
commonToCovering (Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF (Forced BoundaryState -> BoundaryState)
-> [Forced BoundaryState] -> [BoundaryState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forced BoundaryState -> [Forced BoundaryState]
boundaryECovering Forced BoundaryState
bstate) (BoundaryState -> [Dedge]
forall a. HasFaces a => a -> [Dedge]
boundary (BoundaryState -> [Dedge]) -> BoundaryState -> [Dedge]
forall a b. (a -> b) -> a -> b
$ Forced BoundaryState -> BoundaryState
forall a. Forced a -> a
forgetF Forced BoundaryState
bstate)
  where
-- commonToCovering bds edgeList - when bds are all the boundary edge covers of some forced Tgraph
-- whose boundary edges were edgeList, this looks for edges in edgeList that have the same tile label added in all covers.
-- This indicates there is a single choice for such an edge (the other choice is incorrect).
-- The result is a list of pairs: edge and a common tile label.
-- commonToCovering :: [BoundaryState] -> [Dedge] -> [(Dedge,HalfTileLabel)]
    commonToCovering :: [a] -> [Dedge] -> [(Dedge, HalfTileLabel)]
commonToCovering [a]
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 = (a -> [HalfTileLabel]) -> [a] -> [[HalfTileLabel]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [Dedge] -> [HalfTileLabel]
forall {a}. HasFaces a => a -> [Dedge] -> [HalfTileLabel]
`reportCover` [Dedge]
edgeList) [a]
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
_:[a]
_) ([]:[[b]]
_) = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
"singleChoiceEdges:commonToCovering: empty list of labels"
      common (a
e:[a]
more) ((b
l:[b]
ls):[[b]]
lls) = if (b -> Bool) -> [b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
l) [b]
ls
                                     then (a
e,b
l)(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
      
-- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist,
-- this returns the tile label for the face covering each edge in edgelist (in corresponding order).
-- reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel]
    reportCover :: a -> [Dedge] -> [HalfTileLabel]
reportCover a
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
forall a. HasFaces a => [Dedge] -> a -> Map Dedge TileFace
dedgesFacesMap [Dedge]
des (a -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces a
bd) -- more efficient than using graphEFMap?
--      efmap = graphEFMap (recoverGraph bd)
      getf :: Dedge -> TileFace
getf Dedge
e = TileFace -> Maybe TileFace -> TileFace
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (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)
                                    (Dedge -> Map Dedge TileFace -> Maybe TileFace
faceForEdge Dedge
e Map Dedge TileFace
efmap)

-- |Tries to create a new Tgraph from all faces with a boundary vertex in a Tgraph.
-- The resulting faces could have a crossing boundary and also could be disconnected if there is a hole in the starting Tgraph
-- so these conditions are checked for, producing a Try result.
tryBoundaryFaceGraph :: Tgraph -> Try Tgraph
tryBoundaryFaceGraph :: Tgraph -> Try Tgraph
tryBoundaryFaceGraph = [TileFace] -> Try Tgraph
tryConnectedNoCross ([TileFace] -> Try Tgraph)
-> (Tgraph -> [TileFace]) -> Tgraph -> Try Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundaryState -> [TileFace]
boundaryFaces (BoundaryState -> [TileFace])
-> (Tgraph -> BoundaryState) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> BoundaryState
makeBoundaryState


{- -- | Returns a list of (looping) vertex trails for the boundary of a Tgraph.
-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.
-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.
-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs.
boundaryLoopsG:: Tgraph -> [[Vertex]]
boundaryLoopsG = findLoops . boundary
 -}
-- | Returns a list of (looping) vertex trails for a BoundaryState.
-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.
-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.
-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs (and hence BoundaryStates).
boundaryLoops:: HasFaces a => a -> [[Vertex]]
boundaryLoops :: forall a. HasFaces a => a -> [[Vertex]]
boundaryLoops = [Dedge] -> [[Vertex]]
findLoops ([Dedge] -> [[Vertex]]) -> (a -> [Dedge]) -> a -> [[Vertex]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Dedge]
forall a. HasFaces a => a -> [Dedge]
boundary

-- | When applied to a boundary edge list this returns a list of (looping) vertex trails.
-- I.e. if we follow the boundary edges of a Tgraph recording vertices visited as a list returning to the starting vertex
-- we get a looping trail.
-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.
-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.
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

    -- Make a vertex to vertex map from the directed edges then delete items from the map as a trail is followed
    -- from the lowest numbered vertex.
    -- Vertices are collected in reverse order, then the list is reversed when a loop is complete.
    -- This is repeated until the map is empty, to collect all boundary trials.
   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 -- sofar is the collected trail in reverse order.
            = 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 -- look for more loops
                           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"


-- | Given a suitable vertex to location map and boundary loops (represented as a list of lists of vertices),
-- this will return a (Diagrams) Path for the boundary.  It will raise an error if any vertex listed is not a map key.
-- (The resulting path can be filled when converted to a diagram.)
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 VMap.!)) [[Vertex]]
loops where
    locateLoop :: [Point v n] -> Located (Trail v n)
locateLoop [] = String -> Located (Trail v n)
forall a. HasCallStack => String -> a
error String
"pathFromBoundaryLoops: empty loop found\n"
    locateLoop (Point v n
p:[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 (Trail v n)) (N (Trail v n))
p) (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
pPoint v n -> [Point v n] -> [Point v n]
forall a. a -> [a] -> [a]
:[Point v n]
pts)


-- * TrackedTgraphs

{-|
 TrackedTgraph - introduced to allow tracking of subsets of faces
 in both force and decompose operations.
 Mainly used for drawing purposes but also for empires.
 A TrackedTgraph has a main Tgraph (tgraph) and a list of subsets (sublists) of faces (tracked).
 The list allows for tracking different subsets of faces at the same time.
-}
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 g creates a TrackedTgraph from a Tgraph g with an empty tracked list
newTrackedTgraph :: Tgraph -> TrackedTgraph
newTrackedTgraph :: Tgraph -> TrackedTgraph
newTrackedTgraph Tgraph
g = Tgraph -> [[TileFace]] -> TrackedTgraph
makeTrackedTgraph Tgraph
g []

-- |makeTrackedTgraph g trackedlist creates a TrackedTgraph from a Tgraph g
-- from trackedlist where each list in trackedlist is a subset of the faces of g.
-- Any faces not in g are ignored.
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]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g) [[TileFace]]
trackedlist}

-- |trackFaces ttg - pushes the maingraph tilefaces onto the stack of tracked subsets of ttg
trackFaces:: TrackedTgraph -> TrackedTgraph
trackFaces :: TrackedTgraph -> TrackedTgraph
trackFaces TrackedTgraph
ttg = TrackedTgraph
ttg{ tracked = faces ttg : tracked ttg }

-- |unionTwoTracked ttg - combines the top two lists of tracked tilefaces replacing them with the list union.
unionTwoTracked:: TrackedTgraph -> TrackedTgraph
unionTwoTracked :: TrackedTgraph -> TrackedTgraph
unionTwoTracked TrackedTgraph
ttg = TrackedTgraph
ttg{ tracked = 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"

{-*
Forcing and Decomposing TrackedTgraphs
-}

-- | TrackedTgraphs are Forcible    
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 -> String) a
forall (m :: * -> *) a. Monad m => a -> m a
return TrackedTgraph
ttg{ 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 -> String) a
forall (m :: * -> *) a. Monad m => a -> m a
return TrackedTgraph
ttg{ tgraph = g' }
--    boundaryState = boundaryState . tgraph

-- |TrackedTgraph is in class HasFaces
instance HasFaces TrackedTgraph where
    faces :: TrackedTgraph -> [TileFace]
faces  = Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (Tgraph -> [TileFace])
-> (TrackedTgraph -> Tgraph) -> TrackedTgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackedTgraph -> Tgraph
tgraph
    boundary :: TrackedTgraph -> [Dedge]
boundary = [TileFace] -> [Dedge]
forall a. HasFaces a => a -> [Dedge]
boundary ([TileFace] -> [Dedge])
-> (TrackedTgraph -> [TileFace]) -> TrackedTgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (Tgraph -> [TileFace])
-> (TrackedTgraph -> Tgraph) -> TrackedTgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackedTgraph -> Tgraph
tgraph
    maxV :: TrackedTgraph -> Vertex
maxV = [TileFace] -> Vertex
forall a. HasFaces a => a -> Vertex
maxV ([TileFace] -> Vertex)
-> (TrackedTgraph -> [TileFace]) -> TrackedTgraph -> Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (Tgraph -> [TileFace])
-> (TrackedTgraph -> Tgraph) -> TrackedTgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackedTgraph -> Tgraph
tgraph

-- |addHalfDartTracked ttg e - add a half dart to the tgraph of ttg on the given edge e,
-- and push the new singleton face list onto the tracked list.
addHalfDartTracked:: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfDartTracked :: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfDartTracked Dedge
e TrackedTgraph
ttg =
  TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [TileFace]
newfcs[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
    newfcs :: [TileFace]
newfcs = Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g

-- |addHalfKiteTracked ttg e - add a half kite to the tgraph of ttg on the given edge e,
-- and push the new singleton face list onto the tracked list.
addHalfKiteTracked:: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfKiteTracked :: Dedge -> TrackedTgraph -> TrackedTgraph
addHalfKiteTracked Dedge
e TrackedTgraph
ttg =
  TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [TileFace]
newfcs[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
    newfcs :: [TileFace]
newfcs = Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g' [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g

-- |decompose a TrackedTgraph - applies decomposition to all tracked subsets as well as the full Tgraph.
-- Tracked subsets get the same numbering of new vertices as the main Tgraph. 
decomposeTracked :: TrackedTgraph -> TrackedTgraph
decomposeTracked :: TrackedTgraph -> TrackedTgraph
decomposeTracked TrackedTgraph
ttg =
  TrackedTgraph{ tgraph :: Tgraph
tgraph = Tgraph
g' , tracked :: [[TileFace]]
tracked = [[TileFace]]
tlist}
  where
--    makeTrackedTgraph g' 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]
forall a. HasFaces a => a -> [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)

{-*  Drawing TrackedTgraphs
-}

{-|
    To draw a TrackedTgraph, we use a list of functions each turning a VPatch into a diagram.
    The first function is applied to a VPatch for untracked faces.
    Subsequent functions are applied to VPatches for the respective tracked subsets.
    Each diagram is beneath later ones in the list, with the diagram for the untracked VPatch at the bottom.
    The VPatches are all restrictions of a single VPatch for the Tgraph, so consistent.
    (Any extra draw functions are applied to the VPatch for the main tgraph and the results placed atop.)
-}
drawTrackedTgraph :: OKBackend b => [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b
drawTrackedTgraph :: forall b.
OKBackend b =>
[VPatch -> Diagram b] -> TrackedTgraph -> Diagram b
drawTrackedTgraph [VPatch -> Diagram b]
drawList TrackedTgraph
ttg = [Diagram b] -> Diagram b
forall a. Monoid a => [a] -> a
mconcat ([Diagram b] -> Diagram b) -> [Diagram b] -> Diagram b
forall a b. (a -> b) -> a -> b
$ [Diagram b] -> [Diagram b]
forall a. [a] -> [a]
reverse ([Diagram b] -> [Diagram b]) -> [Diagram b] -> [Diagram b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> QDiagram b V2 Double Any)
 -> VPatch -> QDiagram b V2 Double Any)
-> [VPatch -> QDiagram b V2 Double Any]
-> [VPatch]
-> [QDiagram b V2 Double Any]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> QDiagram b V2 Double Any)
-> VPatch -> QDiagram b V2 Double Any
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram b]
[VPatch -> QDiagram b V2 Double Any]
drawList [VPatch]
vpList where
    vp :: VPatch
vp = Tgraph -> VPatch
makeVP (TrackedTgraph -> Tgraph
tgraph TrackedTgraph
ttg)
    untracked :: [TileFace]
untracked = VPatch -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces 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

{-|
    To draw a TrackedTgraph rotated.
    Same as drawTrackedTgraph but with additional angle argument for the rotation.
    This is useful when labels are being drawn.
    The angle argument is used to rotate the common vertex location map (anticlockwise) before drawing
    to ensure labels are not rotated.
-}
drawTrackedTgraphRotated :: OKBackend b => [VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b
drawTrackedTgraphRotated :: forall b.
OKBackend b =>
[VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b
drawTrackedTgraphRotated [VPatch -> Diagram b]
drawList Angle Double
a TrackedTgraph
ttg = [Diagram b] -> Diagram b
forall a. Monoid a => [a] -> a
mconcat ([Diagram b] -> Diagram b) -> [Diagram b] -> Diagram b
forall a b. (a -> b) -> a -> b
$ [Diagram b] -> [Diagram b]
forall a. [a] -> [a]
reverse ([Diagram b] -> [Diagram b]) -> [Diagram b] -> [Diagram b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> QDiagram b V2 Double Any)
 -> VPatch -> QDiagram b V2 Double Any)
-> [VPatch -> QDiagram b V2 Double Any]
-> [VPatch]
-> [QDiagram b V2 Double Any]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> QDiagram b V2 Double Any)
-> VPatch -> QDiagram b V2 Double Any
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram b]
[VPatch -> QDiagram b V2 Double Any]
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]
forall a. HasFaces a => a -> [TileFace]
faces 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

{-|
    To draw a TrackedTgraph aligned.
    Same as drawTrackedTgraph but with additional vertex pair argument for the (x-axis) alignment.
    This is useful when labels are being drawn.
    The vertex pair argument is used to align the common vertex location map before drawing
    (to ensure labels are not rotated).
    This will raise an error if either of the pair of vertices is not a vertex of (the tgraph of) the TrackedTgraph
-}
drawTrackedTgraphAligned :: OKBackend b => [VPatch -> Diagram b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram b
drawTrackedTgraphAligned :: forall b.
OKBackend b =>
[VPatch -> Diagram b] -> Dedge -> TrackedTgraph -> Diagram b
drawTrackedTgraphAligned [VPatch -> Diagram b]
drawList (Vertex
a,Vertex
b) TrackedTgraph
ttg = [Diagram b] -> Diagram b
forall a. Monoid a => [a] -> a
mconcat ([Diagram b] -> Diagram b) -> [Diagram b] -> Diagram b
forall a b. (a -> b) -> a -> b
$ [Diagram b] -> [Diagram b]
forall a. [a] -> [a]
reverse ([Diagram b] -> [Diagram b]) -> [Diagram b] -> [Diagram b]
forall a b. (a -> b) -> a -> b
$ ((VPatch -> QDiagram b V2 Double Any)
 -> VPatch -> QDiagram b V2 Double Any)
-> [VPatch -> QDiagram b V2 Double Any]
-> [VPatch]
-> [QDiagram b V2 Double Any]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VPatch -> QDiagram b V2 Double Any)
-> VPatch -> QDiagram b V2 Double Any
forall a b. (a -> b) -> a -> b
($) [VPatch -> Diagram b]
[VPatch -> QDiagram b V2 Double Any]
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]
forall a. HasFaces a => a -> [TileFace]
faces 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