{-|
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 avoid space leaks.
-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Tgraph.Force
( -- * Forcible class
Forcible(..) -- tryFSOp, tryInitFS, tryChangeBoundary
-- * Generalised forcing
, force
, tryForce
, forceWith
, tryForceWith
, stepForce
, tryStepForce
-- , tryStepForceWith
, tryFSOpWith
, initFS
-- , tryInitFS
-- , tryChangeBoundary
, wholeTiles
-- * Explicitly Forced
, Forced()
, forgetF
, tryForceF
, forceF
, withForced
-- , recoverGraphF
-- , boundaryStateF
-- , makeBoundaryStateF
-- , initFSF --dep
, labelAsForced
-- * Force Related
, addHalfKite
, tryAddHalfKite
, addHalfDart
, tryAddHalfDart
-- , tryOneStepWith
-- , tryOneStepForce
, tryOneStep
-- * Types for Forcing
, BoundaryState(..)
, BoundaryDedges()
, ForceState(..)
, BoundaryChange(..)
, Update(..)
, Updates(..)
, UpdateGenerator(..)
, UFinder
, UChecker
-- * BoundaryState operations
, makeBoundaryState
-- , boundary (part of HasFaces class)
-- , recoverGraph --now in HasGraph
-- , changeVFMap -- Now HIDDEN
, facesAtBV
-- , boundaryVFacesBS (removed)
-- * Auxiliary Functions for a force step
, affectedBoundary
, boundaryAt
, nextBV
, prevBV
, isBoundaryV
, isBoundaryDE
, tryOnBoundary
-- , mustFind
-- , tryReviseUpdates
-- , tryReviseFS
, findSafeUpdate
, tryUnsafes
, checkUnsafeUpdate
, trySafeUpdate
-- , commonVs
, tryUpdate
-- * Recalibrating force
, recalibratingForce
, tryRecalibratingForce
, recalculateBVLocs
, tryForceAt
-- * 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 ((\\), nub, find, partition)
import Prelude hiding (Foldable(..))
import Data.Foldable (Foldable(..))
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map (null, delete, elems, insert, lookupMin, keys,lookup) -- used for Updates
import Data.IntMap.Strict(IntMap)
import qualified Data.IntMap.Strict as VMap (filterWithKey, alter, adjust, delete, lookup, (!), keysSet, member
, fromAscList, fromList, assocs, insert, elems)
import qualified Data.IntSet as IntSet (member)
-- used for BoundaryState locations AND faces at boundary vertices
import Data.Set (Set)
import qualified Data.Set as Set (elems,fromList)
import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate
import Tgraph.Prelude
import Tgraph.Grid
import Control.Monad ( (>=>) )
import Data.Maybe(mapMaybe)
-- import TileLib ( Drawable )
{-
***************************************************************************
Efficient FORCING with
BoundaryState, ForceState
Touching Vertex Check Using a Grid
Incremented Update Maps
***************************************************************************
-}
{-| A BoundaryState records
a mapping of boundary vertices to their incident faces,
a mapping of boundary vertices to positions (using Tgraph.Prelude.locateGraphVertices),
a grid of positions (for fast touching vertex checks),
a list of all the faces,
the next vertex label to be used when adding a new vertex,
the boundary directed edges (directed so that faces are on LHS and exterior is on RHS).
These boundary directed edges are represented using type BoundaryDedges.
New: the positions of boundary vertices and the grid are made lazy.
They are not needed until the first unsafe update has to be done (if there is one).
-}
data BoundaryState
= BoundaryState
{ boundaryDedges:: BoundaryDedges -- ^ boundary directed edges (face on LHS, exterior on RHS)
, bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex.
, bvLocMap:: ~(VertexMap (Point V2 Double)) -- ^ position of each boundary vertex.
, grid:: ~(Grid (Point V2 Double)) -- ^ a grid of locations to avoid (initially boundary vertex locations).
, allFaces:: [TileFace] -- ^ all the tile faces
, nextVertex:: Vertex -- ^ next vertex number
} deriving (Show)
-- | A type to represent the boundary directed edges in a BoundaryState
-- (direction with face on LHS, exterior on RHS).
-- This is now a pair of vertex to vertex maps, one giving the next vertex round the boundary,
-- and one giving the previous vertex round the boundary.
-- This representation is both convenient for some BoundaryState operations and is simple to update.
-- The representation relies on the no crossing boundaries property of Tgraphs.
data BoundaryDedges = BoundaryDedges {prevBVMap::IntMap Vertex, nextBVMap::IntMap Vertex}
deriving(Show)
-- |convert a set of boundary directed edges to BoundaryDedges
bdesFromSet :: Set Dedge -> BoundaryDedges --(IntMap Vertex, IntMap Vertex)
bdesFromSet eset = BoundaryDedges{prevBVMap=prev, nextBVMap=next} where
blist = Set.elems eset
next = VMap.fromAscList blist
prev = VMap.fromList $ map reverseD blist
-- |convert BoundaryDedges to a set of boundary directed edges
bdesToSet :: BoundaryDedges -> Set Dedge
bdesToSet = Set.fromList . VMap.assocs . nextBVMap -- (overrides default) boundary already calculated
-- |add some edges to the boundary (second arg is boundary)
bdesInsert :: [Dedge] -> BoundaryDedges -> BoundaryDedges
bdesInsert = flip (foldl' insertE) -- (++)
where insertE bdes (!a,!b) =
bdes{prevBVMap=VMap.insert b a $ prevBVMap bdes, nextBVMap=VMap.insert a b $ nextBVMap bdes}
-- | remove some edges from the boundary (second arg is boundary)
bdesDelete :: [Dedge] -> BoundaryDedges -> BoundaryDedges
bdesDelete = flip (foldl' deleteE) where --flip (\\)
deleteE bdes (a,b) =
bdes{prevBVMap=VMap.delete b $ prevBVMap bdes, nextBVMap=VMap.delete a $ nextBVMap bdes}
-- |nextBV v bs - returns the next vertex on the boundary from v (in boundary direction).
nextBV :: Vertex -> BoundaryState -> Vertex
nextBV v bs = case VMap.lookup v (nextBVMap $ boundaryDedges bs) of
Nothing -> error $ "nextBV: Vertex not found on boundary: " ++ show v ++ "\n"
Just v1 -> v1
-- |prevBV v bs - returns the previous vertex on the boundary from v (in boundary direction).
prevBV :: Vertex -> BoundaryState -> Vertex
prevBV v bs = case VMap.lookup v (prevBVMap $ boundaryDedges bs) of
Nothing -> error $ "prevBV: Vertex not found on boundary: " ++ show v ++ "\n"
Just v1 -> v1
-- | Check if a directed edge is on the boundary of a BoundaryState (in the correct boundary direction)
isBoundaryDE :: Dedge -> BoundaryState -> Bool
isBoundaryDE (a,b) bs = case VMap.lookup a (nextBVMap $ boundaryDedges bs) of
Nothing -> False
Just c -> c == b
-- | Check if a vertex is on the boundary
isBoundaryV :: Vertex -> BoundaryState -> Bool
isBoundaryV v = VMap.member v . nextBVMap . boundaryDedges
-- |Calculates BoundaryState information from a Tgraph.
makeBoundaryState:: Tgraph -> BoundaryState
makeBoundaryState g =
let bdes = bdesFromSet $ boundaryESet g
bvs = VMap.keysSet $ nextBVMap bdes -- the boundary vertices are the keys of the nextBVMap
-- location data is lazy (not needed until an unsafe update is executed)
~bvLocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices g
~newgrid = createGrid $ VMap.elems bvLocs
in
BoundaryState
{ boundaryDedges = bdes
, bvFacesMap = vertexFMap bvs g
, bvLocMap = bvLocs
, grid = newgrid
, allFaces = faces g
, nextVertex = 1+ maxV g
}
-- |BoundaryState is in class HasFaces.
-- Note the default implementations are overriden to use precalculated information
instance HasFaces BoundaryState where
faces = allFaces
boundaryESet = bdesToSet . boundaryDedges -- (overrides default) boundary already calculated
maxV bd = nextVertex bd - 1 -- (overrides default)
boundaryVFMap = bvFacesMap -- (overrides default) already calculated
-- |A Tgraph can be recovered from a BoundaryState
instance HasGraph BoundaryState where
recoverGraph = makeUncheckedTgraph . allFaces
-- |changeVFMapUnsafe f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap
-- This is used in the unsafe addition case where one of the vertices will be new to the map.
changeVFMapUnsafe:: TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMapUnsafe f vfm = foldl' insertf vfm (faceVList f) where
insertf = flip (VMap.alter consf)
consf Nothing = Just [f] -- new case
consf (Just fs) = Just (f:fs)
-- |changeVFMapSafe f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap
-- This is used in the safe addition case where no new vertices are added to the map.
-- If this is done after deletions, one or three of the vertices will not be in the map.
changeVFMapSafe:: TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]
changeVFMapSafe f vfm = foldl' insertf vfm (faceVList f) where
insertf = flip (VMap.adjust (f:))
-- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex)
facesAtBV:: BoundaryState -> Vertex -> [TileFace]
facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of
Just fcs -> fcs
Nothing -> error $ "facesAtBV: Not a boundary vertex? No result found for vertex " ++ show v ++ "\n"
-- |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 (SafeUpdate f) = "SafeUpdate (" ++ show f ++ ")"
show (UnsafeUpdate mf) = "UnsafeUpdate (\0 -> " ++ show (mf 0)++ ")"
-- |Updates: two partial maps associating updates with (some) boundary directed edges.
-- One for safe updates and one for unsafe updates
-- (Any boundary directed edge will have the opposite direction in some face.)
data Updates = Updates{safes :: Map Dedge Update, unsafes :: Map Dedge Update}
deriving (Show)
-- | Updates form a semigroup
instance Semigroup Updates where
ups1 <> ups2 = Updates
{ safes = safes ups1 <> safes ups2
, unsafes = unsafes ups1 <> unsafes ups2
}
-- | Updates form a monoid
instance Monoid Updates where
mempty = Updates{safes = mempty, unsafes = mempty}
-- |insert a new update (note that a safe can replace un unsafe but not vice versa).
insertUpdate :: Dedge -> Update -> Updates -> Updates
insertUpdate e u@(SafeUpdate _) ups
= ups{ safes = Map.insert e u (safes ups)
, unsafes = Map.delete e (unsafes ups)
} -- a safe can replace an unsafe
insertUpdate e u@(UnsafeUpdate _) ups
= ups{unsafes = Map.insert e u (unsafes ups)}
-- |delete an update
deleteUpdate :: Dedge -> Updates -> Updates
deleteUpdate e ups
= ups{ safes = Map.delete e (safes ups)
, unsafes = Map.delete e (unsafes ups)
}
-- |get the boundary edges that have an update (from Updates)
updateEdges :: Updates -> [Dedge]
updateEdges ups = Map.keys (safes ups) ++ Map.keys (unsafes ups)
-- |are there no more updates?
noUpdates :: Updates -> Bool
noUpdates ups = Map.null (safes ups) && Map.null (unsafes ups)
-- |ForceState: The force state records information between executing single face updates during forcing
-- (a BoundaryState , updates, and an UpdateGenerator).
-- A convention throughout is to initialize and leave a ForceState with the default update generator
-- and corresponding updates. It is important that the updates are calculated lazily in case they are not used.
data ForceState = ForceState
{ boundaryState:: BoundaryState
, updates:: ~Updates -- lazy field may not be used
, updater:: UpdateGenerator
}
-- | Show ForceState does not show the UpdateGenerator which contains a function.
instance Show ForceState where
show fs = show $ "ForceState with boundaryState:\n"
++ show(boundaryState fs)
++ "\n\nand updates:\n"
++ show (updates fs)
++ "\n\n"
-- |ForceState is in class HasFaces.
-- (using the boundaryState implementations)
instance HasFaces ForceState where
faces = faces . boundaryState
boundaryESet = boundaryESet . boundaryState
maxV = maxV . boundaryState
boundaryVFMap = boundaryVFMap . boundaryState
-- |A Tgraph can be recovered from a ForceState
instance HasGraph ForceState where
recoverGraph = recoverGraph . 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) Updates 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 - defaultAllUGen).
-}
newtype UpdateGenerator = UpdateGenerator {applyUG :: BoundaryState -> [Dedge] -> Try Updates}
-- | 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 force and stepForce and other operations.
-- The class operations allow for other
-- force related operations to be generalised for use on any Forcible.
-- For example tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundary.
class Forcible a where
-- | tryFSOp (try ForseState Operation), generalises a (try) ForceState operation to a (try) Forcible operation
-- (beginning and ending with the same forcible type).
--
-- To improve performance of a sequence of force related operations, express each as a
-- ForceState -> Try ForceState, then compose (e.g. using (\<=\<) or (\>=\>) from Control.Monad) and pass to tryFSOp.
-- This ensures there are no unnecessary conversions between steps.
tryFSOp :: (ForceState -> Try ForceState) -> a -> Try a
-- | tryInitFS (try initialising a ForceState) tries to create an initial ForceState (ready for forcing) from a Forcible.
-- This uses defaultAllUGen for Tgraphs and BoundaryStates but stored update generator when the instance is a ForceState.
-- (See also tryFSOpWith).
tryInitFS :: a -> Try ForceState
-- | tryChangeBoundary, converts a (try) BoundaryState changing operation to a (try) Forcible operation
-- (beginning and ending with the same forcible type).
tryChangeBoundary :: (BoundaryState -> Try BoundaryChange) -> a -> Try a
-- |ForceStates are Forcible
instance Forcible ForceState where
tryFSOp = id
tryInitFS = return
tryChangeBoundary f fs = do
bdC <- f (boundaryState fs)
tryReviseFS bdC fs
-- | BoundaryStates are Forcible
instance Forcible BoundaryState where
tryFSOp f bd = do
fs <- tryInitFS bd
fs' <- f fs
return $ boundaryState fs'
tryInitFS bd = do
~ups <- applyUG defaultAllUGen bd (boundary bd)
return $ ForceState { boundaryState = bd , updates = ups , updater = defaultAllUGen }
tryChangeBoundary f bd = do -- update generator not used
bdC <- f bd
return $ newBoundaryState bdC
-- | Tgraphs are Forcible
instance Forcible Tgraph where
tryFSOp f = fmap recoverGraph . tryFSOp f . makeBoundaryState
tryInitFS g = tryInitFS (makeBoundaryState g)
tryChangeBoundary f = -- update generator not used
fmap recoverGraph . tryChangeBoundary f . makeBoundaryState
-- |ForceState only operation to do all update steps.
-- Used to define the more general tryForce
tryFinishFS :: ForceState -> Try ForceState
tryFinishFS fs = do
r <- tryOneStep fs
case r of
Just (fs',_) -> tryFinishFS fs'
Nothing -> return fs -- final state (no more updates)
-- |A version of tryFSOp that (temporarily) uses the supplied update generator rather than the default
-- to perform the supplied try ForceState operation.
-- It will reset the default update generator (in case a resulting ForceState is used after completion).
tryFSOpWith :: Forcible a => UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
tryFSOpWith ugen f = tryFSOp (trySetUG ugen >=> f >=> trySetUG defaultAllUGen)
-- |Not exported. Only used in tryFSOpWith,
-- Resets the update generator in a ForceState (and recalculates updates lazily)
-- It is used twice in tryFSOpWith to restore the default.
trySetUG :: UpdateGenerator -> ForceState -> Try ForceState
trySetUG ugen fs = do
~ups <- applyUG ugen (boundaryState fs) (boundary fs)
return $ fs { updates = ups, updater = ugen }
-- | 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.
-- It will reset the default update generator and updates (in case a resulting ForceState is used after completion).
tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a
tryForceWith ug = tryFSOpWith ug tryFinishFS
-- |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 = tryFSOp tryFinishFS
-- |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 = runTry . tryForce
-- |special case of forcing only half tiles to whole tiles
wholeTiles:: Forcible a => a -> a
wholeTiles = forceWith wholeTileUpdates
-- | forceWith ugen: force using the supplied UpdateGenerator ugen.
-- This raises an error on discovering a stuck/incorrect Forcible.
-- It will reset the default update generator and updates (in case a resulting ForceState is used after completion).
forceWith:: Forcible a => UpdateGenerator -> a -> a
forceWith ugen = runTry . tryForceWith ugen
-- | initialize a force state with the default UpdateGenerator.
-- Raises an error if it finds a stuck Forcible.
initFS :: Forcible a => a -> ForceState
initFS = runTry . 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.
-- It will raise an error if n<0.
tryStepForce :: Forcible a => Int -> a -> Try a
tryStepForce n =
if n>=0
then tryFSOp $ count n
else error "tryStepForce: used with negative number of steps\n"
where
count 0 fs = return fs
count m fs = do result <- tryOneStep fs
case result of
Nothing -> return fs
Just (fs', _) -> count (m-1) fs'
-- |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.
-- It will raise an error if n<0.
stepForce :: Forcible a => Int -> a -> a
stepForce n = runTry . tryStepForce n
-- |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
forgetF :: a
}
deriving (Show,HasFaces,HasGraph)
{-# WARNING labelAsForced
["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."
]
#-}
-- | Constructs an explicitly Forced type.
-- Used in partComposeF and composeF
labelAsForced :: a -> Forced a
labelAsForced = 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 = fmap Forced . 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 = runTry . tryForceF
-- |withForced f - Use f to convert a (Forced a) to a (Forced b)
-- Both a and b should be Forcible.
withForced :: (a->b) -> Forced a -> Forced b
withForced f (Forced a) = Forced (f a)
-- |try to find the right direction for an edge to be a boundary directed edge.
-- Returns either Right de where de is the correct direction for the edge on the boundary,
-- or returns Left failreport.. if neither direction is consistent with boundary directed edges.
tryOnBoundary :: Dedge -> BoundaryState -> Try Dedge
tryOnBoundary e bd
| isBoundaryDE e bd = Right e
| isBoundaryDE (reverseD e) bd = Right (reverseD e)
| otherwise = failReports
[ "tryOnBoundary:\nNeither "
, show e, " nor ", show(reverseD e), " are on the boundary\n"
]
-- |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 e = runTry . tryAddHalfKite 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 = tryChangeBoundary . tryAddHalfKiteBoundary where
-- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change
-- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange
tryAddHalfKiteBoundary e bd =
do de <- tryOnBoundary e bd
let (fc,etype) = inspectBDedge bd de
let tryU | etype == Long = addKiteLongE bd fc
| etype == Short = addKiteShortE bd fc
| etype == Join && isKite fc = completeHalf bd fc
| otherwise = failReport "tryAddHalfKite: applied to dart join (not possible).\n"
u <- tryU
tryUpdate bd 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 e = runTry . tryAddHalfDart 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 = tryChangeBoundary . tryAddHalfDartBoundary where
-- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change
-- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange
tryAddHalfDartBoundary e bd =
do de <- tryOnBoundary e bd
let (fc,etype) = inspectBDedge bd de
let tryU | etype == Long = addDartLongE bd fc
| etype == Short && isKite fc = addDartShortE bd fc
| etype == Join && isDart fc = completeHalf bd fc
| otherwise = failReport "tryAddHalfDart: applied to short edge of dart or to kite join (not possible).\n"
u <- tryU
tryUpdate bd u
-- |tryOneStep fs does one force step.
-- It returns either
--
-- (1) a Right(Just (f,bc)) with a new ForceState f paired with the BoundaryChange bc.
-- (bc is only returned for debugging purposes as it has been used with uGen to create the resulting ForceState f), or
--
-- (2) a Right Nothing indicating forcing has finished and there are no more updates, or
--
-- (3) a Left report for a stuck/incorrect Tgraph.
tryOneStep :: ForceState -> Try (Maybe (ForceState,BoundaryChange))
tryOneStep fs =
case findSafeUpdate (updates fs) of
Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u
fs' <- tryReviseFS bdChange fs
return $ Just (fs',bdChange)
_ -> do maybeBdC <- tryUnsafes fs
case maybeBdC of
Just bdC -> do fs' <- tryReviseFS bdC fs
return $ Just (fs',bdC)
Nothing -> return Nothing -- no more updates
-- | Apply the update generator on the changed boundary of a ForceState
tryReviseFS :: BoundaryChange -> ForceState -> Try ForceState
tryReviseFS bdC fs =
do ups <- tryReviseUpdates (updater fs) bdC (updates fs)
return $ fs{ boundaryState = newBoundaryState bdC, updates = ups}
{-| 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
{ newBoundaryState:: BoundaryState -- ^ resulting boundary state
, removedEdges:: [Dedge] -- ^ edges no longer on the boundary
, revisedEdges :: [Dedge] -- ^ new boundary edges plus immediate boundary neighbours (requiring new update calculations)
, newFace :: TileFace -- ^ face added in the change
} deriving (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 bs [e1@(a,b)] = [e0,e1,e2] where
e0 = preceding a bs
e2 = following b bs
affectedBoundary bs [e1@(a,b),e2@(c,d)] | c==b = [e0,e1,e2,e3] where
e0 = preceding a bs
e3 = following d bs
affectedBoundary bs [e1@(a,b),e2@(c,d)] | a==d = [e0,e2,e1,e3] where
e0 = preceding c bs
e3 = following b bs
affectedBoundary _ [] = [] -- case for filling a triangular hole
affectedBoundary _ edges = error $ "affectedBoundary: unexpected boundary edges "
++ show edges ++ "\n(Either more than 2 or 2 not adjacent)\n"
-- |find the directed edge following the given vertex round the boundary
following :: Vertex -> BoundaryState -> Dedge
following a bs = (a, nextBV a bs)
-- |find the directed edge preceeding the given vertex round the boundary
preceding :: Vertex -> BoundaryState -> Dedge
preceding a bs = (prevBV a bs, a)
-- |boundaryAt v bs - get the (2) boundary edges at boundary vertex v in BoundaryState bs.
-- Raises an error if v is not on the boundary.
-- Otherwise returns the two edges in boundary direction order - e.g. [(a,v),(v,b)]
boundaryAt :: Vertex -> BoundaryState -> [Dedge]
boundaryAt v bs = [preceding v bs, following v bs]
{-# INLINE tryReviseUpdates #-}
-- |tryReviseUpdates uGen bdChange: revises the Updates after boundary change (bdChange)
-- using uGen to calculate new updates.
tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> Updates -> Try Updates
tryReviseUpdates uGen bdChange ups =
do let ups' = foldl' (flip deleteUpdate) ups (removedEdges bdChange)
ups'' <- applyUG uGen (newBoundaryState bdChange) (revisedEdges bdChange)
return (ups'' <> ups')
{-# INLINE findSafeUpdate #-}
-- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering)
findSafeUpdate:: Updates -> Maybe Update
findSafeUpdate ups = snd <$> Map.lookupMin (safes ups)
{-| tryUnsafes: Should only be used when there are no Safe updates in the Updates.
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 fs = tryUnsafesBS (boundaryState fs) (Map.elems $ unsafes $ updates fs) -- directed edge key order
{-| tryUnsafesBS: called by tryUnsafes with a list of unsafe updates to try in order
tryUnsafesBS works through the unsafe updates in 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.
-}
tryUnsafesBS:: BoundaryState -> [Update] -> Try (Maybe BoundaryChange)
tryUnsafesBS bd = checkBlocked 0 where
-- the integer records how many blocked cases have been found so far
checkBlocked:: Int -> [Update] -> Try (Maybe BoundaryChange)
checkBlocked 0 [] = return Nothing
checkBlocked n [] = failReports
["tryUnsafesBS: There are "
,show n
," unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n"
,"This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n"
,"Total number of faces is "
,show (faceCount bd)
,"\n"
]
checkBlocked n (u: more) = case checkUnsafeUpdate bd u of
Nothing -> checkBlocked (n+1) more
other -> return 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 bd (UnsafeUpdate makeFace) =
let v = nextVertex bd
newface = makeFace v
oldVPoints = bvLocMap bd
newVPoints = addVPoint newface oldVPoints
vPosition = newVPoints VMap.! v
in case insertGridCheck vPosition (grid bd) of
Left _ -> Nothing -- blocked by touching vertex
Right newgrid ->
let
(!unmatched, !matchedDedges) = partition (\(x,y) -> x == v || y == v) (faceDedges newface) -- (two edges,singleton)
newBdry = map reverseD unmatched -- two edges
resultBd = BoundaryState
{ boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd
, bvFacesMap = changeVFMapUnsafe newface (bvFacesMap bd)
, bvLocMap = newVPoints
, grid = newgrid
, allFaces = newface:allFaces bd
-- allFaces = newface:faces bd <<<CAUSES SPACE LEAK>>>>
, nextVertex = v+1
}
bdChange = BoundaryChange
{ newBoundaryState = resultBd
, removedEdges = matchedDedges -- singleton
, revisedEdges = affectedBoundary resultBd newBdry -- 4 edges
, newFace = newface
}
in Just bdChange
checkUnsafeUpdate _ _ = error "checkUnsafeUpdate: applied to safe update.\n"
{-| 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 bd (SafeUpdate newface) =
let fDedges = faceDedges newface
localBoundary = nub [e | v <- faceVList newface, e <- boundaryAt v bd] -- duplicates removed
(!matchedDedges, !unmatched) = partition (`elem` localBoundary) fDedges -- (2 or 3, 1 or none)
removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)
newBdry = map reverseD unmatched --(fDedges \\ matchedDedges) -- one or none
nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs
resultBd = BoundaryState
{ boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd
, bvFacesMap = changeVFMapSafe newface $ foldl' (flip VMap.delete) (bvFacesMap bd) removedBVs
-- do deletions first then only adds for vertices still on the boundary.
, allFaces = newface:allFaces bd
, bvLocMap = foldl' (flip VMap.delete) (bvLocMap bd) removedBVs
--remove vertex/vertices no longer on boundary
, grid = grid bd
, nextVertex = nextVertex bd
}
bdChange = BoundaryChange
{ newBoundaryState = resultBd
, removedEdges = matchedDedges -- 2 or 3 edges
, revisedEdges = affectedBoundary resultBd newBdry -- 3 or 0 edges
, newFace = newface
}
in if compatibleNew newface nbrFaces
then Right bdChange
else failReports
["trySafeUpdate:(incorrect tiling)\nConflicting new face "
,show newface
,"\nwith neighbouring faces\n"
,show nbrFaces
,"\n"
]
trySafeUpdate _ _ = error "trySafeUpdate: applied to non-safe update.\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 [(a,b),(c,d)] | b==c = [b]
| d==a = [a]
| otherwise = error $ "commonVs: 2 directed edges not consecutive: " ++ show [(a,b),(c,d)] ++ "\n"
commonVs [(a,b),(c,d),(e,f)] | length (nub [a,b,c,d,e,f]) == 3 = [a,c,e]
commonVs es = error $ "commonVs: unexpected argument edges (not 2 consecutive directed edges or 3 round triangle): " ++ show es ++ "\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 bd u@(SafeUpdate _) = trySafeUpdate bd u
tryUpdate bd u@(UnsafeUpdate _) =
case checkUnsafeUpdate bd u of
Just bdC -> return bdC
Nothing -> failReport "tryUpdate: crossing boundary (touching vertices).\n"
-- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateGraphVertices.
-- and a new grid of positions
-- (Used at intervals in tryRecalibratingForce and recalibratingForce).
recalculateBVLocs :: BoundaryState -> BoundaryState
recalculateBVLocs bd = bd { bvLocMap = newlocs
, grid = createGrid $ VMap.elems newlocs
} where
newlocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices $ recoverGraph bd
bvs = VMap.keysSet $ bvLocMap 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 = tryFSOp recalibrating where
recalibrating fs = do
fs' <- tryStepForce 20000 fs
if noUpdates $ updates fs'
then return fs'
else recalibrating 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 = runTry . tryRecalibratingForce
-- | Not exported. Auxiliary ForceState function used by tryForceAt
tryForceAtFS :: [Vertex] -> ForceState -> Try ForceState
tryForceAtFS vs fs = do
let bs = boundaryState fs
bvs = filter (`isBoundaryV` bs) vs
des = Set.elems $ Set.fromList $ concatMap (`boundaryAt` bs) bvs -- does nub and sort
let thesafes = mapMaybe (`Map.lookup` safes (updates fs)) des
~theunsafes = mapMaybe (`Map.lookup` unsafes (updates fs)) des
case thesafes of
(u:_) -> do bdChange <- trySafeUpdate bs u
fs' <- tryReviseFS bdChange fs
tryForceAtFS bvs fs'
[] -> do maybeBdC <- tryUnsafesBS bs theunsafes
case maybeBdC of
Just bdC -> do fs' <- tryReviseFS bdC fs
tryForceAtFS bvs fs'
Nothing -> return fs -- no more updates
-- | Experimental version of tryForce that only adds faces at the given vertices.
-- (Any vertex not on the boundary is ignored).
tryForceAt :: Forcible a => [Vertex] -> a -> Try a
tryForceAt vs = tryFSOp (tryForceAtFS vs)
{- $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 gens = UpdateGenerator genf where
genf bd focus =
do let addGen (Right (es,ups)) gen =
do ups' <- applyUG gen bd es
let es' = es \\ updateEdges ups'
return (es',ups' <> ups)
addGen other _ = other -- fails with first failing generator
(_ , ups) <- foldl' addGen (Right (focus,mempty)) gens
return ups
{-| 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 = combineUpdateGenerators generators where
generators = [ wholeTileUpdates -- (rule 1)
, aceKiteUpdates -- (rule 2)
, queenOrKingUpdates -- (rule 3)
, deuceDartUpdates -- (rule 4)
, jackDartUpdates -- (rule 5)
, sunStarUpdates -- (rule 6)
, jackKiteUpdates -- (rule 7)
, kingDartUpdates -- (rule 8)
, queenDartUpdates -- (rule 9)
, 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 predF bd focus =
[ (e,fc) | e <- focus
, fc <- facesAtBV bd (fst e)
, fc `elem` facesAtBV bd (snd e)
, predF bd e 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 etype predF bd focus =
[ (e,fc) | e <- focus
, let (fc,etype') = inspectBDedge bd e
, etype == etype'
, predF bd 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 f (Just !v) = SafeUpdate (f v)
makeUpdate f Nothing = UnsafeUpdate f
-- |A vertex on the boundary must be a star if it has 7 or more dart origins
mustbeStar:: BoundaryState -> Vertex -> Bool
mustbeStar bd v = length (filter ((==v) . originV) $ filter isDart $ facesAtBV bd v) >= 7
-- |A vertex on the boundary must be a sun if it has 5 or more kite origins
mustbeSun:: BoundaryState -> Vertex -> Bool
mustbeSun bd v = length (filter ((==v) . originV) $ filter isKite $ facesAtBV bd v) >= 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 bd v = isKiteOppV bd v &&
hasAnyMatchingE (map shortE $ filter isKite $ facesAtBV bd v)
-- |A boundary vertex which is a kite wing and has 4 dart origins must be a king vertex
mustbeKing:: BoundaryState -> Vertex -> Bool
mustbeKing bd v = isKiteWing bd v && length dartOrigins ==4
where dartOrigins = filter ((==v) . originV) $ filter isDart $ facesAtBV bd v
-- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd
isKiteWing:: BoundaryState -> Vertex -> Bool
isKiteWing bd v = v `elem` map wingV (filter isKite (facesAtBV bd v))
-- |isKiteOppV bd v - Vertex v is a kite oppV in BoundaryState bd
isKiteOppV:: BoundaryState -> Vertex -> Bool
isKiteOppV bd v = v `elem` map oppV (filter isKite (facesAtBV bd v))
-- |isDartOrigin bd v - Vertex v is a dart origin in BoundaryState bd
isDartOrigin:: BoundaryState -> Vertex -> Bool
isDartOrigin bd v = v `elem` map originV (filter isDart (facesAtBV bd 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 bd v = kiteWingCount bd v >2
-- |kiteWingCount bd v - the number of kite wings at v in BoundaryState bd
kiteWingCount:: BoundaryState -> Vertex -> Int
kiteWingCount bd v = length $ filter ((==v) . wingV) $ filter isKite (facesAtBV bd 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 bd v =
(length dWings == 2 && not (hasAnyMatchingE (map longE dWings))) || -- 2 dart wings and dart long edges not shared.
(length dWings == 1 && isKiteOrigin)
where fcs = facesAtBV bd v
dWings = filter ((==v) . wingV) $ filter isDart fcs
isKiteOrigin = v `elem` map originV (filter isKite fcs)
-- |hasMatching asks if a directed edge list has any two matching (=opposing) directed edges.
hasAnyMatchingE :: [Dedge] -> Bool
hasAnyMatchingE ((x,y):more) = (y,x) `elem` more || hasAnyMatchingE more
hasAnyMatchingE [] = 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 checker finder = UpdateGenerator genf where
genf bd edges = foldl' addU (Right mempty) (finder bd edges) where
addU (Left x) _ = Left x
addU (Right ups) (e,fc) = do u <- checker bd fc
return (insertUpdate e u ups)
-- Ten Update Generators (with corresponding Finders)
-- |Update generator for rule (1)
wholeTileUpdates:: UpdateGenerator
wholeTileUpdates = newUpdateGenerator completeHalf incompleteHalves
-- |Find faces with missing opposite face (mirror face)
incompleteHalves :: UFinder
incompleteHalves = boundaryEdgeFilter Join anyFace where
anyFace _ _ = True
-- |Update generator for rule (2)
aceKiteUpdates :: UpdateGenerator
aceKiteUpdates = newUpdateGenerator addKiteShortE nonKDarts
-- |Find half darts with boundary short edge
nonKDarts :: UFinder
nonKDarts = boundaryEdgeFilter Short foundDart where
foundDart _ = isDart
-- |Update generator for rule (3)
-- queen and king vertices add a missing kite half (on a boundary kite short edge)
queenOrKingUpdates :: UpdateGenerator
queenOrKingUpdates = newUpdateGenerator addKiteShortE kitesWingDartOrigin
-- |Find kites with boundary short edge where the wing is also a dart origin
kitesWingDartOrigin :: UFinder
kitesWingDartOrigin = boundaryEdgeFilter Short kiteWDO where
kiteWDO bd fc = 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 = newUpdateGenerator addDartShortE 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 = boundaryEdgeFilter Short kiteGap where
kiteGap bd fc = isKite fc && mustbeDeuce bd (oppV fc)
-- |Update generator for rule (5)
-- jackDartUpdates - jack vertex add a missing second dart
jackDartUpdates :: UpdateGenerator
jackDartUpdates = newUpdateGenerator addDartShortE 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 = boundaryEdgeFilter Short farKOfDarts where
farKOfDarts bd fc = 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 = newUpdateGenerator completeSunStar 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 = boundaryEdgeFilter Long multiples57 where
multiples57 bd fc =
(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 = newUpdateGenerator addKiteLongE 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 = boundaryEdgeFilter Long dartsWingDB where
dartsWingDB bd fc = 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 = newUpdateGenerator addDartLongE 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 = boundaryEdgeFilter Long predicate where
predicate bd fc = 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 = newUpdateGenerator addDartLongE 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 = boundaryEdgeFilter Long predicate where
predicate bd fc = 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 = newUpdateGenerator addKiteShortE 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 = boundaryEdgeFilter Short predicate where
predicate bd fc =
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 bd (LD(a,b,_)) = makeUpdate makeFace <$> x where
makeFace v = makeRD a v b
x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD
completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where
makeFace = makeLD a b
x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD
completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where
makeFace = makeRK a b
x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK
completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where
makeFace v = makeLK a v b
x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK
-- |add a (missing) half kite on a (boundary) short edge of a dart or kite
addKiteShortE :: UChecker
addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeLK v c b
x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK
addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeRK v c b
x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK
addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeRK v c b
x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK
addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeLK v c b
x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK
-- |add a half dart top to a boundary short edge of a half kite.
addDartShortE :: UChecker
addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeLD v c b
x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD
addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where
makeFace v = makeRD v c b
x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD
addDartShortE _ _ = error "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 bd fc = if isKite fc
then addKiteLongE bd fc
else addDartLongE bd fc
-- |add a kite to a long edge of a dart or kite
addKiteLongE :: UChecker
addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where
makeFace v = makeRK c v a
x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK
addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where
makeFace = makeLK b a
x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK
addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where
makeFace = makeLK a c
x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK
addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where
makeFace v = makeRK a v b
x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK
-- |add a half dart on a boundary long edge of a dart or kite
addDartLongE :: UChecker
addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where
makeFace = makeRD a c
x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD
addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where
makeFace v = makeLD a v b
x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD
addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where
makeFace = makeRD b a
x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD
addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where
makeFace v = makeLD c v a
x = tryFindThirdV bd (a,c) (1,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 { applyUG = gen } where
gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map
combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any
-- otherwise combines the updates with mconcat
decide e = decider $ inspectBDedge bd e where
decider (f,Join) = mapItem (completeHalf bd f) -- rule 1
decider (f,Short)
| isDart f = mapItem (addKiteShortE bd f) -- rule 2
| otherwise = kiteShortDecider f
decider (f,Long)
| isDart f = dartLongDecider f
| otherwise = kiteLongDecider f
dartLongDecider f
| mustbeStar bd (originV f) = mapItem (completeSunStar bd f)
| mustbeKing bd (originV f) = mapItem (addDartLongE bd f)
| mustbeJack bd (wingV f) = mapItem (addKiteLongE bd f)
| otherwise = Right mempty
kiteLongDecider f
| mustbeSun bd (originV f) = mapItem (completeSunStar bd f)
| mustbeQueen bd (wingV f) = mapItem (addDartLongE bd f)
| otherwise = Right mempty
kiteShortDecider f
| mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem (addDartShortE bd f)
| mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem (addKiteShortE bd f)
| otherwise = Right mempty
-- mapItem :: Try Update -> Try Updates
mapItem = fmap (\u -> insertUpdate e u mempty)
-- |Given a BoundaryState and a directed boundary edge, this returns
-- the unique face on that edge and the edge type for that face and edge (Short/Long/Join)
inspectBDedge:: BoundaryState -> Dedge -> (TileFace, EdgeType)
inspectBDedge bd (a,b) = (face,edgeType (b,a) face) where
face = case find (isAtV a) $ facesAtBV bd b of
Just f -> f
Nothing -> 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 checkUnsafeUpdate.)
-}
{-|tryFindThirdV tries to find a neighbouring third vertex on the boundary either side of the dedge
(for a new face to be added).
It can return a Left failreport if it discovers an incorrect Tgraph.
Otherwise it returns a Right Nothing or Right (Just v) depending on whether it found an existing
suitable vertex.
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 bd (a,b) (n,m) = maybeV where
aAngle = externalAngle bd a
bAngle = externalAngle bd b
maybeV | aAngle <1 || aAngle >9
= failReports
["tryFindThirdV: vertex: "
,show a
," has (tt) external angle "
,show aAngle
,"\nwhen adding to boundary directed edge: "
,show (a,b)
,"\nwith faces at "
,show a
,":\n"
,show (facesAtBV bd a)
,"\nand faces at "
,show b
,":\n"
,show (facesAtBV bd b),
"\nand a total of "
,show (length $ faces bd)
," faces.\n"
]
| bAngle <1 || bAngle >9
= failReports
["tryFindThirdV: vertex: "
,show b
," has (tt) external angle "
,show bAngle
,"\nwhen adding to boundary directed edge: "
,show (a,b)
,"\nwith faces at "
,show a
,":\n"
,show (facesAtBV bd a)
,"\nand faces at "
,show b
,":\n"
,show (facesAtBV bd b)
,"\nand a total of "
,show (faceCount bd)
," faces.\n"
]
| aAngle < n
= failReports
["tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: "
,show (a,b)
,"\n"
]
| bAngle < m
= failReports
["tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: "
,show (a,b)
,"\n"
]
| aAngle == n = Right $ Just $ fst $ preceding a bd
| bAngle == m = Right $ Just $ snd $ following b bd
| otherwise = Right Nothing
{-# INLINE externalAngle #-}
-- |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 bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd 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 v face@(LD (a,b,c))
| v==a = 1
| v==b = 3
| v==c = 1
| otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)
intAngleAt v face@(RD (a,b,c))
| v==a = 1
| v==b = 1
| v==c = 3
| otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)
intAngleAt v face@(LK (a,b,c))
| v==a = 1
| v==b = 2
| v==c = 2
| otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)
intAngleAt v face@(RK (a,b,c))
| v==a = 1
| v==b = 2
| v==c = 2
| otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)