{-|
Module      : Tgraph.Force
Description : The force functions for Tgraphs 
Copyright   : (c) Chris Reade, 2021
License     : BSD-style
Maintainer  : chrisreade@mac.com
Stability   : experimental

This module includes force and tryForce plus related operations for testing and experimenting
such as tryStepForce, tryAddHalfKite and tryAddHalfDart.
It introduces BoundaryState and ForceState types and includes a Forcible class with instances for
Tgraph, BoundaryState, and ForceState.

The module is made strict (to remove many space leaks).
-}

{-# LANGUAGE Strict            #-} 

module Tgraph.Force
  ( -- *  Forcible class
   Forcible(..)
    -- *  Generalised forcing
  , force
  , forceWith
  , tryForce
  , tryForceWith
  , stepForce
  , tryStepForce
  , tryStepForceWith
  , tryFSOp
  , initFS
  , tryInitFS
  , tryChangeBoundary
  , wholeTiles
  -- *  Explicitly Forced
  , Forced()
  , forgetF
  , tryForceF
  , forceF
   , recoverGraphF
  , boundaryStateF
  , makeBoundaryStateF
  , initFSF
  , labelAsForced
   -- *  Force Related
  , addHalfKite
  , tryAddHalfKite
  , addHalfDart
  , tryAddHalfDart
    -- *  Debug Step Forcing
  , tryOneStepWith
  , tryOneStepForce
-- * Types for Forcing
  , BoundaryState(..)
  , ForceState(..)
  , BoundaryChange(..)
  , Update(..)
  , UpdateMap
  , UpdateGenerator(..)
  , UFinder
  , UChecker
    -- *  BoundaryState operations
  , makeBoundaryState
  -- , boundary (part of HasFaces class)
  , recoverGraph
--  , changeVFMap -- Now HIDDEN
  , facesAtBV
  , boundaryFaces
    -- *  Auxiliary Functions for a force step
  , affectedBoundary
--  , mustFind
  , tryReviseUpdates
  , tryReviseFSWith
  , findSafeUpdate
  , tryUnsafes
  , checkUnsafeUpdate
  , trySafeUpdate
--   , commonVs
  , tryUpdate
    -- *  Recalibrating force
  , recalibratingForce
  , tryRecalibratingForce
  , recalculateBVLocs
    -- * Forcing Rules and Update Generators
    -- $rules

    -- *  Combined Update Generators
  , defaultAllUGen
  , combineUpdateGenerators
  , allUGenerator
    -- * Update Generators and Finders for each Rule.
  , wholeTileUpdates
  , incompleteHalves
  , aceKiteUpdates
  , nonKDarts
  , queenOrKingUpdates
  , kitesWingDartOrigin
  , deuceDartUpdates
  , kiteGaps
  , jackDartUpdates
  , noTouchingDart
  , sunStarUpdates
  , almostSunStar
  , jackKiteUpdates
  , jackMissingKite
  , kingDartUpdates
  , kingMissingThirdDart
  , queenDartUpdates
  , queenMissingDarts
  , queenKiteUpdates
  , queenMissingKite
    -- *  Six Update Checkers
  , completeHalf
  , addKiteShortE
  , addDartShortE
  , completeSunStar
  , addKiteLongE
  , addDartLongE
    -- *  Boundary vertex properties
  , mustbeStar
  , mustbeSun
  , mustbeDeuce
  , mustbeKing
  , isKiteWing
  , isKiteOppV
  , isDartOrigin
  , mustbeQueen
  , kiteWingCount
  , mustbeJack
   -- * Other tools for making new update generators
  , newUpdateGenerator
  -- , makeGenerator
  , boundaryFilter
  , boundaryEdgeFilter
  , makeUpdate
--  , hasAnyMatchingE
--  , inspectBDedge
    -- *  Auxiliary Functions for adding faces
    -- $Additions
  -- , tryFindThirdV
  , externalAngle

  , touchCheck

  )  where



import Data.List ((\\), intersect, nub, find,foldl')
import qualified Data.Map as Map (Map, empty, delete, elems, insert, union, keys) -- used for UpdateMap
import qualified Data.IntMap.Strict as VMap (elems, filterWithKey, alter, delete, lookup, (!))
            -- used for BoundaryState locations AND faces at boundary vertices
-- import qualified Data.Maybe(fromMaybe)  -- was used for lazy mustFind only
import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate 
import Tgraph.Prelude

{-
***************************************************************************   
Efficient FORCING with 
  BoundaryState, ForceState 
  Touching Vertex Check
  Incremented Update Maps
***************************************************************************
-}




{-| A BoundaryState records
the boundary directed edges (directed so that faces are on LHS and exterior is on RHS)
plus 
a mapping of boundary vertices to their incident faces, plus
a mapping of boundary vertices to positions (using Tgraph.Prelude.locateVertices).
It also keeps track of all the faces
and the next vertex label to be used when adding a new vertex.
-}
data BoundaryState
   = BoundaryState
     { BoundaryState -> [(Vertex, Vertex)]
boundaryDedges:: [Dedge]  -- ^ boundary directed edges (face on LHS, exterior on RHS)
     , BoundaryState -> VertexMap [TileFace]
bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex.
     , BoundaryState -> VertexMap (Point V2 Double)
bvLocMap:: VertexMap (Point V2 Double)  -- ^ position of each boundary vertex.
     , BoundaryState -> [TileFace]
allFaces:: [TileFace] -- ^ all the tile faces
     , BoundaryState -> Vertex
nextVertex:: Vertex -- ^ next vertex number
     } deriving (Vertex -> BoundaryState -> ShowS
[BoundaryState] -> ShowS
BoundaryState -> String
(Vertex -> BoundaryState -> ShowS)
-> (BoundaryState -> String)
-> ([BoundaryState] -> ShowS)
-> Show BoundaryState
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> BoundaryState -> ShowS
showsPrec :: Vertex -> BoundaryState -> ShowS
$cshow :: BoundaryState -> String
show :: BoundaryState -> String
$cshowList :: [BoundaryState] -> ShowS
showList :: [BoundaryState] -> ShowS
Show)

-- |BoundaryState is in class HasFaces
instance HasFaces BoundaryState where
    faces :: BoundaryState -> [TileFace]
faces = BoundaryState -> [TileFace]
allFaces
    boundary :: BoundaryState -> [(Vertex, Vertex)]
boundary = BoundaryState -> [(Vertex, Vertex)]
boundaryDedges
    maxV :: BoundaryState -> Vertex
maxV BoundaryState
bd = BoundaryState -> Vertex
nextVertex BoundaryState
bd Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- Vertex
1

-- |Calculates BoundaryState information from a Tgraph.
makeBoundaryState:: Tgraph -> BoundaryState
makeBoundaryState :: Tgraph -> BoundaryState
makeBoundaryState Tgraph
g =
  let bdes :: [(Vertex, Vertex)]
bdes = Tgraph -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary Tgraph
g
      bvs :: [Vertex]
bvs = ((Vertex, Vertex) -> Vertex) -> [(Vertex, Vertex)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst [(Vertex, Vertex)]
bdes -- (fmap snd bdes would also do) for all boundary vertices
      bvLocs :: VertexMap (Point V2 Double)
bvLocs = (Vertex -> Point V2 Double -> Bool)
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
forall a. (Vertex -> a -> Bool) -> IntMap a -> IntMap a
VMap.filterWithKey (\Vertex
k Point V2 Double
_ -> Vertex
k Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
bvs) (VertexMap (Point V2 Double) -> VertexMap (Point V2 Double))
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
forall a b. (a -> b) -> a -> b
$ [TileFace] -> VertexMap (Point V2 Double)
forall a. HasFaces a => a -> VertexMap (Point V2 Double)
locateVertices ([TileFace] -> VertexMap (Point V2 Double))
-> [TileFace] -> VertexMap (Point V2 Double)
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g
  in 
      BoundaryState
      { boundaryDedges :: [(Vertex, Vertex)]
boundaryDedges = [(Vertex, Vertex)]
bdes
      , bvFacesMap :: VertexMap [TileFace]
bvFacesMap = [Vertex] -> [TileFace] -> VertexMap [TileFace]
forall a. HasFaces a => [Vertex] -> a -> VertexMap [TileFace]
vertexFacesMap [Vertex]
bvs (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)
      , bvLocMap :: VertexMap (Point V2 Double)
bvLocMap = VertexMap (Point V2 Double)
bvLocs
      , allFaces :: [TileFace]
allFaces = Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g
      , nextVertex :: Vertex
nextVertex = Vertex
1Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+ Tgraph -> Vertex
forall a. HasFaces a => a -> Vertex
maxV Tgraph
g
      }


-- |Converts a BoundaryState back to a Tgraph
recoverGraph:: BoundaryState -> Tgraph
recoverGraph :: BoundaryState -> Tgraph
recoverGraph = [TileFace] -> Tgraph
makeUncheckedTgraph ([TileFace] -> Tgraph)
-> (BoundaryState -> [TileFace]) -> BoundaryState -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces

-- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap
changeVFMap::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMap :: TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMap TileFace
f VertexMap [TileFace]
vfm = (VertexMap [TileFace] -> Vertex -> VertexMap [TileFace])
-> VertexMap [TileFace] -> [Vertex] -> VertexMap [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VertexMap [TileFace] -> Vertex -> VertexMap [TileFace]
insertf VertexMap [TileFace]
vfm (TileFace -> [Vertex]
faceVList TileFace
f) where
   insertf :: VertexMap [TileFace] -> Vertex -> VertexMap [TileFace]
insertf VertexMap [TileFace]
vmap Vertex
v = (Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> VertexMap [TileFace] -> VertexMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter Maybe [TileFace] -> Maybe [TileFace]
consf Vertex
v VertexMap [TileFace]
vmap
   consf :: Maybe [TileFace] -> Maybe [TileFace]
consf Maybe [TileFace]
Nothing = [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
Just [TileFace
f]
   consf (Just [TileFace]
fs) = [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
Just (TileFace
fTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:[TileFace]
fs)

-- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex)
facesAtBV:: BoundaryState -> Vertex -> [TileFace]
facesAtBV :: BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v = case Vertex -> VertexMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd) of
  Just [TileFace]
fcs -> [TileFace]
fcs
  Maybe [TileFace]
Nothing -> String -> [TileFace]
forall a. HasCallStack => String -> a
error (String -> [TileFace]) -> String -> [TileFace]
forall a b. (a -> b) -> a -> b
$ String
"facesAtBV: Not a boundary vertex? No result found for vertex " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- |return a list of faces which have a boundary vertex from a BoundaryState
boundaryFaces :: BoundaryState -> [TileFace]
boundaryFaces :: BoundaryState -> [TileFace]
boundaryFaces BoundaryState
bd = [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a]
nub ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Vertex -> [TileFace]) -> [Vertex] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd) [Vertex]
bvs where
    bvs :: [Vertex]
bvs = BoundaryState -> [Vertex]
forall a. HasFaces a => a -> [Vertex]
boundaryVs BoundaryState
bd
-- boundaryFaces = nub . concat . VMap.elems . bvFacesMap 
-- relies on the map containing no extra info for non boundary vertices

-- |An Update is either safe or unsafe.
-- A safe update has a new face involving 3 existing vertices.
-- An unsafe update has a makeFace function to create the new face when given a fresh third vertex.
data Update = SafeUpdate TileFace
            | UnsafeUpdate (Vertex -> TileFace)

-- | 0 is used as a dummy variable to show unsafe updates (to display the function explicitly)
instance Show Update where
    show :: Update -> String
show (SafeUpdate TileFace
f) = String
"SafeUpdate (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    show (UnsafeUpdate Vertex -> TileFace
mf) = String
"UnsafeUpdate (\0 -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show (Vertex -> TileFace
mf Vertex
0)String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

-- |UpdateMap: partial map associating updates with (some) boundary directed edges.
-- (Any boundary directed edge will have the opposite direction in some face.)
type UpdateMap = Map.Map Dedge Update

-- |ForceState: The force state records information between executing single face updates during forcing
-- (a BoundaryState and an UpdateMap).
data ForceState = ForceState
                   { ForceState -> BoundaryState
boundaryState:: BoundaryState
                   , ForceState -> UpdateMap
updateMap:: UpdateMap
                   } deriving (Vertex -> ForceState -> ShowS
[ForceState] -> ShowS
ForceState -> String
(Vertex -> ForceState -> ShowS)
-> (ForceState -> String)
-> ([ForceState] -> ShowS)
-> Show ForceState
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> ForceState -> ShowS
showsPrec :: Vertex -> ForceState -> ShowS
$cshow :: ForceState -> String
show :: ForceState -> String
$cshowList :: [ForceState] -> ShowS
showList :: [ForceState] -> ShowS
Show)

-- |ForceState is in class HasFaces
instance HasFaces ForceState where
    faces :: ForceState -> [TileFace]
faces = BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (BoundaryState -> [TileFace])
-> (ForceState -> BoundaryState) -> ForceState -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForceState -> BoundaryState
boundaryState
    boundary :: ForceState -> [(Vertex, Vertex)]
boundary = BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary (BoundaryState -> [(Vertex, Vertex)])
-> (ForceState -> BoundaryState)
-> ForceState
-> [(Vertex, Vertex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForceState -> BoundaryState
boundaryState
    maxV :: ForceState -> Vertex
maxV = BoundaryState -> Vertex
forall a. HasFaces a => a -> Vertex
maxV (BoundaryState -> Vertex)
-> (ForceState -> BoundaryState) -> ForceState -> Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForceState -> BoundaryState
boundaryState

{-|UpdateGenerator is a newtype for functions which capture one or more of the forcing rules.
The functions can be applied using the unwrapper applyUG
and produce a (Try) UpdateMap when given a BoundaryState and a focus list of particular directed boundary edges.  
Each forcing rule has a particular UpdateGenerator,
but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGenerator).
-}
newtype UpdateGenerator = UpdateGenerator {UpdateGenerator
-> BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
applyUG :: BoundaryState -> [Dedge] -> Try UpdateMap}


-- | Forcing a Tgraph requires conversion to a BoundaryState (which records extra data)
-- and then to a ForceState (which keeps track of possible updates during forcing).
-- Thus we introduce a Forcible class which will have Tgraph, BoundaryState, ForceState as instances.
--
-- Forcible class has operations to (indirectly) implement forcing and single step forcing
-- for any Forcible. The class operations are more general to allow for other
-- force related operations to be generalised for use on any Forcible.
-- For example tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundaryWith.
--
-- Note that these operations are parameterised on an UpdateGenerator, which encapsulates
-- the forcing rules to be used.
class Forcible a where
    -- | tryFSOpWith (try ForseState Operation with) when given an update generator, generalises a (try) ForceState operation to a (try) Forcible operation.
    -- The update generator is only used to initialise a ForceState when there is not one
    -- already available (i.e not used when the Forcible is a ForceState)
    --
    -- To improve performance of a sequence of force related operations, express each as a
    -- ForceState -> Try ForceState, then use (\<=\<) or (\>=\>) to combine and pass to tryFSOpWith.
    -- This ensures there are no unnecessary conversions between steps.
    tryFSOpWith :: UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
    -- | tryInitFSWith (try initialising a ForceState with) when given an update generator tries to create an initial ForceState (ready for forcing) from a Forcible.
    -- Again, the update generator is not used when the instance is a ForceState.
    tryInitFSWith :: UpdateGenerator -> a -> Try ForceState
    -- | tryChangeBoundaryWith when given an update generator, converts a (try) BoundaryState changing operation to a (try) Forcible operation.
    -- The update generator is only used when the instance is a ForceState (to revise the update map in the result).
    tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a

-- |ForceStates are Forcible
instance Forcible ForceState where
    tryFSOpWith :: UpdateGenerator
-> (ForceState -> Try ForceState) -> ForceState -> Try ForceState
tryFSOpWith UpdateGenerator
_ = (ForceState -> Try ForceState) -> ForceState -> Try ForceState
forall a. a -> a
id  -- update generator not used
    tryInitFSWith :: UpdateGenerator -> ForceState -> Try ForceState
tryInitFSWith UpdateGenerator
_  = ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return  -- update generator not used
    tryChangeBoundaryWith :: UpdateGenerator
-> (BoundaryState -> Try BoundaryChange)
-> ForceState
-> Try ForceState
tryChangeBoundaryWith UpdateGenerator
ugen BoundaryState -> Try BoundaryChange
f ForceState
fs = do
        BoundaryChange
bdC <- BoundaryState -> Try BoundaryChange
f (ForceState -> BoundaryState
boundaryState ForceState
fs)
        UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
ugen BoundaryChange
bdC ForceState
fs
--    boundaryState = boundaryState

-- | BoundaryStates are Forcible    
instance Forcible BoundaryState where
    tryFSOpWith :: UpdateGenerator
-> (ForceState -> Try ForceState)
-> BoundaryState
-> Try BoundaryState
tryFSOpWith UpdateGenerator
ugen ForceState -> Try ForceState
f BoundaryState
bd = do
        ForceState
fs <- UpdateGenerator -> BoundaryState -> Try ForceState
forall a. Forcible a => UpdateGenerator -> a -> Try ForceState
tryInitFSWith UpdateGenerator
ugen BoundaryState
bd
        ForceState
fs' <- ForceState -> Try ForceState
f ForceState
fs
        BoundaryState -> Try BoundaryState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ ForceState -> BoundaryState
boundaryState ForceState
fs'
    tryInitFSWith :: UpdateGenerator -> BoundaryState -> Try ForceState
tryInitFSWith UpdateGenerator
ugen BoundaryState
bd = do
        UpdateMap
umap <- UpdateGenerator
-> BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
applyUG UpdateGenerator
ugen BoundaryState
bd (BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd)
        ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForceState -> Try ForceState) -> ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$ ForceState { boundaryState :: BoundaryState
boundaryState = BoundaryState
bd , updateMap :: UpdateMap
updateMap = UpdateMap
umap }
    tryChangeBoundaryWith :: UpdateGenerator
-> (BoundaryState -> Try BoundaryChange)
-> BoundaryState
-> Try BoundaryState
tryChangeBoundaryWith UpdateGenerator
_ BoundaryState -> Try BoundaryChange
f BoundaryState
bd = do -- update generator not used
        BoundaryChange
bdC <- BoundaryState -> Try BoundaryChange
f BoundaryState
bd
        BoundaryState -> Try BoundaryState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (BoundaryState -> Try BoundaryState)
-> BoundaryState -> Try BoundaryState
forall a b. (a -> b) -> a -> b
$ BoundaryChange -> BoundaryState
newBoundaryState BoundaryChange
bdC

-- | Tgraphs are Forcible    
instance Forcible Tgraph where
    tryFSOpWith :: UpdateGenerator
-> (ForceState -> Try ForceState) -> Tgraph -> Try Tgraph
tryFSOpWith UpdateGenerator
ugen ForceState -> Try ForceState
f Tgraph
g = BoundaryState -> Tgraph
recoverGraph (BoundaryState -> Tgraph) -> Try BoundaryState -> Try Tgraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateGenerator
-> (ForceState -> Try ForceState)
-> BoundaryState
-> Try BoundaryState
forall a.
Forcible a =>
UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith UpdateGenerator
ugen ForceState -> Try ForceState
f (Tgraph -> BoundaryState
makeBoundaryState Tgraph
g)
    tryInitFSWith :: UpdateGenerator -> Tgraph -> Try ForceState
tryInitFSWith UpdateGenerator
ugen Tgraph
g = UpdateGenerator -> BoundaryState -> Try ForceState
forall a. Forcible a => UpdateGenerator -> a -> Try ForceState
tryInitFSWith UpdateGenerator
ugen (Tgraph -> BoundaryState
makeBoundaryState Tgraph
g)
    tryChangeBoundaryWith :: UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> Tgraph -> Try Tgraph
tryChangeBoundaryWith UpdateGenerator
ugen BoundaryState -> Try BoundaryChange
f Tgraph
g = -- update generator not used
        BoundaryState -> Tgraph
recoverGraph (BoundaryState -> Tgraph) -> Try BoundaryState -> Try Tgraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateGenerator
-> (BoundaryState -> Try BoundaryChange)
-> BoundaryState
-> Try BoundaryState
forall a.
Forcible a =>
UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundaryWith UpdateGenerator
ugen BoundaryState -> Try BoundaryChange
f (Tgraph -> BoundaryState
makeBoundaryState Tgraph
g)
--    boundaryState = makeBoundaryState


-- | try forcing using a given UpdateGenerator.
--  tryForceWith uGen fs - does updates using uGen until there are no more updates.
--  It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph.
tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a
tryForceWith :: forall a. Forcible a => UpdateGenerator -> a -> Try a
tryForceWith UpdateGenerator
ugen = UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
forall a.
Forcible a =>
UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith UpdateGenerator
ugen (UpdateGenerator -> ForceState -> Try ForceState
tryForceStateWith UpdateGenerator
ugen) where
--    tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState
    tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState
tryForceStateWith UpdateGenerator
uGen = ForceState -> Try ForceState
retry where
      retry :: ForceState -> Try ForceState
retry ForceState
fs = case UpdateMap -> Maybe Update
findSafeUpdate (ForceState -> UpdateMap
updateMap ForceState
fs) of
                 Just Update
u -> do BoundaryChange
bdChange <- BoundaryState -> Update -> Try BoundaryChange
trySafeUpdate (ForceState -> BoundaryState
boundaryState ForceState
fs) Update
u
                              ForceState
fs' <- UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
uGen BoundaryChange
bdChange ForceState
fs
                              ForceState -> Try ForceState
retry ForceState
fs'
                 Maybe Update
_  -> do Maybe BoundaryChange
maybeBdC <- ForceState -> Try (Maybe BoundaryChange)
tryUnsafes ForceState
fs
                          case Maybe BoundaryChange
maybeBdC of
                            Maybe BoundaryChange
Nothing  -> ForceState -> Try ForceState
forall a b. b -> Either a b
Right ForceState
fs -- no more updates
                            Just BoundaryChange
bdC -> do ForceState
fs' <- UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
uGen BoundaryChange
bdC ForceState
fs
                                           ForceState -> Try ForceState
retry ForceState
fs'

-- | try a given number of force steps using a given UpdateGenerator.
tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a
tryStepForceWith :: forall a. Forcible a => UpdateGenerator -> Vertex -> a -> Try a
tryStepForceWith UpdateGenerator
ugen Vertex
n =
  if Vertex
nVertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>=Vertex
0
  then UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
forall a.
Forcible a =>
UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith UpdateGenerator
ugen ((ForceState -> Try ForceState) -> a -> Try a)
-> (ForceState -> Try ForceState) -> a -> Try a
forall a b. (a -> b) -> a -> b
$ Vertex -> ForceState -> Try ForceState
forall {t}. (Eq t, Num t) => t -> ForceState -> Try ForceState
count Vertex
n
  else String -> a -> Try a
forall a. HasCallStack => String -> a
error String
"tryStepForceWith: used with negative number of steps\n"
  where
      count :: t -> ForceState -> Try ForceState
count t
0 ForceState
fs = ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ForceState
fs
      count t
m ForceState
fs = do Maybe (ForceState, BoundaryChange)
result <- UpdateGenerator
-> ForceState -> Try (Maybe (ForceState, BoundaryChange))
tryOneStepWith UpdateGenerator
ugen ForceState
fs
                      case Maybe (ForceState, BoundaryChange)
result of
                       Maybe (ForceState, BoundaryChange)
Nothing -> ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ForceState
fs
                       Just (ForceState
fs', BoundaryChange
_) ->  t -> ForceState -> Try ForceState
count (t
mt -> t -> t
forall a. Num a => a -> a -> a
-t
1) ForceState
fs'

-- |A version of tryFSOpWith using defaultAllUGen representing all 10 rules for updates.
tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a
tryFSOp :: forall a.
Forcible a =>
(ForceState -> Try ForceState) -> a -> Try a
tryFSOp = UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
forall a.
Forcible a =>
UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith UpdateGenerator
defaultAllUGen

-- |A try version of the main force function using defaultAllUGen representing all 10 rules for updates.
-- This returns Left report on discovering a stuck Tgraph and Right a (with a the resulting forcible) otherwise.
tryForce:: Forcible a => a -> Try a
tryForce :: forall a. Forcible a => a -> Try a
tryForce = UpdateGenerator -> a -> Try a
forall a. Forcible a => UpdateGenerator -> a -> Try a
tryForceWith UpdateGenerator
defaultAllUGen

-- |The main force (partial) function using defaultAllUGen representing all 10 rules for updates.
-- This raises an error on discovering a stuck/incorrect Forcible.
force:: Forcible a => a -> a
force :: forall a. Forcible a => a -> a
force = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> (a -> Try a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Try a
forall a. Forcible a => a -> Try a
tryForce

-- |special case of forcing only half tiles to whole tiles
wholeTiles:: Forcible a => a -> a
wholeTiles :: forall a. Forcible a => a -> a
wholeTiles = UpdateGenerator -> a -> a
forall a. Forcible a => UpdateGenerator -> a -> a
forceWith UpdateGenerator
wholeTileUpdates

-- | forceWith ugen: force using the given UpdateGenerator
-- This raises an error on discovering a stuck/incorrect Forcible.
forceWith:: Forcible a => UpdateGenerator -> a -> a
forceWith :: forall a. Forcible a => UpdateGenerator -> a -> a
forceWith UpdateGenerator
ugen = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> (a -> Try a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateGenerator -> a -> Try a
forall a. Forcible a => UpdateGenerator -> a -> Try a
tryForceWith UpdateGenerator
ugen

-- | try to initialize a force state with the default UpdateGenerator.
-- Returns a Left report if it finds a stuck Forcible.
tryInitFS :: Forcible a => a -> Try ForceState
tryInitFS :: forall a. Forcible a => a -> Try ForceState
tryInitFS = UpdateGenerator -> a -> Try ForceState
forall a. Forcible a => UpdateGenerator -> a -> Try ForceState
tryInitFSWith UpdateGenerator
defaultAllUGen

-- | initialize a force state with the default UpdateGenerator.
-- Raises an error if it finds a stuck Forcible.
initFS :: Forcible a => a -> ForceState
initFS :: forall a. Forcible a => a -> ForceState
initFS = Try ForceState -> ForceState
forall a. Try a -> a
runTry (Try ForceState -> ForceState)
-> (a -> Try ForceState) -> a -> ForceState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Try ForceState
forall a. Forcible a => a -> Try ForceState
tryInitFS

-- |tryStepForce n a - produces a (Right) intermediate Forcible after n steps (n face additions) starting from Forcible a.
-- or a Left report if it encounters a stuck/incorrect Forcible within n steps.
-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. 
tryStepForce :: Forcible a => Int -> a -> Try a
tryStepForce :: forall a. Forcible a => Vertex -> a -> Try a
tryStepForce = UpdateGenerator -> Vertex -> a -> Try a
forall a. Forcible a => UpdateGenerator -> Vertex -> a -> Try a
tryStepForceWith UpdateGenerator
defaultAllUGen-- Was called tryStepForceFrom

-- |stepForce n a - produces an intermediate Forcible after n steps (n face additions) starting from Forcible a.
-- It raises an error if it encounters a stuck/incorrect Forcible within n steps.
-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. 
stepForce :: Forcible a => Int -> a ->  a
stepForce :: forall a. Forcible a => Vertex -> a -> a
stepForce Vertex
n = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> (a -> Try a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> a -> Try a
forall a. Forcible a => Vertex -> a -> Try a
tryStepForce Vertex
n

-- |specialises tryChangeBoundaryWith to the default update generator.
tryChangeBoundary:: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundary :: forall a.
Forcible a =>
(BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundary = UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> a -> Try a
forall a.
Forcible a =>
UpdateGenerator
-> (BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundaryWith UpdateGenerator
defaultAllUGen

-- |Forced a is a newtype (for a) to explicitly indicate that a is fully forced.
-- This enables restriction of some functions that should only be applied to a fully forced Forcible.
--
-- To access the Forcible use:  forgetF :: Forced a -> a
--
-- Create an explicitly Forced Forcible using forceF or tryForceF
newtype Forced a = Forced { -- | forget the explicit Forced labelling
                            forall a. Forced a -> a
forgetF :: a  
                          }                 
   deriving (Vertex -> Forced a -> ShowS
[Forced a] -> ShowS
Forced a -> String
(Vertex -> Forced a -> ShowS)
-> (Forced a -> String) -> ([Forced a] -> ShowS) -> Show (Forced a)
forall a. Show a => Vertex -> Forced a -> ShowS
forall a. Show a => [Forced a] -> ShowS
forall a. Show a => Forced a -> String
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Vertex -> Forced a -> ShowS
showsPrec :: Vertex -> Forced a -> ShowS
$cshow :: forall a. Show a => Forced a -> String
show :: Forced a -> String
$cshowList :: forall a. Show a => [Forced a] -> ShowS
showList :: [Forced a] -> ShowS
Show)

-- |Extend HasFaces ops from a to Forced a
instance HasFaces a => HasFaces (Forced a) where
    faces :: Forced a -> [TileFace]
faces = a -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces (a -> [TileFace]) -> (Forced a -> a) -> Forced a -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced a -> a
forall a. Forced a -> a
forgetF
    boundary :: Forced a -> [(Vertex, Vertex)]
boundary = a -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary (a -> [(Vertex, Vertex)])
-> (Forced a -> a) -> Forced a -> [(Vertex, Vertex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced a -> a
forall a. Forced a -> a
forgetF
    maxV :: Forced a -> Vertex
maxV = [TileFace] -> Vertex
forall a. HasFaces a => a -> Vertex
maxV ([TileFace] -> Vertex)
-> (Forced a -> [TileFace]) -> Forced a -> Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced a -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces

-- | Constructs an explicitly Forced type.
--
-- WARNING: this should only be used when the argument is known to be a fully forced Forcible.
-- Consider using forceF or tryForceF instead for safety reasons.
labelAsForced :: a -> Forced a
labelAsForced :: forall a. a -> Forced a
labelAsForced = a -> Forced a
forall a. a -> Forced a
Forced

-- |tryForceF is the same as tryForce except that
-- the successful result is explitly indicated as Forced.
tryForceF :: Forcible a => a -> Try (Forced a)
tryForceF :: forall a. Forcible a => a -> Try (Forced a)
tryForceF = (a -> Forced a) -> Either ShowS a -> Either ShowS (Forced a)
forall a b. (a -> b) -> Either ShowS a -> Either ShowS b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Forced a
forall a. a -> Forced a
Forced (Either ShowS a -> Either ShowS (Forced a))
-> (a -> Either ShowS a) -> a -> Either ShowS (Forced a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either ShowS a
forall a. Forcible a => a -> Try a
tryForce

-- |forceF is the same partial function as force except that
-- the (successful) result is explitly indicated as Forced.
forceF:: Forcible a => a -> Forced a
forceF :: forall a. Forcible a => a -> Forced a
forceF = Try (Forced a) -> Forced a
forall a. Try a -> a
runTry (Try (Forced a) -> Forced a)
-> (a -> Try (Forced a)) -> a -> Forced a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Try (Forced a)
forall a. Forcible a => a -> Try (Forced a)
tryForceF

-- | recoverGraphF is an explicitly forced version of recoverGraph
recoverGraphF :: Forced BoundaryState -> Forced Tgraph
recoverGraphF :: Forced BoundaryState -> Forced Tgraph
recoverGraphF (Forced BoundaryState
bs) = Tgraph -> Forced Tgraph
forall a. a -> Forced a
labelAsForced (BoundaryState -> Tgraph
recoverGraph BoundaryState
bs)

-- | boundaryStateF is an explicitly forced version of boundaryState
boundaryStateF :: Forced ForceState -> Forced BoundaryState
boundaryStateF :: Forced ForceState -> Forced BoundaryState
boundaryStateF (Forced ForceState
fs) = BoundaryState -> Forced BoundaryState
forall a. a -> Forced a
labelAsForced (ForceState -> BoundaryState
boundaryState ForceState
fs)

-- | makeBoundaryStateF is an explicitly forced version of makeBoundaryState
makeBoundaryStateF :: Forced Tgraph -> Forced BoundaryState
makeBoundaryStateF :: Forced Tgraph -> Forced BoundaryState
makeBoundaryStateF (Forced Tgraph
g) = BoundaryState -> Forced BoundaryState
forall a. a -> Forced a
labelAsForced (Tgraph -> BoundaryState
makeBoundaryState Tgraph
g)

-- | initFSF is an explicitly forced version of initFS
initFSF :: Forcible a => Forced a -> Forced ForceState
initFSF :: forall a. Forcible a => Forced a -> Forced ForceState
initFSF (Forced a
a) = ForceState -> Forced ForceState
forall a. a -> Forced a
labelAsForced (a -> ForceState
forall a. Forcible a => a -> ForceState
initFS a
a)

-- |addHalfKite is for adding a single half kite on a chosen boundary Dedge of a Forcible.
-- The Dedge must be a boundary edge but the direction is not important as
-- the correct direction is automatically calculated.
-- It will raise an error if the edge is a dart join or if a conflict (stuck graph) is detected
-- or if the edge is not a boundary edge.
addHalfKite :: Forcible a => Dedge -> a -> a
addHalfKite :: forall a. Forcible a => (Vertex, Vertex) -> a -> a
addHalfKite (Vertex, Vertex)
e  = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> (a -> Try a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> a -> Try a
forall a. Forcible a => (Vertex, Vertex) -> a -> Try a
tryAddHalfKite (Vertex, Vertex)
e

-- |tryAddHalfKite is a version of addHalfKite which returns a Try
-- with a Left report if it finds a stuck/incorrect graph, or 
-- if the edge is a dart join, or
-- if the edge is not a boundary edge.   
tryAddHalfKite :: Forcible a => Dedge -> a -> Try a
tryAddHalfKite :: forall a. Forcible a => (Vertex, Vertex) -> a -> Try a
tryAddHalfKite = (BoundaryState -> Try BoundaryChange) -> a -> Try a
forall a.
Forcible a =>
(BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundary ((BoundaryState -> Try BoundaryChange) -> a -> Try a)
-> ((Vertex, Vertex) -> BoundaryState -> Try BoundaryChange)
-> (Vertex, Vertex)
-> a
-> Try a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> BoundaryState -> Try BoundaryChange
tryAddHalfKiteBoundary where
-- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change
-- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange
    tryAddHalfKiteBoundary :: (Vertex, Vertex) -> BoundaryState -> Try BoundaryChange
tryAddHalfKiteBoundary (Vertex, Vertex)
e BoundaryState
bd =
      do (Vertex, Vertex)
de <- case [(Vertex, Vertex)
e, (Vertex, Vertex) -> (Vertex, Vertex)
reverseD (Vertex, Vertex)
e] [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd of
                 [(Vertex, Vertex)
de] -> (Vertex, Vertex) -> Either ShowS (Vertex, Vertex)
forall a b. b -> Either a b
Right (Vertex, Vertex)
de
                 [(Vertex, Vertex)]
_ ->  [String] -> Either ShowS (Vertex, Vertex)
forall a. [String] -> Try a
failReports
                          [String
"tryAddHalfKite:  on non-boundary edge "
                          ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex, Vertex)
e
                          ,String
"\n"
                          ]
         let (TileFace
fc,EdgeType
etype) = BoundaryState -> (Vertex, Vertex) -> (TileFace, EdgeType)
inspectBDedge BoundaryState
bd (Vertex, Vertex)
de
         let tryU :: Try Update
tryU | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Long = UChecker
addKiteLongE BoundaryState
bd TileFace
fc
                  | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Short = UChecker
addKiteShortE BoundaryState
bd TileFace
fc
                  | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Join Bool -> Bool -> Bool
&& TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc = UChecker
completeHalf BoundaryState
bd TileFace
fc
                  | Bool
otherwise = String -> Try Update
forall a. String -> Try a
failReport String
"tryAddHalfKite: applied to dart join (not possible).\n"
         Update
u <- Try Update
tryU
         BoundaryState -> Update -> Try BoundaryChange
tryUpdate BoundaryState
bd Update
u

-- |addHalfDart is for adding a single half dart on a chosen boundary Dedge of a Forcible.
-- The Dedge must be a boundary edge but the direction is not important as
-- the correct direction is automatically calculated.
-- It will raise an error if the edge is a dart short edge or kite join
-- or if a conflict (stuck graph) is detected or if
-- the edge is not a boundary edge.
addHalfDart :: Forcible a => Dedge -> a -> a
addHalfDart :: forall a. Forcible a => (Vertex, Vertex) -> a -> a
addHalfDart (Vertex, Vertex)
e = Try a -> a
forall a. Try a -> a
runTry (Try a -> a) -> (a -> Try a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> a -> Try a
forall a. Forcible a => (Vertex, Vertex) -> a -> Try a
tryAddHalfDart (Vertex, Vertex)
e

-- |tryAddHalfDart is a version of addHalfDart which returns a Try
-- with a Left report if it finds a stuck/incorrect graph, or
-- if the edge is a dart short edge or kite join, or
-- if the edge is not a boundary edge.
tryAddHalfDart :: Forcible a => Dedge -> a -> Try a
tryAddHalfDart :: forall a. Forcible a => (Vertex, Vertex) -> a -> Try a
tryAddHalfDart = (BoundaryState -> Try BoundaryChange) -> a -> Try a
forall a.
Forcible a =>
(BoundaryState -> Try BoundaryChange) -> a -> Try a
tryChangeBoundary ((BoundaryState -> Try BoundaryChange) -> a -> Try a)
-> ((Vertex, Vertex) -> BoundaryState -> Try BoundaryChange)
-> (Vertex, Vertex)
-> a
-> Try a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> BoundaryState -> Try BoundaryChange
tryAddHalfDartBoundary where
-- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change
-- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange
    tryAddHalfDartBoundary :: (Vertex, Vertex) -> BoundaryState -> Try BoundaryChange
tryAddHalfDartBoundary (Vertex, Vertex)
e BoundaryState
bd =
      do (Vertex, Vertex)
de <- case [(Vertex, Vertex)
e, (Vertex, Vertex) -> (Vertex, Vertex)
reverseD (Vertex, Vertex)
e] [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd of
                [(Vertex, Vertex)
de] -> (Vertex, Vertex) -> Either ShowS (Vertex, Vertex)
forall a b. b -> Either a b
Right (Vertex, Vertex)
de
                [(Vertex, Vertex)]
_ -> [String] -> Either ShowS (Vertex, Vertex)
forall a. [String] -> Try a
failReports
                        [String
"tryAddHalfDart:  on non-boundary edge "
                        ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex, Vertex)
e
                        ,String
"\n"
                        ]
         let (TileFace
fc,EdgeType
etype) = BoundaryState -> (Vertex, Vertex) -> (TileFace, EdgeType)
inspectBDedge BoundaryState
bd (Vertex, Vertex)
de
         let tryU :: Try Update
tryU | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Long = UChecker
addDartLongE BoundaryState
bd TileFace
fc
                  | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Short Bool -> Bool -> Bool
&& TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc = UChecker
addDartShortE BoundaryState
bd TileFace
fc
                  | EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Join Bool -> Bool -> Bool
&& TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
fc = UChecker
completeHalf BoundaryState
bd TileFace
fc
                  | Bool
otherwise = String -> Try Update
forall a. String -> Try a
failReport String
"tryAddHalfDart: applied to short edge of dart or to kite join (not possible).\n"
         Update
u <- Try Update
tryU
         BoundaryState -> Update -> Try BoundaryChange
tryUpdate BoundaryState
bd Update
u


-- |tryOneStepWith uGen fs does one force step (used for debugging purposes).
-- It returns either (1) a Right(Just (f,bc)) with a new ForceState f paired with a BoundaryChange bc
-- (using uGen to revise updates in the final ForceState), or (2)
-- a Right Nothing indicating forcing has finished and there are no more updates, or (3)
-- a Left report for a stuck/incorrect graph.
tryOneStepWith :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange))
tryOneStepWith :: UpdateGenerator
-> ForceState -> Try (Maybe (ForceState, BoundaryChange))
tryOneStepWith UpdateGenerator
uGen ForceState
fs =
      case UpdateMap -> Maybe Update
findSafeUpdate (ForceState -> UpdateMap
updateMap ForceState
fs) of
      Just Update
u -> do BoundaryChange
bdChange <- BoundaryState -> Update -> Try BoundaryChange
trySafeUpdate (ForceState -> BoundaryState
boundaryState ForceState
fs) Update
u
                   ForceState
fs' <- UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
uGen BoundaryChange
bdChange ForceState
fs
                   Maybe (ForceState, BoundaryChange)
-> Try (Maybe (ForceState, BoundaryChange))
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ForceState, BoundaryChange)
 -> Try (Maybe (ForceState, BoundaryChange)))
-> Maybe (ForceState, BoundaryChange)
-> Try (Maybe (ForceState, BoundaryChange))
forall a b. (a -> b) -> a -> b
$ (ForceState, BoundaryChange) -> Maybe (ForceState, BoundaryChange)
forall a. a -> Maybe a
Just (ForceState
fs',BoundaryChange
bdChange)
      Maybe Update
_  -> do Maybe BoundaryChange
maybeBdC <- ForceState -> Try (Maybe BoundaryChange)
tryUnsafes ForceState
fs
               case Maybe BoundaryChange
maybeBdC of
                Just BoundaryChange
bdC -> do ForceState
fs' <- UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
uGen BoundaryChange
bdC ForceState
fs
                               Maybe (ForceState, BoundaryChange)
-> Try (Maybe (ForceState, BoundaryChange))
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ForceState, BoundaryChange)
 -> Try (Maybe (ForceState, BoundaryChange)))
-> Maybe (ForceState, BoundaryChange)
-> Try (Maybe (ForceState, BoundaryChange))
forall a b. (a -> b) -> a -> b
$ (ForceState, BoundaryChange) -> Maybe (ForceState, BoundaryChange)
forall a. a -> Maybe a
Just (ForceState
fs',BoundaryChange
bdC)
                Maybe BoundaryChange
Nothing  -> Maybe (ForceState, BoundaryChange)
-> Try (Maybe (ForceState, BoundaryChange))
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ForceState, BoundaryChange)
forall a. Maybe a
Nothing           -- no more updates

-- |tryOneStepForce is a special case of tryOneStepWith using defaultAllUGen (used for debugging).
tryOneStepForce :: ForceState -> Try (Maybe (ForceState,BoundaryChange))
tryOneStepForce :: ForceState -> Try (Maybe (ForceState, BoundaryChange))
tryOneStepForce = UpdateGenerator
-> ForceState -> Try (Maybe (ForceState, BoundaryChange))
tryOneStepWith UpdateGenerator
defaultAllUGen


{-| After a face addition to a BoundaryState (by either trySafeUpdate or tryUnsafeUpdate), a BoundaryChange records
     (1) the new BoundaryState 
     (2) the list of directed edges that were, but are no longer on the boundary (1,2,or 3),
     (3) a list of boundary edges requiring updates to be recalculated - i.e the new boundary edges and their immediate neighbours (4,3,or 0).
     (4) the face that has been added.
-}
data BoundaryChange = BoundaryChange
                       { BoundaryChange -> BoundaryState
newBoundaryState:: BoundaryState -- ^ resulting boundary state
                       , BoundaryChange -> [(Vertex, Vertex)]
removedEdges:: [Dedge] -- ^ edges no longer on the boundary
                       , BoundaryChange -> [(Vertex, Vertex)]
revisedEdges :: [Dedge]  -- ^ new boundary edges plus immediate boundary neighbours (requiring new update calculations)
                       , BoundaryChange -> TileFace
newFace :: TileFace -- ^ face added in the change
                       } deriving (Vertex -> BoundaryChange -> ShowS
[BoundaryChange] -> ShowS
BoundaryChange -> String
(Vertex -> BoundaryChange -> ShowS)
-> (BoundaryChange -> String)
-> ([BoundaryChange] -> ShowS)
-> Show BoundaryChange
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> BoundaryChange -> ShowS
showsPrec :: Vertex -> BoundaryChange -> ShowS
$cshow :: BoundaryChange -> String
show :: BoundaryChange -> String
$cshowList :: [BoundaryChange] -> ShowS
showList :: [BoundaryChange] -> ShowS
Show)

{-| Given a BoundaryState with a list of one boundary edge or
     two adjacent boundary edges (or exceptionally no boundary edges),
     it extends the list with adjacent boundary edges (to produce 3 or 4 or none).
     It will raise an error if given more than 2 or 2 non-adjacent boundary edges.
     (Used to calculate revisedEdges in a BoundaryChange.
     (N.B. When a new face is fitted in to a hole with 3 sides there is no new boundary. Hence the need to allow for an empty list.)
-}
affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge]
affectedBoundary :: BoundaryState -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
affectedBoundary BoundaryState
bd [e1 :: (Vertex, Vertex)
e1@(Vertex
a,Vertex
b)] = [(Vertex, Vertex)
e0,(Vertex, Vertex)
e1,(Vertex, Vertex)
e2] where
           bdry :: [(Vertex, Vertex)]
bdry = BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd
           e0 :: (Vertex, Vertex)
e0 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd) [(Vertex, Vertex)]
bdry 
                  (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary: boundary edge not found with snd = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
           e2 :: (Vertex, Vertex)
e2 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst) [(Vertex, Vertex)]
bdry
                  (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary: boundary edge not found with fst = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
affectedBoundary BoundaryState
bd [e1 :: (Vertex, Vertex)
e1@(Vertex
a,Vertex
b),e2 :: (Vertex, Vertex)
e2@(Vertex
c,Vertex
d)] | Vertex
cVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b = [(Vertex, Vertex)
e0,(Vertex, Vertex)
e1,(Vertex, Vertex)
e2,(Vertex, Vertex)
e3] where
           bdry :: [(Vertex, Vertex)]
bdry = BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd
           e0 :: (Vertex, Vertex)
e0 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd) [(Vertex, Vertex)]
bdry 
                   (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary (c==b): boundary edge not found with snd = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1,(Vertex, Vertex)
e2]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
           e3 :: (Vertex, Vertex)
e3 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
d)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst) [(Vertex, Vertex)]
bdry 
                   (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary: boundary edge not found with fst = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1,(Vertex, Vertex)
e2]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
affectedBoundary BoundaryState
bd [e1 :: (Vertex, Vertex)
e1@(Vertex
a,Vertex
b),e2 :: (Vertex, Vertex)
e2@(Vertex
c,Vertex
d)] | Vertex
aVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
d  = [(Vertex, Vertex)
e0,(Vertex, Vertex)
e2,(Vertex, Vertex)
e1,(Vertex, Vertex)
e3] where
           bdry :: [(Vertex, Vertex)]
bdry = BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd
           e0 :: (Vertex, Vertex)
e0 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd) [(Vertex, Vertex)]
bdry 
                   (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary (a==d): boundary edge not found with snd = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
c String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1,(Vertex, Vertex)
e2]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
           e3 :: (Vertex, Vertex)
e3 = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)]
-> (() -> (Vertex, Vertex))
-> (Vertex, Vertex)
forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b)(Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst) [(Vertex, Vertex)]
bdry 
                   (\()-> String -> (Vertex, Vertex)
forall a. HasCallStack => String -> a
error (String -> (Vertex, Vertex)) -> String -> (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary: boundary edge not found with fst = "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
b String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
"\nand edges: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)
e1,(Vertex, Vertex)
e2]
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith boundary:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
bdry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
affectedBoundary BoundaryState
_ [] = [] -- case for filling a triangular hole
affectedBoundary BoundaryState
_ [(Vertex, Vertex)]
edges = String -> [(Vertex, Vertex)]
forall a. HasCallStack => String -> a
error (String -> [(Vertex, Vertex)]) -> String -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ String
"affectedBoundary: unexpected boundary edges "
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
edges String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n(Either more than 2 or 2 not adjacent)\n"


{-| mustFind (older version requires laziness) - an auxiliary function used to search with definite result.
mustFind p ls default returns the first item in ls satisfying predicate p and returns
default argument when none found (in finite cases).
Special case: the default arg may be used to raise an error when nothing is found.

mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p
mustFind p ls dflt
  = Data.Maybe.fromMaybe dflt (find p ls)
-}

{-| mustFind (strict version) is an auxiliary function used to search with definite result.
mustFind' p ls defaulfnt returns the first item in ls satisfying predicate p and returns
defaultfn () when none found (in finite cases).
This is a replacement foran older mustFind that relied on laziness.
This version works in a strict context.
-}
mustFind :: Foldable t => (p -> Bool) -> t p -> (() -> p) -> p
mustFind :: forall (t :: * -> *) p.
Foldable t =>
(p -> Bool) -> t p -> (() -> p) -> p
mustFind p -> Bool
p t p
ls () -> p
dflt
  = case (p -> Bool) -> t p -> Maybe p
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find p -> Bool
p t p
ls of
    Just p
a -> p
a
    Maybe p
Nothing -> () -> p
dflt ()

-- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange)
-- using uGen to calculate new updates.
tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap
tryReviseUpdates :: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap
tryReviseUpdates UpdateGenerator
uGen BoundaryChange
bdChange UpdateMap
umap =
  do let umap' :: UpdateMap
umap' = (UpdateMap -> (Vertex, Vertex) -> UpdateMap)
-> UpdateMap -> [(Vertex, Vertex)] -> UpdateMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Vertex, Vertex) -> UpdateMap -> UpdateMap)
-> UpdateMap -> (Vertex, Vertex) -> UpdateMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Vertex, Vertex) -> UpdateMap -> UpdateMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) UpdateMap
umap (BoundaryChange -> [(Vertex, Vertex)]
removedEdges BoundaryChange
bdChange)
     UpdateMap
umap'' <- UpdateGenerator
-> BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
applyUG UpdateGenerator
uGen (BoundaryChange -> BoundaryState
newBoundaryState BoundaryChange
bdChange) (BoundaryChange -> [(Vertex, Vertex)]
revisedEdges BoundaryChange
bdChange)
     UpdateMap -> Try UpdateMap
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdateMap -> UpdateMap -> UpdateMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union UpdateMap
umap'' UpdateMap
umap')

-- |tryReviseFSWith ugen bdC fs tries to revise fs after a boundary change (bdC) by calculating
-- the revised updates with ugen (and using the new boundary state in bdC).
tryReviseFSWith :: UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith :: UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState
tryReviseFSWith UpdateGenerator
ugen BoundaryChange
bdC ForceState
fs =
    do UpdateMap
umap <- UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap
tryReviseUpdates UpdateGenerator
ugen BoundaryChange
bdC (ForceState -> UpdateMap
updateMap ForceState
fs)
       ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForceState -> Try ForceState) -> ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$ ForceState{ boundaryState :: BoundaryState
boundaryState = BoundaryChange -> BoundaryState
newBoundaryState BoundaryChange
bdC, updateMap :: UpdateMap
updateMap = UpdateMap
umap}


-- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering)
findSafeUpdate:: UpdateMap -> Maybe Update
findSafeUpdate :: UpdateMap -> Maybe Update
findSafeUpdate UpdateMap
umap = (Update -> Bool) -> [Update] -> Maybe Update
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Update -> Bool
isSafeUpdate (UpdateMap -> [Update]
forall k a. Map k a -> [a]
Map.elems UpdateMap
umap) where
  isSafeUpdate :: Update -> Bool
isSafeUpdate (SafeUpdate TileFace
_ ) = Bool
True
  isSafeUpdate (UnsafeUpdate Vertex -> TileFace
_ ) = Bool
False

{-| tryUnsafes: Should only be used when there are no Safe updates in the UpdateMap.
   tryUnsafes works through the unsafe updates in (directed edge) key order and
   completes the first unsafe update that is not blocked (by a touching vertex), returning Right (Just bdC)
   where bdC is the resulting boundary change (if there is one).
   It returns Right Nothing if there are no unsafe updates but
   Left report if there are unsafes but all unsafes are blocked, where report describes the problem.
-}
tryUnsafes:: ForceState -> Try (Maybe BoundaryChange)
tryUnsafes :: ForceState -> Try (Maybe BoundaryChange)
tryUnsafes ForceState
fs = Vertex -> [Update] -> Try (Maybe BoundaryChange)
checkBlocked Vertex
0 ([Update] -> Try (Maybe BoundaryChange))
-> [Update] -> Try (Maybe BoundaryChange)
forall a b. (a -> b) -> a -> b
$ UpdateMap -> [Update]
forall k a. Map k a -> [a]
Map.elems (UpdateMap -> [Update]) -> UpdateMap -> [Update]
forall a b. (a -> b) -> a -> b
$ ForceState -> UpdateMap
updateMap ForceState
fs where
  bd :: BoundaryState
bd = ForceState -> BoundaryState
boundaryState ForceState
fs
  -- the integer records how many blocked cases have been found so far
  checkBlocked:: Int -> [Update]  -> Try (Maybe BoundaryChange)
  checkBlocked :: Vertex -> [Update] -> Try (Maybe BoundaryChange)
checkBlocked Vertex
0 [] = Maybe BoundaryChange -> Try (Maybe BoundaryChange)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BoundaryChange
forall a. Maybe a
Nothing
  checkBlocked Vertex
n [] = [String] -> Try (Maybe BoundaryChange)
forall a. [String] -> Try a
failReports 
                        [String
"tryUnsafes: There are "
                        ,Vertex -> String
forall a. Show a => a -> String
show Vertex
n
                        ,String
" unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n"
                        ,String
"This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n"
                        ,String
"Total number of faces is "
                        ,Vertex -> String
forall a. Show a => a -> String
show ([TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ([TileFace] -> Vertex) -> [TileFace] -> Vertex
forall a b. (a -> b) -> a -> b
$ BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces BoundaryState
bd)
                        ,String
"\n"
                        ]
  checkBlocked Vertex
n (Update
u: [Update]
more) = case BoundaryState -> Update -> Maybe BoundaryChange
checkUnsafeUpdate BoundaryState
bd Update
u of
                               Maybe BoundaryChange
Nothing -> Vertex -> [Update] -> Try (Maybe BoundaryChange)
checkBlocked (Vertex
nVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+Vertex
1) [Update]
more
                               Maybe BoundaryChange
other -> Maybe BoundaryChange -> Try (Maybe BoundaryChange)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BoundaryChange
other

{-| checkUnsafeUpdate bd u, calculates the resulting boundary change for an unsafe update (u) with a new vertex
     (raising an error if u is a safe update).
     It performs a touching vertex check with the new vertex
     returning Nothing if there is a touching vertex (blocked case).
     Otherwise it returns Just bdc with bdc a boundary change.
    [Note: Try is not used as a conflict cannot be found in the unsafe case, and blocking is only a problem
    when all unsafe updates are blocked (and there is at least one) - see tryUnsafes]
-}
checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange
checkUnsafeUpdate :: BoundaryState -> Update -> Maybe BoundaryChange
checkUnsafeUpdate BoundaryState
_  (SafeUpdate TileFace
_) = String -> Maybe BoundaryChange
forall a. HasCallStack => String -> a
error  String
"checkUnsafeUpdate: applied to safe update.\n"
checkUnsafeUpdate BoundaryState
bd (UnsafeUpdate Vertex -> TileFace
makeFace) =
   let v :: Vertex
v = BoundaryState -> Vertex
nextVertex BoundaryState
bd
       newface :: TileFace
newface = Vertex -> TileFace
makeFace Vertex
v
       oldVPoints :: VertexMap (Point V2 Double)
oldVPoints = BoundaryState -> VertexMap (Point V2 Double)
bvLocMap BoundaryState
bd
       newVPoints :: VertexMap (Point V2 Double)
newVPoints = TileFace
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
addVPoint TileFace
newface VertexMap (Point V2 Double)
oldVPoints
       vPosition :: Point V2 Double
vPosition = VertexMap (Point V2 Double)
newVPoints VertexMap (Point V2 Double) -> Vertex -> Point V2 Double
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
v -- Just vPosition = VMap.lookup v newVPoints
       fDedges :: [(Vertex, Vertex)]
fDedges = TileFace -> [(Vertex, Vertex)]
faceDedges TileFace
newface
       matchedDedges :: [(Vertex, Vertex)]
matchedDedges = ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Vertex
x,Vertex
y) -> Vertex
x Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
v Bool -> Bool -> Bool
&& Vertex
y Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
v) [(Vertex, Vertex)]
fDedges -- singleton
       newDedges :: [(Vertex, Vertex)]
newDedges = ((Vertex, Vertex) -> (Vertex, Vertex))
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> (Vertex, Vertex)
reverseD ([(Vertex, Vertex)]
fDedges [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Vertex, Vertex)]
matchedDedges) -- two edges
       resultBd :: BoundaryState
resultBd = BoundaryState
                    { boundaryDedges :: [(Vertex, Vertex)]
boundaryDedges = [(Vertex, Vertex)]
newDedges [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [a] -> [a] -> [a]
++ (BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Vertex, Vertex)]
matchedDedges)
                    , bvFacesMap :: VertexMap [TileFace]
bvFacesMap = TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMap TileFace
newface (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd)
                    , bvLocMap :: VertexMap (Point V2 Double)
bvLocMap = VertexMap (Point V2 Double)
newVPoints
                    , allFaces :: [TileFace]
allFaces = TileFace
newfaceTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:BoundaryState -> [TileFace]
allFaces BoundaryState
bd
                    -- allFaces = newface:faces bd <<<CAUSES SPACE LEAK>>>>
                    , nextVertex :: Vertex
nextVertex = Vertex
vVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+Vertex
1
                    }
       bdChange :: BoundaryChange
bdChange = BoundaryChange
                    { newBoundaryState :: BoundaryState
newBoundaryState = BoundaryState
resultBd
                    , removedEdges :: [(Vertex, Vertex)]
removedEdges = [(Vertex, Vertex)]
matchedDedges
                    , revisedEdges :: [(Vertex, Vertex)]
revisedEdges = BoundaryState -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
affectedBoundary BoundaryState
resultBd [(Vertex, Vertex)]
newDedges
                    , newFace :: TileFace
newFace = TileFace
newface
                    }
   in if Point V2 Double -> VertexMap (Point V2 Double) -> Bool
touchCheck Point V2 Double
vPosition VertexMap (Point V2 Double)
oldVPoints -- true if new vertex is blocked because it touches the boundary elsewhere
      then Maybe BoundaryChange
forall a. Maybe a
Nothing -- don't proceed when v is a touching vertex
      else BoundaryChange -> Maybe BoundaryChange
forall a. a -> Maybe a
Just BoundaryChange
bdChange

{-| trySafeUpdate bd u adds a new face by completing a safe update u on BoundaryState bd
    (raising an error if u is an unsafe update).
     It returns a Right BoundaryChange (containing a new BoundaryState, removed boundary edges and
     revised boundary edge list), unless a stuck/incorrect graph is found.
     It checks that the new face is not in conflict with existing faces,
     producing (Left report) if there is a conflict.
    It should cater for the exceptional case where the update removes 3 boundary edges
    in a triangle (and removes 3 boundary vertices), closing a hole.
-}
trySafeUpdate:: BoundaryState -> Update -> Try BoundaryChange
trySafeUpdate :: BoundaryState -> Update -> Try BoundaryChange
trySafeUpdate BoundaryState
_  (UnsafeUpdate Vertex -> TileFace
_) = String -> Try BoundaryChange
forall a. HasCallStack => String -> a
error String
"trySafeUpdate: applied to non-safe update.\n"
trySafeUpdate BoundaryState
bd (SafeUpdate TileFace
newface) =
   let fDedges :: [(Vertex, Vertex)]
fDedges = TileFace -> [(Vertex, Vertex)]
faceDedges TileFace
newface
       localRevDedges :: [(Vertex, Vertex)]
localRevDedges =  [(Vertex
b,Vertex
a) | Vertex
v <- TileFace -> [Vertex]
faceVList TileFace
newface, TileFace
f <- BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd VertexMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
v, (Vertex
a,Vertex
b) <- TileFace -> [(Vertex, Vertex)]
faceDedges TileFace
f]
       matchedDedges :: [(Vertex, Vertex)]
matchedDedges = [(Vertex, Vertex)]
fDedges [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [(Vertex, Vertex)]
localRevDedges -- list of 2 or 3
       -- matchedDedges = fDedges `intersect` boundary bd -- list of 2 or 3
       removedBVs :: [Vertex]
removedBVs = [(Vertex, Vertex)] -> [Vertex]
commonVs [(Vertex, Vertex)]
matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)
       newDedges :: [(Vertex, Vertex)]
newDedges = ((Vertex, Vertex) -> (Vertex, Vertex))
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> (Vertex, Vertex)
reverseD ([(Vertex, Vertex)]
fDedges [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Vertex, Vertex)]
matchedDedges) -- one or none
       nbrFaces :: [TileFace]
nbrFaces = [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a]
nub ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Vertex -> [TileFace]) -> [Vertex] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd) [Vertex]
removedBVs
       resultBd :: BoundaryState
resultBd = BoundaryState
                   { boundaryDedges :: [(Vertex, Vertex)]
boundaryDedges = [(Vertex, Vertex)]
newDedges [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [a] -> [a] -> [a]
++ (BoundaryState -> [(Vertex, Vertex)]
boundaryDedges BoundaryState
bd [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Vertex, Vertex)]
matchedDedges)
                   , bvFacesMap :: VertexMap [TileFace]
bvFacesMap = (VertexMap [TileFace] -> Vertex -> VertexMap [TileFace])
-> VertexMap [TileFace] -> [Vertex] -> VertexMap [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Vertex -> VertexMap [TileFace] -> VertexMap [TileFace])
-> VertexMap [TileFace] -> Vertex -> VertexMap [TileFace]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> VertexMap [TileFace] -> VertexMap [TileFace]
forall a. Vertex -> IntMap a -> IntMap a
VMap.delete) (TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMap TileFace
newface (VertexMap [TileFace] -> VertexMap [TileFace])
-> VertexMap [TileFace] -> VertexMap [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd) [Vertex]
removedBVs
--                   , bvFacesMap = changeVFMap newface (bvFacesMap bd)
                   , allFaces :: [TileFace]
allFaces = TileFace
newfaceTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:BoundaryState -> [TileFace]
allFaces BoundaryState
bd
                   , bvLocMap :: VertexMap (Point V2 Double)
bvLocMap = (Vertex
 -> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double))
-> VertexMap (Point V2 Double)
-> [Vertex]
-> VertexMap (Point V2 Double)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Vertex
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
forall a. Vertex -> IntMap a -> IntMap a
VMap.delete (BoundaryState -> VertexMap (Point V2 Double)
bvLocMap BoundaryState
bd) [Vertex]
removedBVs
                               --remove vertex/vertices no longer on boundary
                   , nextVertex :: Vertex
nextVertex = BoundaryState -> Vertex
nextVertex BoundaryState
bd
                   }
       bdChange :: BoundaryChange
bdChange = BoundaryChange
                   { newBoundaryState :: BoundaryState
newBoundaryState = BoundaryState
resultBd
                   , removedEdges :: [(Vertex, Vertex)]
removedEdges = [(Vertex, Vertex)]
matchedDedges
                   , revisedEdges :: [(Vertex, Vertex)]
revisedEdges = BoundaryState -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
affectedBoundary BoundaryState
resultBd [(Vertex, Vertex)]
newDedges
                   , newFace :: TileFace
newFace = TileFace
newface
                   }
   in if TileFace -> [TileFace] -> Bool
noNewConflict TileFace
newface [TileFace]
nbrFaces
      then BoundaryChange -> Try BoundaryChange
forall a b. b -> Either a b
Right BoundaryChange
bdChange
      else [String] -> Try BoundaryChange
forall a. [String] -> Try a
failReports
              [String
"trySafeUpdate:(incorrect tiling)\nConflicting new face  "
              ,TileFace -> String
forall a. Show a => a -> String
show TileFace
newface
              ,String
"\nwith neighbouring faces\n"
              ,[TileFace] -> String
forall a. Show a => a -> String
show [TileFace]
nbrFaces
              ,String
"\n"
              ]


-- | given 2 consecutive directed edges (not necessarily in the right order),
-- this returns the common vertex (as a singleton list).
-- Exceptionally it may be given 3 consecutive directed edges forming a triangle
-- and returns the 3 vertices of the triangle.
-- It raises an error if the argument is not one of these 2 cases.
commonVs :: [Dedge] -> [Vertex]
commonVs :: [(Vertex, Vertex)] -> [Vertex]
commonVs [(Vertex
a,Vertex
b),(Vertex
c,Vertex
d)] | Vertex
bVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c = [Vertex
b]
                       | Vertex
dVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a = [Vertex
a]
                       | Bool
otherwise = String -> [Vertex]
forall a. HasCallStack => String -> a
error (String -> [Vertex]) -> String -> [Vertex]
forall a b. (a -> b) -> a -> b
$ String
"commonVs: 2 directed edges not consecutive: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex
a,Vertex
b),(Vertex
c,Vertex
d)] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
commonVs [(Vertex
a,Vertex
b),(Vertex
c,Vertex
d),(Vertex
e,Vertex
f)] | [Vertex] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ([Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
nub [Vertex
a,Vertex
b,Vertex
c,Vertex
d,Vertex
e,Vertex
f]) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
3 = [Vertex
a,Vertex
c,Vertex
e]
commonVs [(Vertex, Vertex)]
es = String -> [Vertex]
forall a. HasCallStack => String -> a
error (String -> [Vertex]) -> String -> [Vertex]
forall a b. (a -> b) -> a -> b
$ String
"commonVs: unexpected argument edges (not 2 consecutive directed edges or 3 round triangle): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)] -> String
forall a. Show a => a -> String
show [(Vertex, Vertex)]
es  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- |tryUpdate: tries a single update (safe or unsafe),
-- producing Left report if the update creates a touching vertex in the unsafe case,
-- or if a stuck/incorrect Tgraph is discovered in the safe case.
tryUpdate:: BoundaryState -> Update -> Try BoundaryChange
tryUpdate :: BoundaryState -> Update -> Try BoundaryChange
tryUpdate BoundaryState
bd u :: Update
u@(SafeUpdate TileFace
_) = BoundaryState -> Update -> Try BoundaryChange
trySafeUpdate BoundaryState
bd Update
u
tryUpdate BoundaryState
bd u :: Update
u@(UnsafeUpdate Vertex -> TileFace
_) =
  case BoundaryState -> Update -> Maybe BoundaryChange
checkUnsafeUpdate BoundaryState
bd Update
u of
       Just BoundaryChange
bdC -> BoundaryChange -> Try BoundaryChange
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return BoundaryChange
bdC
       Maybe BoundaryChange
Nothing ->  String -> Try BoundaryChange
forall a. String -> Try a
failReport String
"tryUpdate: crossing boundary (touching vertices).\n"

-- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices.
-- (Used at intervals in tryRecalibratingForce and recalibratingForce).
recalculateBVLocs :: BoundaryState -> BoundaryState
recalculateBVLocs :: BoundaryState -> BoundaryState
recalculateBVLocs BoundaryState
bd = BoundaryState
bd {bvLocMap = newlocs} where
    newlocs :: VertexMap (Point V2 Double)
newlocs = (Vertex -> Point V2 Double -> Bool)
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
forall a. (Vertex -> a -> Bool) -> IntMap a -> IntMap a
VMap.filterWithKey (\Vertex
k Point V2 Double
_ -> Vertex
k Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
bvs) (VertexMap (Point V2 Double) -> VertexMap (Point V2 Double))
-> VertexMap (Point V2 Double) -> VertexMap (Point V2 Double)
forall a b. (a -> b) -> a -> b
$ [TileFace] -> VertexMap (Point V2 Double)
forall a. HasFaces a => a -> VertexMap (Point V2 Double)
locateVertices ([TileFace] -> VertexMap (Point V2 Double))
-> [TileFace] -> VertexMap (Point V2 Double)
forall a b. (a -> b) -> a -> b
$ BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces BoundaryState
bd
    bvs :: [Vertex]
bvs = (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst ((Vertex, Vertex) -> Vertex) -> [(Vertex, Vertex)] -> [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd

-- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch.
-- This is needed to limit accumulated inaccuracies when large numbers of faces are added in forcing.
tryRecalibratingForce :: Forcible c => c -> Try c
tryRecalibratingForce :: forall a. Forcible a => a -> Try a
tryRecalibratingForce = (ForceState -> Try ForceState) -> c -> Try c
forall a.
Forcible a =>
(ForceState -> Try ForceState) -> a -> Try a
tryFSOp ForceState -> Try ForceState
recalibrating where
   recalibrating :: ForceState -> Try ForceState
recalibrating ForceState
fs = do
       ForceState
fs' <- Vertex -> ForceState -> Try ForceState
forall a. Forcible a => Vertex -> a -> Try a
tryStepForce Vertex
20000 ForceState
fs
       if UpdateMap -> Bool
forall a. Map (Vertex, Vertex) a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UpdateMap -> Bool) -> UpdateMap -> Bool
forall a b. (a -> b) -> a -> b
$ ForceState -> UpdateMap
updateMap ForceState
fs'
       then ForceState -> Try ForceState
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ForceState
fs'
       else ForceState -> Try ForceState
recalibrating (ForceState -> Try ForceState) -> ForceState -> Try ForceState
forall a b. (a -> b) -> a -> b
$ ForceState
fs' {boundaryState = recalculateBVLocs $ boundaryState fs'}

-- |A version of force that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch.
-- This is needed to limit accumulation of errors when large numbers of faces are added in forcing.
-- This raises an error on discovering a stuck/incorrect Forcible.
recalibratingForce :: Forcible c => c -> c
recalibratingForce :: forall a. Forcible a => a -> a
recalibratingForce = Try c -> c
forall a. Try a -> a
runTry (Try c -> c) -> (c -> Try c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Try c
forall a. Forcible a => a -> Try a
tryRecalibratingForce



{- $rules
FORCING RULES:

1. (wholeTileUpdates) When a join edge is on the boundary - add the missing half tile to make a whole tile.    
2. (aceKiteUpdates) When a half dart has its short edge on the boundary
   add the half kite that must be on the short edge
   (this is at ace vertices but also helps with jack and deuce vertices).  
3. (queenOrKingUpdates) When a vertex is both a dart origin and a kite wing it must be a queen or king vertex.
   If there is a boundary short edge of a kite half at the vertex, 
   add another kite half sharing the short edge. 
   (This converts 1 kite to 2 and 3 kites to 4 in combination with the first rule).
4. (deuceDartUpdates) When two half kites share a short edge their oppV vertex must be a deuce vertex.
   Add any missing half darts needed to complete the vertex.
5. (jackDartUpdates) When a single dart wing is at a vertex which is recognised as an incomplete jack vertex
   and has a complete kite below the dart wing, 
   add a second dart half touching at the vertex (sharing the kite below).
6. (sunStarUpdates) When a vertex has 3 or 4 whole kite origins (= 6 or 8 half kite origins)
   it must be a sun centre. Also if a vertex has 4 whole dart origins (= 8 half dart origins)
   it must be a star centre.
   Add an appropriate half kite/dart on a boundary long edge at the vertex.
   (This will complete suns (resp. stars) along with rule 1),
7. (jackKiteUpdates) When a dart half has its wing recognised as a jack vertex
   add a missing kite half on its long edge.
8. (kingDartUpdates) When a vertex is a kite wing and also an origin for exactly 4 dart halves
   it must be a king vertex.
   Add a missing dart half (on any boundary long edge of a dart at the vertex).
9. (queenDartUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen)
   add any missing half dart on a boundary kite long edge. (More than 2 is still valid - was =4)
10.(queenKiteUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen)
   add any missing fourth half kite on a boundary kite short edge. (More than 2 rather than =3 to trap false queen case)

There is an update generator for each rule as well as combined update generators (defaultAllUGen, allUGenerator).

The rules are based on the 7 vertex types:

sun, star, jack, queen, king, ace (fool), deuce

-}

{-------------------  FORCING RULES and Update Generators --------------------------
7 vertex types are:
sun, queen, jack (largeDartBase), ace (fool), deuce (largeKiteCentre), king, star
-}

-- |combineUpdateGenerators combines a list of update generators into a single update generator.
-- When used, the generators are tried in order on each boundary edge (in the supplied focus edges),
-- and will return a Left..(fail report) for the first generator that produces a Left..(fail report) if any.
combineUpdateGenerators :: [UpdateGenerator] -> UpdateGenerator
combineUpdateGenerators :: [UpdateGenerator] -> UpdateGenerator
combineUpdateGenerators [UpdateGenerator]
gens = (BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap)
-> UpdateGenerator
UpdateGenerator BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
genf where
  genf :: BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
genf BoundaryState
bd [(Vertex, Vertex)]
focus =
    do let addGen :: Either ShowS ([(Vertex, Vertex)], UpdateMap)
-> UpdateGenerator -> Either ShowS ([(Vertex, Vertex)], UpdateMap)
addGen (Right ([(Vertex, Vertex)]
es,UpdateMap
umap)) UpdateGenerator
gen =
             do UpdateMap
umap' <- UpdateGenerator
-> BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
applyUG UpdateGenerator
gen BoundaryState
bd [(Vertex, Vertex)]
es
                let es' :: [(Vertex, Vertex)]
es' = [(Vertex, Vertex)]
es [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a] -> [a]
\\ UpdateMap -> [(Vertex, Vertex)]
forall k a. Map k a -> [k]
Map.keys UpdateMap
umap'
                ([(Vertex, Vertex)], UpdateMap)
-> Either ShowS ([(Vertex, Vertex)], UpdateMap)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Vertex, Vertex)]
es',UpdateMap -> UpdateMap -> UpdateMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union UpdateMap
umap' UpdateMap
umap)
           addGen Either ShowS ([(Vertex, Vertex)], UpdateMap)
other UpdateGenerator
_  = Either ShowS ([(Vertex, Vertex)], UpdateMap)
other  -- fails with first failing generator
       ([(Vertex, Vertex)]
_ , UpdateMap
umap) <- (Either ShowS ([(Vertex, Vertex)], UpdateMap)
 -> UpdateGenerator -> Either ShowS ([(Vertex, Vertex)], UpdateMap))
-> Either ShowS ([(Vertex, Vertex)], UpdateMap)
-> [UpdateGenerator]
-> Either ShowS ([(Vertex, Vertex)], UpdateMap)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either ShowS ([(Vertex, Vertex)], UpdateMap)
-> UpdateGenerator -> Either ShowS ([(Vertex, Vertex)], UpdateMap)
addGen (([(Vertex, Vertex)], UpdateMap)
-> Either ShowS ([(Vertex, Vertex)], UpdateMap)
forall a b. b -> Either a b
Right ([(Vertex, Vertex)]
focus,UpdateMap
forall k a. Map k a
Map.empty)) [UpdateGenerator]
gens
       UpdateMap -> Try UpdateMap
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return UpdateMap
umap

{-| allUGenerator was the original generator for all updates.
    It combines the individual update generators for each of the 10 rules in sequence using combineUpdateGenerators
    (See also defaultAllUGen which is defined without using combineUpdateGenerators)
-}
allUGenerator :: UpdateGenerator
allUGenerator :: UpdateGenerator
allUGenerator = [UpdateGenerator] -> UpdateGenerator
combineUpdateGenerators [UpdateGenerator]
generators where
    generators :: [UpdateGenerator]
generators = [ UpdateGenerator
wholeTileUpdates          -- (rule 1)
                 , UpdateGenerator
aceKiteUpdates            -- (rule 2)
                 , UpdateGenerator
queenOrKingUpdates        -- (rule 3)
                 , UpdateGenerator
deuceDartUpdates          -- (rule 4)
                 , UpdateGenerator
jackDartUpdates           -- (rule 5)
                 , UpdateGenerator
sunStarUpdates            -- (rule 6)
                 , UpdateGenerator
jackKiteUpdates           -- (rule 7)
                 , UpdateGenerator
kingDartUpdates           -- (rule 8)
                 , UpdateGenerator
queenDartUpdates          -- (rule 9)
                 , UpdateGenerator
queenKiteUpdates          -- (rule 10)
                 ]


-- |UFinder (Update case finder functions). Given a BoundaryState and a list of (focus) boundary directed edges,
-- such a function returns each focus edge satisfying the particular update case paired with the tileface
-- matching that edge. For example, if the function is looking for dart short edges on the boundary,
-- it will return only those focus edges which are half-dart short edges,
-- each paired with its half-dart face.
type UFinder = BoundaryState -> [Dedge] -> [(Dedge,TileFace)]

-- |UChecker (Update checker functions). Given a BoundaryState and a particular tileface (on the boundary),
-- such functions try to produce particular updates on the boundary edge of the given tileface.
-- [They are called update checkers because they may uncover an incorrect/stuck tiling
-- when creating the update.]
-- As an example, addKiteShortE will try to produce an update to add a half-kite with short edge against the boundary.
-- Such a function can be used with a UFinder that either returns dart halves with short edge on the boundary
-- (nonKDarts in rule 2) or returns kite halves with short edge on the boundary
-- (kitesWingDartOrigin in rule 3).
type UChecker = BoundaryState -> TileFace -> Try Update

{-|This is a general purpose filter (previously used to create UFinder functions for each force rule).
 It requires a face predicate where
 the face predicate takes a BoundaryState bd, a boundary Dedge (a,b) and the TileFace with the edge (b,a)
 and decides whether the face is wanted or not (True = wanted)
 This will be used to filter all the faces at the focus edges 
 (when given a BoundaryState and list of focus edges).
 For some predicates the BoundaryState argument is not used (eg boundaryJoin in incompleteHalves), 
 but for others it is used to look at other faces at b or at a besides the supplied face 
 (eg in kitesWingDartOrigin) 
-}
boundaryFilter::  (BoundaryState -> Dedge -> TileFace -> Bool) -> UFinder
boundaryFilter :: (BoundaryState -> (Vertex, Vertex) -> TileFace -> Bool) -> UFinder
boundaryFilter BoundaryState -> (Vertex, Vertex) -> TileFace -> Bool
predF BoundaryState
bd [(Vertex, Vertex)]
focus =
    [ ((Vertex, Vertex)
e,TileFace
fc) | (Vertex, Vertex)
e <- [(Vertex, Vertex)]
focus
             , TileFace
fc <- BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd ((Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst (Vertex, Vertex)
e)
             , TileFace
fc TileFace -> [TileFace] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd ((Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd (Vertex, Vertex)
e)
             , BoundaryState -> (Vertex, Vertex) -> TileFace -> Bool
predF BoundaryState
bd (Vertex, Vertex)
e TileFace
fc
             ]


{-|This is a general purpose filter used to create UFinder functions for each force rule.
 It requires an edgeType and a face predicate.
 The face predicate takes a BoundaryState bd, and a TileFace
 and (assuming the boundary edge of the face matches the given edgeType)
 decides whether the face is wanted or not (True = wanted).
 This will be used to filter all the faces at the focus edges 
 (when given a BoundaryState and list of focus edges).
 For some predicates the BoundaryState argument is not used (eg boundaryJoin in incompleteHalves), 
 but for others it is used to look at other faces besides the supplied face 
 (eg in kitesWingDartOrigin) 
-}
boundaryEdgeFilter::  EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter :: EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
etype BoundaryState -> TileFace -> Bool
predF BoundaryState
bd [(Vertex, Vertex)]
focus =
     [ ((Vertex, Vertex)
e,TileFace
fc) | (Vertex, Vertex)
e <- [(Vertex, Vertex)]
focus
              , let (TileFace
fc,EdgeType
etype') = BoundaryState -> (Vertex, Vertex) -> (TileFace, EdgeType)
inspectBDedge BoundaryState
bd (Vertex, Vertex)
e
              , EdgeType
etype EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
etype'
              , BoundaryState -> TileFace -> Bool
predF BoundaryState
bd TileFace
fc
              ]

-- |makeUpdate f x constructs a safe update if x is Just(..) and an unsafe update if x is Nothing
makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex ->  Update
makeUpdate :: (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
f (Just Vertex
v) = TileFace -> Update
SafeUpdate (Vertex -> TileFace
f Vertex
v)
makeUpdate Vertex -> TileFace
f Maybe Vertex
Nothing  = (Vertex -> TileFace) -> Update
UnsafeUpdate Vertex -> TileFace
f



-- |A vertex on the boundary must be a star if it has 7 or more dart origins
mustbeStar:: BoundaryState -> Vertex -> Bool
mustbeStar :: BoundaryState -> Vertex -> Bool
mustbeStar BoundaryState
bd Vertex
v = [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
v) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
originV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v) Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>= Vertex
7

-- |A vertex on the boundary must be a sun if it has 5 or more kite origins
mustbeSun:: BoundaryState -> Vertex -> Bool
mustbeSun :: BoundaryState -> Vertex -> Bool
mustbeSun BoundaryState
bd Vertex
v = [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
v) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
originV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v) Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>= Vertex
5

-- |A vertex on the boundary which is an oppV of a kite must be a deuce
-- if there is a shared kite short edge at the vertex.
mustbeDeuce:: BoundaryState -> Vertex -> Bool
mustbeDeuce :: BoundaryState -> Vertex -> Bool
mustbeDeuce BoundaryState
bd Vertex
v = BoundaryState -> Vertex -> Bool
isKiteOppV BoundaryState
bd Vertex
v Bool -> Bool -> Bool
&&
                   [(Vertex, Vertex)] -> Bool
hasAnyMatchingE ((TileFace -> (Vertex, Vertex)) -> [TileFace] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> (Vertex, Vertex)
shortE ([TileFace] -> [(Vertex, Vertex)])
-> [TileFace] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v)

-- |A boundary vertex which is a kite wing and has 4 dart origins must be a king vertex
mustbeKing:: BoundaryState -> Vertex -> Bool
mustbeKing :: BoundaryState -> Vertex -> Bool
mustbeKing BoundaryState
bd Vertex
v = BoundaryState -> Vertex -> Bool
isKiteWing BoundaryState
bd Vertex
v Bool -> Bool -> Bool
&& [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
dartOrigins Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
4
   where  dartOrigins :: [TileFace]
dartOrigins = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
v) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
originV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v

{-
-- |A boundary vertex which is a kite wing and dart origin must be either a king or queen
mustbeQorK:: BoundaryState -> Vertex -> Bool
mustbeQorK bd v = isDartOrigin bd v && isKiteWing bd v
-}

-- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd
isKiteWing:: BoundaryState -> Vertex -> Bool
isKiteWing :: BoundaryState -> Vertex -> Bool
isKiteWing BoundaryState
bd Vertex
v = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
wingV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v))

-- |isKiteOppV bd v - Vertex v is a kite oppV in BoundaryState bd
isKiteOppV:: BoundaryState -> Vertex -> Bool
isKiteOppV :: BoundaryState -> Vertex -> Bool
isKiteOppV BoundaryState
bd Vertex
v = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
oppV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v))

-- |isDartOrigin bd v - Vertex v is a dart origin in BoundaryState bd
isDartOrigin:: BoundaryState -> Vertex -> Bool
isDartOrigin :: BoundaryState -> Vertex -> Bool
isDartOrigin BoundaryState
bd Vertex
v = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v))

-- |A boundary vertex with >2 kite wings is a queen vertex 
-- (needing a fourth kite on a kite short edge or dart on a kite long edge)
mustbeQueen:: BoundaryState -> Vertex -> Bool
mustbeQueen :: BoundaryState -> Vertex -> Bool
mustbeQueen BoundaryState
bd Vertex
v = BoundaryState -> Vertex -> Vertex
kiteWingCount BoundaryState
bd Vertex
v Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>Vertex
2

-- |kiteWingCount bd v - the number of kite wings at v in BoundaryState bd
kiteWingCount:: BoundaryState -> Vertex -> Int
kiteWingCount :: BoundaryState -> Vertex -> Vertex
kiteWingCount BoundaryState
bd Vertex
v = [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ([TileFace] -> Vertex) -> [TileFace] -> Vertex
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
v) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
wingV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v)

-- |mustbeJack  is true of a boundary vertex if
-- it is the wing of two darts not sharing a long edge or
-- it is a wing of a dart and also a kite origin
-- (false means it is either undetermined or is a deuce).
mustbeJack :: BoundaryState -> Vertex -> Bool
mustbeJack :: BoundaryState -> Vertex -> Bool
mustbeJack BoundaryState
bd Vertex
v =
  ([TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
dWings Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Vertex, Vertex)] -> Bool
hasAnyMatchingE ((TileFace -> (Vertex, Vertex)) -> [TileFace] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> (Vertex, Vertex)
longE [TileFace]
dWings))) Bool -> Bool -> Bool
|| -- 2 dart wings and dart long edges not shared.
  ([TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
dWings Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
1 Bool -> Bool -> Bool
&& Bool
isKiteOrigin)
  where fcs :: [TileFace]
fcs = BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v
        dWings :: [TileFace]
dWings = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
v) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
wingV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart [TileFace]
fcs
        isKiteOrigin :: Bool
isKiteOrigin = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs)

-- |hasMatching asks if a directed edge list has any two matching (=opposing) directed edges.
hasAnyMatchingE :: [Dedge] -> Bool
hasAnyMatchingE :: [(Vertex, Vertex)] -> Bool
hasAnyMatchingE ((Vertex
x,Vertex
y):[(Vertex, Vertex)]
more) = (Vertex
y,Vertex
x) (Vertex, Vertex) -> [(Vertex, Vertex)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Vertex, Vertex)]
more Bool -> Bool -> Bool
|| [(Vertex, Vertex)] -> Bool
hasAnyMatchingE [(Vertex, Vertex)]
more
hasAnyMatchingE [] = Bool
False

{-| newUpdateGenerator combines an update case finder (UFinder) with its corresponding update checker (UChecker)
    to produce an update generator.
    This is used to make each of the 10 update generators corresponding to 10 rules. 
    
    When the generator is applied (with applyUG) to a BoundaryState and list of focus edges,
    the finder produces a list of pairs of dedge and face,
    the checker is used to convert the face in each pair to an update (which can fail with a Left report),
    and the new updates are returned as a map (with the dedges as keys) in a Right result.
-}
newUpdateGenerator :: UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator :: UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
checker UFinder
finder = (BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap)
-> UpdateGenerator
UpdateGenerator BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
genf where
  genf :: BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
genf BoundaryState
bd [(Vertex, Vertex)]
edges = (Try UpdateMap -> ((Vertex, Vertex), TileFace) -> Try UpdateMap)
-> Try UpdateMap -> [((Vertex, Vertex), TileFace)] -> Try UpdateMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Try UpdateMap -> ((Vertex, Vertex), TileFace) -> Try UpdateMap
forall {k}.
Ord k =>
Either ShowS (Map k Update)
-> (k, TileFace) -> Either ShowS (Map k Update)
addU (UpdateMap -> Try UpdateMap
forall a b. b -> Either a b
Right UpdateMap
forall k a. Map k a
Map.empty) (UFinder
finder BoundaryState
bd [(Vertex, Vertex)]
edges) where
     addU :: Either ShowS (Map k Update)
-> (k, TileFace) -> Either ShowS (Map k Update)
addU (Left ShowS
x) (k, TileFace)
_          = ShowS -> Either ShowS (Map k Update)
forall a b. a -> Either a b
Left ShowS
x
     addU (Right Map k Update
ump) (k
e,TileFace
fc)  = do Update
u <- UChecker
checker BoundaryState
bd TileFace
fc
                                   Map k Update -> Either ShowS (Map k Update)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> Update -> Map k Update -> Map k Update
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
e Update
u Map k Update
ump)

{-  makeGenerator (deprecated) this is renamed as newUpdateGenerator.
makeGenerator :: UChecker -> UFinder -> UpdateGenerator
makeGenerator = newUpdateGenerator
 -}

--   Ten Update Generators (with corresponding Finders)


-- |Update generator for rule (1)
wholeTileUpdates:: UpdateGenerator
wholeTileUpdates :: UpdateGenerator
wholeTileUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
completeHalf UFinder
incompleteHalves

-- |Find faces with missing opposite face (mirror face)  
incompleteHalves :: UFinder
incompleteHalves :: UFinder
incompleteHalves = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Join BoundaryState -> TileFace -> Bool
forall {p} {p}. p -> p -> Bool
anyFace where
    anyFace :: p -> p -> Bool
anyFace p
_ p
_ = Bool
True
{- incompleteHalves = boundaryFilter boundaryJoin where
    boundaryJoin _ (a,b) fc = joinE fc == (b,a)
 -}

-- |Update generator for rule (2)
aceKiteUpdates :: UpdateGenerator
aceKiteUpdates :: UpdateGenerator
aceKiteUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addKiteShortE UFinder
nonKDarts

-- |Find half darts with boundary short edge
nonKDarts :: UFinder
nonKDarts :: UFinder
nonKDarts = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Short BoundaryState -> TileFace -> Bool
forall {p} {rep}. p -> HalfTile rep -> Bool
foundDart where
    foundDart :: p -> HalfTile rep -> Bool
foundDart p
_ = HalfTile rep -> Bool
forall rep. HalfTile rep -> Bool
isDart
{- nonKDarts = boundaryFilter bShortDarts where
    bShortDarts _ (a,b) fc = isDart fc && shortE fc == (b,a)
 -}

-- |Update generator for rule (3)
 -- queen and king vertices add a missing kite half (on a boundary kite short edge)
queenOrKingUpdates :: UpdateGenerator
queenOrKingUpdates :: UpdateGenerator
queenOrKingUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addKiteShortE UFinder
kitesWingDartOrigin

-- |Find kites with boundary short edge where the wing is also a dart origin
kitesWingDartOrigin :: UFinder
kitesWingDartOrigin :: UFinder
kitesWingDartOrigin = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Short BoundaryState -> TileFace -> Bool
kiteWDO where
   kiteWDO :: BoundaryState -> TileFace -> Bool
kiteWDO BoundaryState
bd TileFace
fc = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
isDartOrigin BoundaryState
bd (TileFace -> Vertex
wingV TileFace
fc)
{- kitesWingDartOrigin = boundaryFilter kiteWDO where
   kiteWDO bd (a,b) fc = shortE fc == (b,a)
                         && isKite fc && isDartOrigin bd (wingV fc)
 -}

{-| Update generator for rule (4)
     (for deuce vertices = largeKiteCentres)
     Kites whose short edge (b,a) matches a boundary edge (a,b) where their oppV 
     has 2 other kite halves sharing a shortE.
     These need a dart adding on the short edge.
-}
deuceDartUpdates :: UpdateGenerator
deuceDartUpdates :: UpdateGenerator
deuceDartUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addDartShortE UFinder
kiteGaps

-- |Find kite halves with a short edge on the boundary 
-- where there are 2 other kite halves sharing a short edge
-- at oppV of the kite half.
kiteGaps :: UFinder
kiteGaps :: UFinder
kiteGaps = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Short BoundaryState -> TileFace -> Bool
kiteGap where
  kiteGap :: BoundaryState -> TileFace -> Bool
kiteGap BoundaryState
bd TileFace
fc = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeDeuce BoundaryState
bd (TileFace -> Vertex
oppV TileFace
fc)
{- kiteGaps = boundaryFilter kiteGap where
  kiteGap bd (a,b) fc = shortE fc == (b,a)
                        && isKite fc && mustbeDeuce bd (oppV fc)
 -}

-- |Update generator for rule (5)
-- jackDartUpdates - jack vertex add a missing second dart
jackDartUpdates :: UpdateGenerator
jackDartUpdates :: UpdateGenerator
jackDartUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addDartShortE UFinder
noTouchingDart

-- |Find kite halves with a short edge on the boundary where oppV must be a jack vertex
-- The function mustbeJack finds if a vertex must be a jack.
noTouchingDart :: UFinder
noTouchingDart :: UFinder
noTouchingDart = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Short BoundaryState -> TileFace -> Bool
farKOfDarts where
   farKOfDarts :: BoundaryState -> TileFace -> Bool
farKOfDarts BoundaryState
bd TileFace
fc  = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeJack BoundaryState
bd (TileFace -> Vertex
oppV TileFace
fc)
{- noTouchingDart = boundaryFilter farKOfDarts where
   farKOfDarts bd (a,b) fc  = shortE fc == (b,a)
                              && isKite fc && mustbeJack bd (oppV fc)
 -}

{-| Update generator for rule (6)
sunStarUpdates is for vertices that must be either sun or star 
almostSunStar finds half-kites/half-darts with a long edge on the boundary
where their origin vertex has 8 total half-kites/half-darts respectively
or their origin vertex has 6 total half-kites in the case of kites only
completeSunStar will add a new face of the same type (dart/kite) 
sharing the long edge.
-}
sunStarUpdates :: UpdateGenerator
sunStarUpdates :: UpdateGenerator
sunStarUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
completeSunStar UFinder
almostSunStar

-- |Find a boundary long edge of either
-- a dart where there are at least 7 dart origins (mustbeStar), or
-- a kite where there are at least 5 kite origins (mustbeSun).
almostSunStar :: UFinder
almostSunStar :: UFinder
almostSunStar = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Long BoundaryState -> TileFace -> Bool
multiples57 where
    multiples57 :: BoundaryState -> TileFace -> Bool
multiples57 BoundaryState
bd TileFace
fc = 
        (TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeStar BoundaryState
bd (TileFace -> Vertex
originV TileFace
fc)) Bool -> Bool -> Bool
||
        (TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeSun BoundaryState
bd (TileFace -> Vertex
originV TileFace
fc))
{- almostSunStar = boundaryFilter multiples57 where
    multiples57 bd (a,b) fc = longE fc == (b,a) &&
        ((isDart fc && mustbeStar bd (originV fc)) ||
         (isKite fc && mustbeSun bd (originV fc))
        )
 -}

-- |Update generator for rule (7)
-- jack vertices with dart long edge on the boundary - add missing kite top.
-- The function mustbeJack finds if a vertex must be a jack.
jackKiteUpdates :: UpdateGenerator
jackKiteUpdates :: UpdateGenerator
jackKiteUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addKiteLongE UFinder
jackMissingKite

-- |Find a boundary long edge of a dart where the wingV is a jack vertex.
-- The function mustbeJack finds if a vertex must be a jack.
jackMissingKite :: UFinder
jackMissingKite :: UFinder
jackMissingKite = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Long BoundaryState -> TileFace -> Bool
dartsWingDB where
    dartsWingDB :: BoundaryState -> TileFace -> Bool
dartsWingDB BoundaryState
bd TileFace
fc = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeJack BoundaryState
bd (TileFace -> Vertex
wingV TileFace
fc)
{- jackMissingKite = boundaryFilter dartsWingDB where
    dartsWingDB bd (a,b) fc = longE fc == (b,a) &&
                              isDart fc && mustbeJack bd (wingV fc)
 -}
-- |Update generator for rule (8)
-- king vertices with 2 of the 3 darts  - add another half dart on a boundary long edge of existing darts
kingDartUpdates :: UpdateGenerator
kingDartUpdates :: UpdateGenerator
kingDartUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addDartLongE UFinder
kingMissingThirdDart

-- |Find a dart long edge on the boundary where the originV must be a king vertex.
-- The function mustbeKing finds if a vertex must be a king
-- (2 of the 3 darts at the origin plus a kite wing at the origin).
kingMissingThirdDart :: UFinder
kingMissingThirdDart :: UFinder
kingMissingThirdDart = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Long BoundaryState -> TileFace -> Bool
predicate where
    predicate :: BoundaryState -> TileFace -> Bool
predicate BoundaryState
bd TileFace
fc = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
fc Bool -> Bool -> Bool
&& BoundaryState -> Vertex -> Bool
mustbeKing BoundaryState
bd (TileFace -> Vertex
originV TileFace
fc)
{- kingMissingThirdDart = boundaryFilter predicate where
    predicate bd (a,b) fc = longE fc == (b,a) &&
        isDart fc && mustbeKing bd (originV fc)

 -}
-- |Update generator for rule (9)
-- queen vertices (more than 2 kite wings) with a boundary kite long edge - add a half dart
queenDartUpdates :: UpdateGenerator
queenDartUpdates :: UpdateGenerator
queenDartUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addDartLongE UFinder
queenMissingDarts

-- |Find a boundary kite long edge where the wingV must be a queen vertex
-- (more than 2 kite wings at the wingV).
queenMissingDarts :: UFinder
queenMissingDarts :: UFinder
queenMissingDarts = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Long BoundaryState -> TileFace -> Bool
predicate where
    predicate :: BoundaryState -> TileFace -> Bool
predicate BoundaryState
bd TileFace
fc = TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
kiteWings Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>Vertex
2
           where fcWing :: Vertex
fcWing = TileFace -> Vertex
wingV TileFace
fc
                 kiteWings :: [TileFace]
kiteWings = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
fcWing) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
wingV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$
                             (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
fcWing
{- queenMissingDarts = boundaryFilter predicate where
    predicate bd (a,b) fc =
        longE fc == (b,a) && isKite fc && length kiteWings >2
           where fcWing = wingV fc
                 kiteWings = filter ((==fcWing) . wingV) $
                             filter isKite $ facesAtBV bd fcWing
 -}
-- |Update generator for rule (10)
-- queen vertices with more than 2 kite wings -- add missing half kite on a boundary kite short edge
queenKiteUpdates :: UpdateGenerator
queenKiteUpdates :: UpdateGenerator
queenKiteUpdates = UChecker -> UFinder -> UpdateGenerator
newUpdateGenerator UChecker
addKiteShortE UFinder
queenMissingKite

-- |Find a kite short edge on the boundary where the wingV must be a queen vertex
-- (more than 2 kite wings at the wingV).
queenMissingKite :: UFinder
queenMissingKite :: UFinder
queenMissingKite = EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder
boundaryEdgeFilter EdgeType
Short BoundaryState -> TileFace -> Bool
predicate where
    predicate :: BoundaryState -> TileFace -> Bool
predicate BoundaryState
bd TileFace
fc =
        TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc Bool -> Bool -> Bool
&& [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
kiteWings Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>Vertex
2
        where fcWing :: Vertex
fcWing = TileFace -> Vertex
wingV TileFace
fc
              kiteWings :: [TileFace]
kiteWings = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
fcWing) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
wingV) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite (BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
fcWing)
{- queenMissingKite = boundaryFilter predicate where
    predicate bd (a,b) fc =
        shortE fc == (b,a) && isKite fc && length kiteWings >2
           where fcWing = wingV fc
                 kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing)
 -}

--  Six Update Checkers


-- |completeHalf will check an update to
--  add a symmetric (mirror) face for a given face at a boundary join edge.
completeHalf :: UChecker
completeHalf :: UChecker
completeHalf BoundaryState
bd (LD(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
RD (Vertex
a,b
v,Vertex
b)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
3,Vertex
1) --anglesForJoinRD
completeHalf BoundaryState
bd (RD(Vertex
a,Vertex
_,Vertex
b)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
LD (Vertex
a,Vertex
b,c
v)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
b) (Vertex
1,Vertex
3) --anglesForJoinLD
completeHalf BoundaryState
bd (LK(Vertex
a,Vertex
_,Vertex
b)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
RK (Vertex
a,Vertex
b,c
v)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
b) (Vertex
1,Vertex
2) --anglesForJoinRK
completeHalf BoundaryState
bd (RK(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
LK (Vertex
a,b
v,Vertex
b)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
2,Vertex
1) --anglesForJoinLK

-- |add a (missing) half kite on a (boundary) short edge of a dart or kite
addKiteShortE :: UChecker
addKiteShortE :: UChecker
addKiteShortE BoundaryState
bd (RD(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
LK (a
v,Vertex
c,Vertex
b)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
2,Vertex
2) --anglesForShortLK
addKiteShortE BoundaryState
bd (LD(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
RK (a
v,Vertex
c,Vertex
b)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
2,Vertex
2) --anglesForShortRK
addKiteShortE BoundaryState
bd (LK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
RK (a
v,Vertex
c,Vertex
b)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
2,Vertex
2) --anglesForShortRK
addKiteShortE BoundaryState
bd (RK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
LK (a
v,Vertex
c,Vertex
b)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
2,Vertex
2) --anglesForShortLK

-- |add a half dart top to a boundary short edge of a half kite.
addDartShortE :: UChecker
addDartShortE :: UChecker
addDartShortE BoundaryState
bd (RK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
LD (a
v,Vertex
c,Vertex
b)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
3,Vertex
1) --anglesForShortLD
addDartShortE BoundaryState
bd (LK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {a}. a -> HalfTile (a, Vertex, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
        makeFace :: a -> HalfTile (a, Vertex, Vertex)
makeFace a
v = (a, Vertex, Vertex) -> HalfTile (a, Vertex, Vertex)
forall rep. rep -> HalfTile rep
RD (a
v,Vertex
c,Vertex
b)
        x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
c,Vertex
b) (Vertex
1,Vertex
3) --anglesForShortRD
addDartShortE BoundaryState
_  TileFace
_ = String -> Try Update
forall a. HasCallStack => String -> a
error String
"addDartShortE applied to non-kite face\n"

-- |add a kite half to a kite long edge or dart half to a dart long edge
completeSunStar :: UChecker
completeSunStar :: UChecker
completeSunStar BoundaryState
bd TileFace
fc = if TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite TileFace
fc
                        then UChecker
addKiteLongE BoundaryState
bd TileFace
fc
                        else UChecker
addDartLongE BoundaryState
bd TileFace
fc

-- |add a kite to a long edge of a dart or kite
addKiteLongE :: UChecker
addKiteLongE :: UChecker
addKiteLongE BoundaryState
bd (LD(Vertex
a,Vertex
_,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
RK (Vertex
c,b
v,Vertex
a)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
c) (Vertex
2,Vertex
1) -- anglesForLongRK
addKiteLongE BoundaryState
bd (RD(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
    makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
LK (Vertex
b,Vertex
a,c
v)
    x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
1,Vertex
2) -- anglesForLongLK
addKiteLongE BoundaryState
bd (RK(Vertex
a,Vertex
_,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
LK (Vertex
a,Vertex
c,c
v)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
c) (Vertex
1,Vertex
2) -- anglesForLongLK
addKiteLongE BoundaryState
bd (LK(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
RK (Vertex
a,b
v,Vertex
b)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
2,Vertex
1) -- anglesForLongRK

-- |add a half dart on a boundary long edge of a dart or kite
addDartLongE :: UChecker
addDartLongE :: UChecker
addDartLongE BoundaryState
bd (LD(Vertex
a,Vertex
_,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
RD (Vertex
a,Vertex
c,c
v)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
c) (Vertex
1,Vertex
1) -- anglesForLongRD
addDartLongE BoundaryState
bd (RD(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
LD (Vertex
a,b
v,Vertex
b)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
1,Vertex
1) -- anglesForLongLD
addDartLongE BoundaryState
bd (LK(Vertex
a,Vertex
b,Vertex
_)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {c}. c -> HalfTile (Vertex, Vertex, c)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: c -> HalfTile (Vertex, Vertex, c)
makeFace c
v = (Vertex, Vertex, c) -> HalfTile (Vertex, Vertex, c)
forall rep. rep -> HalfTile rep
RD (Vertex
b,Vertex
a,c
v)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
b,Vertex
a) (Vertex
1,Vertex
1) -- anglesForLongRD
addDartLongE BoundaryState
bd (RK(Vertex
a,Vertex
_,Vertex
c)) = (Vertex -> TileFace) -> Maybe Vertex -> Update
makeUpdate Vertex -> TileFace
forall {b}. b -> HalfTile (Vertex, b, Vertex)
makeFace (Maybe Vertex -> Update)
-> Either ShowS (Maybe Vertex) -> Try Update
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ShowS (Maybe Vertex)
x where
  makeFace :: b -> HalfTile (Vertex, b, Vertex)
makeFace b
v = (Vertex, b, Vertex) -> HalfTile (Vertex, b, Vertex)
forall rep. rep -> HalfTile rep
LD (Vertex
c,b
v,Vertex
a)
  x :: Either ShowS (Maybe Vertex)
x = BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
c) (Vertex
1,Vertex
1) -- anglesForLongLD

{-
-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)
anglesForJoinRD,anglesForJoinLD,anglesForJoinRK,anglesForJoinLK::(Int,Int)
anglesForJoinRD = (3,1)
anglesForJoinLD = (1,3)
anglesForJoinRK = (1,2)
anglesForJoinLK = (2,1)
-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)
anglesForLongLD,anglesForLongRD,anglesForLongRK,anglesForLongLK::(Int,Int)
anglesForLongLD = (1,1)
anglesForLongRD = (1,1)
anglesForLongRK = (2,1)
anglesForLongLK = (1,2)
-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)
anglesForShortLD,anglesForShortRD,anglesForShortLK,anglesForShortRK::(Int,Int)
anglesForShortLD = (3,1)
anglesForShortRD = (1,3)
anglesForShortLK = (2,2)
anglesForShortRK = (2,2)
-}


--  The Default All Update Generator (defaultAllUGen)


-- |The default all update generator (see also allUGenerator). It uses the 10 rules (and the same UCheckers as allUGenerator),
-- but makes decisions based on the EdgeType of a boundary edge (instead of trying each UFinder in turn).
-- If there are any Left..(fail reports) for the given
-- boundary edges the result is a single Left, concatenating all the failure reports (unlike allUGenerator).
defaultAllUGen :: UpdateGenerator
defaultAllUGen :: UpdateGenerator
defaultAllUGen = UpdateGenerator { applyUG :: BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
applyUG = BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
gen } where
  gen :: BoundaryState -> [(Vertex, Vertex)] -> Try UpdateMap
gen BoundaryState
bd [(Vertex, Vertex)]
es = [Try UpdateMap] -> Try UpdateMap
combine ([Try UpdateMap] -> Try UpdateMap)
-> [Try UpdateMap] -> Try UpdateMap
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> Try UpdateMap)
-> [(Vertex, Vertex)] -> [Try UpdateMap]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> Try UpdateMap
decide [(Vertex, Vertex)]
es where -- Either String is a monoid as well as Map
      decide :: (Vertex, Vertex) -> Try UpdateMap
decide (Vertex, Vertex)
e = ((Vertex, Vertex), TileFace, EdgeType) -> Try UpdateMap
forall {k}.
Ord k =>
(k, TileFace, EdgeType) -> Either ShowS (Map k Update)
decider ((Vertex, Vertex)
e,TileFace
f,EdgeType
etype) where (TileFace
f,EdgeType
etype) = BoundaryState -> (Vertex, Vertex) -> (TileFace, EdgeType)
inspectBDedge BoundaryState
bd (Vertex, Vertex)
e

      decider :: (k, TileFace, EdgeType) -> Either ShowS (Map k Update)
decider (k
e,TileFace
f,EdgeType
Join)  = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
completeHalf BoundaryState
bd TileFace
f) -- rule 1
      decider (k
e,TileFace
f,EdgeType
Short)
        | TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
f = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addKiteShortE BoundaryState
bd TileFace
f) -- rule 2
        | Bool
otherwise = k -> TileFace -> Either ShowS (Map k Update)
forall {k}. Ord k => k -> TileFace -> Either ShowS (Map k Update)
kiteShortDecider k
e TileFace
f
      decider (k
e,TileFace
f,EdgeType
Long)
        | TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
f = k -> TileFace -> Either ShowS (Map k Update)
forall {k}. Ord k => k -> TileFace -> Either ShowS (Map k Update)
dartLongDecider k
e TileFace
f
        | Bool
otherwise = k -> TileFace -> Either ShowS (Map k Update)
forall {k}. Ord k => k -> TileFace -> Either ShowS (Map k Update)
kiteLongDecider k
e TileFace
f

      dartLongDecider :: k -> TileFace -> Either ShowS (Map k Update)
dartLongDecider k
e TileFace
f
        | BoundaryState -> Vertex -> Bool
mustbeStar BoundaryState
bd (TileFace -> Vertex
originV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
completeSunStar BoundaryState
bd TileFace
f)
        | BoundaryState -> Vertex -> Bool
mustbeKing BoundaryState
bd (TileFace -> Vertex
originV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addDartLongE BoundaryState
bd TileFace
f)
        | BoundaryState -> Vertex -> Bool
mustbeJack BoundaryState
bd (TileFace -> Vertex
wingV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addKiteLongE BoundaryState
bd TileFace
f)
        | Bool
otherwise = Map k Update -> Either ShowS (Map k Update)
forall a b. b -> Either a b
Right Map k Update
forall k a. Map k a
Map.empty

      kiteLongDecider :: k -> TileFace -> Either ShowS (Map k Update)
kiteLongDecider k
e TileFace
f
        | BoundaryState -> Vertex -> Bool
mustbeSun BoundaryState
bd (TileFace -> Vertex
originV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
completeSunStar BoundaryState
bd TileFace
f)
        | BoundaryState -> Vertex -> Bool
mustbeQueen BoundaryState
bd (TileFace -> Vertex
wingV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addDartLongE BoundaryState
bd TileFace
f)
        | Bool
otherwise = Map k Update -> Either ShowS (Map k Update)
forall a b. b -> Either a b
Right Map k Update
forall k a. Map k a
Map.empty

      kiteShortDecider :: k -> TileFace -> Either ShowS (Map k Update)
kiteShortDecider k
e TileFace
f
        | BoundaryState -> Vertex -> Bool
mustbeDeuce BoundaryState
bd (TileFace -> Vertex
oppV TileFace
f) Bool -> Bool -> Bool
|| BoundaryState -> Vertex -> Bool
mustbeJack BoundaryState
bd (TileFace -> Vertex
oppV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addDartShortE BoundaryState
bd TileFace
f)
        | BoundaryState -> Vertex -> Bool
mustbeQueen BoundaryState
bd (TileFace -> Vertex
wingV TileFace
f) Bool -> Bool -> Bool
|| BoundaryState -> Vertex -> Bool
isDartOrigin BoundaryState
bd (TileFace -> Vertex
wingV TileFace
f) = k -> Try Update -> Either ShowS (Map k Update)
forall {f :: * -> *} {k} {a}.
(Functor f, Ord k) =>
k -> f a -> f (Map k a)
mapItem k
e (UChecker
addKiteShortE BoundaryState
bd TileFace
f)
        | Bool
otherwise = Map k Update -> Either ShowS (Map k Update)
forall a b. b -> Either a b
Right Map k Update
forall k a. Map k a
Map.empty

      mapItem :: k -> f a -> f (Map k a)
mapItem k
e = (a -> Map k a) -> f a -> f (Map k a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
u -> k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
e a
u Map k a
forall k a. Map k a
Map.empty)
      combine :: [Try UpdateMap] -> Try UpdateMap
combine = ([UpdateMap] -> UpdateMap)
-> Either ShowS [UpdateMap] -> Try UpdateMap
forall a b. (a -> b) -> Either ShowS a -> Either ShowS b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UpdateMap] -> UpdateMap
forall a. Monoid a => [a] -> a
mconcat (Either ShowS [UpdateMap] -> Try UpdateMap)
-> ([Try UpdateMap] -> Either ShowS [UpdateMap])
-> [Try UpdateMap]
-> Try UpdateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Try UpdateMap] -> Either ShowS [UpdateMap]
forall a. [Try a] -> Try [a]
concatFails -- concatenates all failure reports if there are any
                                           -- otherwise combines the update maps with mconcat


-- |Given a BoundaryState and a directed boundary edge, this returns the same edge with
-- the unique face on that edge and the edge type for that face and edge (Short/Long/Join)
inspectBDedge:: BoundaryState -> Dedge -> (TileFace, EdgeType)
inspectBDedge :: BoundaryState -> (Vertex, Vertex) -> (TileFace, EdgeType)
inspectBDedge BoundaryState
bd (Vertex
a,Vertex
b) = (TileFace
face,(Vertex, Vertex) -> TileFace -> EdgeType
edgeType (Vertex
b,Vertex
a) TileFace
face) where
      face :: TileFace
face = case (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> TileFace -> Bool
isAtV Vertex
a) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
b of
             [TileFace
f] -> TileFace
f
             [TileFace]
_   -> String -> TileFace
forall a. HasCallStack => String -> a
error (String -> TileFace) -> String -> TileFace
forall a b. (a -> b) -> a -> b
$ String
"inspectBDedge: Not a boundary directed edge " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
 {-
     face = case facesAtBV bd a `intersect` facesAtBV bd b of
         [f] -> f
         _ -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"
-}





{- $Additions
Note about face additions:

When adding a new face on a boundary edge we need to use some geometric information.

To check if any other edges of the new face are adjacent on the boundary, we
calculate external angles at the relevant boundary vertices,
using a representation of angles which allows an equality test.
(All angles are integer multiples of 1/10th turn (mod 10) so we use
these integers for comparing angles n where n is 0..9)

No crossing boundary property:
It is important that there are no crossing boundaries to ensure there is a unique external angle at each boundary vertex.

Touching Vertex check:
If only one edge of a new face is on the boundary, we need to create a new vertex.
This will need to have its position checked against other (boundary) vertices to avoid
creating a touching vertex/crossing boundary. This is why BoundaryStates keep track of boundary vertex positions.
(The check is done in tryUnsafeUpdate.)
-}

{-|tryFindThirdV finds a neighbouring third vertex on the boundary if there is one in the correct direction for a face added to
   the right hand side of a directed boundary edge.
   In tryFindThirdV bd (a,b) (n,m), the two integer arguments n and m are the INTERNAL angles
   for the new face on the boundary directed edge (a,b)
   (for a and b respectively) expressed as multiples of tt (tt being a tenth turn)
   and must both be either 1,2, or 3.
   tryFindThirdV compares these internal angles with the external angles of the boundary calculated at a and b.
   If one of them matches, then an adjacent boundary edge will lead to the required vertex.
   If either n or m is too large a Left report is returned indicating an incorrect graph (stuck tiling).
   If n and m are smaller than the respective external angles, Right Nothing is returned.
-}
tryFindThirdV:: BoundaryState -> Dedge -> (Int,Int) -> Try (Maybe Vertex)
tryFindThirdV :: BoundaryState
-> (Vertex, Vertex)
-> (Vertex, Vertex)
-> Either ShowS (Maybe Vertex)
tryFindThirdV BoundaryState
bd (Vertex
a,Vertex
b) (Vertex
n,Vertex
m) = Either ShowS (Maybe Vertex)
maybeV where
    aAngle :: Vertex
aAngle = BoundaryState -> Vertex -> Vertex
externalAngle BoundaryState
bd Vertex
a
    bAngle :: Vertex
bAngle = BoundaryState -> Vertex -> Vertex
externalAngle BoundaryState
bd Vertex
b
    maybeV :: Either ShowS (Maybe Vertex)
maybeV | Vertex
aAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
<Vertex
1 Bool -> Bool -> Bool
|| Vertex
aAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>Vertex
9
                = [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports 
                   [String
"tryFindThirdV: vertex: "
                   ,Vertex -> String
forall a. Show a => a -> String
show Vertex
a
                   ,String
" has (tt) external angle "
                   ,Vertex -> String
forall a. Show a => a -> String
show Vertex
aAngle
                   ,String
"\nwhen adding to boundary directed edge: "
                   ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                   ,String
"\nwith faces at "
                   ,Vertex -> String
forall a. Show a => a -> String
show Vertex
a
                   ,String
":\n"
                   ,[TileFace] -> String
forall a. Show a => a -> String
show (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd VertexMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
a)
                   ,String
"\nand faces at "
                   ,Vertex -> String
forall a. Show a => a -> String
show Vertex
b
                   ,String
":\n"
                   ,[TileFace] -> String
forall a. Show a => a -> String
show (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd VertexMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
b), 
                   String
"\nand a total of "
                   ,Vertex -> String
forall a. Show a => a -> String
show ([TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ([TileFace] -> Vertex) -> [TileFace] -> Vertex
forall a b. (a -> b) -> a -> b
$ BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces BoundaryState
bd)
                   ,String
" faces.\n"
                   ]
           | Vertex
bAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
<Vertex
1 Bool -> Bool -> Bool
|| Vertex
bAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
>Vertex
9
                = [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports
                    [String
"tryFindThirdV: vertex: "
                    ,Vertex -> String
forall a. Show a => a -> String
show Vertex
b
                    ,String
" has (tt) external angle "
                    ,Vertex -> String
forall a. Show a => a -> String
show Vertex
bAngle
                    ,String
"\nwhen adding to boundary directed edge: "
                    ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                    ,String
"\nwith faces at "
                    ,Vertex -> String
forall a. Show a => a -> String
show Vertex
a
                    ,String
":\n"
                    ,[TileFace] -> String
forall a. Show a => a -> String
show (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd VertexMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
a)
                    ,String
"\nand faces at "
                    ,Vertex -> String
forall a. Show a => a -> String
show Vertex
b
                    ,String
":\n"
                    ,[TileFace] -> String
forall a. Show a => a -> String
show (BoundaryState -> VertexMap [TileFace]
bvFacesMap BoundaryState
bd VertexMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
b)
                    ,String
"\nand a total of "
                    ,Vertex -> String
forall a. Show a => a -> String
show ([TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length ([TileFace] -> Vertex) -> [TileFace] -> Vertex
forall a b. (a -> b) -> a -> b
$ BoundaryState -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces BoundaryState
bd)
                    ,String
" faces.\n"
                    ]
           | Vertex
aAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
< Vertex
n
                = [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports
                    [String
"tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: "
                    ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                    ,String
"\n"
                    ]
           | Vertex
bAngle Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
< Vertex
m
                = [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports
                    [String
"tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: "
                    ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                    ,String
"\n"
                    ]
           | Vertex
aAngle Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
n = case ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)] -> Maybe (Vertex, Vertex)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a) (Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd) (BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd) of
                             Just (Vertex, Vertex)
pr -> Maybe Vertex -> Either ShowS (Maybe Vertex)
forall a b. b -> Either a b
Right (Maybe Vertex -> Either ShowS (Maybe Vertex))
-> Maybe Vertex -> Either ShowS (Maybe Vertex)
forall a b. (a -> b) -> a -> b
$ Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just ((Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst (Vertex, Vertex)
pr)
                             Maybe (Vertex, Vertex)
Nothing -> [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports
                                          [String
"tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge "
                                          ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                                          ,String
"\n"
                                          ]
           | Vertex
bAngle Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
m = case ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)] -> Maybe (Vertex, Vertex)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b) (Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> a
fst) (BoundaryState -> [(Vertex, Vertex)]
forall a. HasFaces a => a -> [(Vertex, Vertex)]
boundary BoundaryState
bd) of
                             Just (Vertex, Vertex)
pr -> Maybe Vertex -> Either ShowS (Maybe Vertex)
forall a b. b -> Either a b
Right (Maybe Vertex -> Either ShowS (Maybe Vertex))
-> Maybe Vertex -> Either ShowS (Maybe Vertex)
forall a b. (a -> b) -> a -> b
$ Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just ((Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd (Vertex, Vertex)
pr)
                             Maybe (Vertex, Vertex)
Nothing -> [String] -> Either ShowS (Maybe Vertex)
forall a. [String] -> Try a
failReports
                                           [String
"tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge "
                                           ,(Vertex, Vertex) -> String
forall a. Show a => a -> String
show (Vertex
a,Vertex
b)
                                           ,String
"\n"
                                           ]
           | Bool
otherwise =   Maybe Vertex -> Either ShowS (Maybe Vertex)
forall a b. b -> Either a b
Right  Maybe Vertex
forall a. Maybe a
Nothing

-- |externalAngle bd v - calculates the external angle at boundary vertex v in BoundaryState bd as an
-- integer multiple of tt (tenth turn), so 1..9.  It relies on there being no crossing boundaries,
-- so that there is a single external angle at each boundary vertex. 
externalAngle:: BoundaryState -> Vertex -> Int
externalAngle :: BoundaryState -> Vertex -> Vertex
externalAngle BoundaryState
bd Vertex
v = Vertex
10 Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- [Vertex] -> Vertex
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex -> TileFace -> Vertex
intAngleAt Vertex
v) ([TileFace] -> [Vertex]) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ BoundaryState -> Vertex -> [TileFace]
facesAtBV BoundaryState
bd Vertex
v)

-- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face)
-- in terms of tenth turns, so returning an Int (1,2,or 3).
intAngleAt :: Vertex -> TileFace -> Int
intAngleAt :: Vertex -> TileFace -> Vertex
intAngleAt Vertex
v TileFace
fc = TileFace -> [Vertex]
faceIntAngles TileFace
fc [Vertex] -> Vertex -> Vertex
forall a. HasCallStack => [a] -> Vertex -> a
!! Vertex -> TileFace -> Vertex
indexV Vertex
v TileFace
fc

-- |faceIntAngles returns a list of the three internal angles of a face (clockwise from originV)
-- in terms of tenth turns - always 1 or 2 for kites and 1 or 3 for darts.
faceIntAngles :: TileFace -> [Int]
faceIntAngles :: TileFace -> [Vertex]
faceIntAngles (LD (Vertex, Vertex, Vertex)
_) = [Vertex
1,Vertex
3,Vertex
1]
faceIntAngles (RD (Vertex, Vertex, Vertex)
_) = [Vertex
1,Vertex
1,Vertex
3]
faceIntAngles TileFace
_      = [Vertex
1,Vertex
2,Vertex
2] -- LK and RK


{-------------------------
*************************             
Touching vertex checking 
********************************************
requires Diagrams.Prelude for Point and V2
--------------------------------------------}

-- |touchCheck p vpMap - check if a vertex location p touches (is too close to) any other vertex location in the mapping vpMap
touchCheck:: Point V2 Double -> VertexMap (Point V2 Double) -> Bool
touchCheck :: Point V2 Double -> VertexMap (Point V2 Double) -> Bool
touchCheck Point V2 Double
p VertexMap (Point V2 Double)
vpMap = (Point V2 Double -> Bool) -> [Point V2 Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Point V2 Double -> Point V2 Double -> Bool
touching Point V2 Double
p) (VertexMap (Point V2 Double) -> [Point V2 Double]
forall a. IntMap a -> [a]
VMap.elems VertexMap (Point V2 Double)
vpMap)