{-|
Module      : Tgraph.Compose
Description : A compose operation for Tgraphs
Copyright   : (c) Chris Reade, 2021
License     : BSD-style
Maintainer  : chrisreade@mac.com
Stability   : experimental

This module includes the main composition operations compose, partCompose,
tryPartCompose, composeF, and partComposeF but also exposes 
auxiliary functions
tryGetDartWingInfo, getDartWingInfoForced (and type DartWingInfo)
and partCompFacesFrom for debugging.
-}
{-# LANGUAGE Strict             #-} 

module Tgraph.Compose 
  ( -- * Composing forced Tgraphs 
    composeF
  , partComposeF
    -- * General compose operations 
  , compose
  , partCompose
  , tryPartCompose
  , tryPartComposeFaces
  -- * Exported auxiliary functions (and type)
  -- , partCompFacesAssumeF
  -- , partComposeFaces
  -- , partComposeFacesF
  , partComposeFacesFrom --new
  , DartWingInfo(..)
  -- , getDWIassumeF
  -- , getDartWingInfo
  , tryGetDartWingInfo
  , getDartWingInfoForced
 -- , composedFaceGroups
   -- * Older versions (for debugging/comparison)
  , oldGetDartWingInfo
  , oldPartCompose
  ) where

import Data.List (find, foldl', (\\),partition, nub)
import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!),alter,empty,elems)
import Data.Maybe (mapMaybe)
import qualified Data.IntSet as IntSet (empty,insert,toList,member)

import Tgraph.Prelude
import Tgraph.Force ( Forced(), forgetF, labelAsForced, tryForceF )
{-------------------------------------------------------------------------
***************************************************************************              
COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose
***************************************************************************
---------------------------------------------------------------------------}

-- |The main compose (partial) function which simply drops the remainder faces from partCompose to return just
-- the composed Tgraph.  It will raise an error if the result is not a valid Tgraph
-- (i.e. if it fails the connectedness, no crossing boundary check).
-- It does not assume the given Tgraph is forced.
-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).
compose:: Tgraph -> Tgraph
compose :: Tgraph -> Tgraph
compose = ([TileFace], Tgraph) -> Tgraph
forall a b. (a, b) -> b
snd (([TileFace], Tgraph) -> Tgraph)
-> (Tgraph -> ([TileFace], Tgraph)) -> Tgraph -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> ([TileFace], Tgraph)
partCompose

-- |partCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) 
-- and a composed Tgraph. 
-- It checks the composed Tgraph for connectedness and no crossing boundaries
-- raising an error if this check fails.
-- It does not assume the given Tgraph is forced.
-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).
partCompose:: Tgraph -> ([TileFace],Tgraph)
partCompose :: Tgraph -> ([TileFace], Tgraph)
partCompose Tgraph
g = Try ([TileFace], Tgraph) -> ([TileFace], Tgraph)
forall a. Try a -> a
runTry (Try ([TileFace], Tgraph) -> ([TileFace], Tgraph))
-> Try ([TileFace], Tgraph) -> ([TileFace], Tgraph)
forall a b. (a -> b) -> a -> b
$ String -> Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a. String -> Try a -> Try a
onFail String
"partCompose:\n" (Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph))
-> Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a b. (a -> b) -> a -> b
$ Tgraph -> Try ([TileFace], Tgraph)
tryPartCompose Tgraph
g

-- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g,
-- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced.
-- It checks the resulting new faces for connectedness and no crossing boundaries.
-- If both the above succeed, the result is Right (remainder, g')
-- where g' is the composed Tgraph and remainder is a list
-- of faces from g which will not compose. 
tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph)
tryPartCompose :: Tgraph -> Try ([TileFace], Tgraph)
tryPartCompose Tgraph
g = 
  do DartWingInfo
dwInfo <- Tgraph -> Try DartWingInfo
tryGetDartWingInfo Tgraph
g 
     let (~[TileFace]
remainder,[TileFace]
newFaces) = DartWingInfo -> ([TileFace], [TileFace])
partComposeFacesFrom DartWingInfo
dwInfo
     Tgraph
checked <- String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
"tryPartCompose:\n" (Try Tgraph -> Try Tgraph) -> Try Tgraph -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Try Tgraph
tryConnectedNoCross [TileFace]
newFaces
     ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TileFace]
remainder,Tgraph
checked)

-- |Get the remainder and composed faces (without checking the composed faces make a valid Tgraph)
-- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced.
tryPartComposeFaces:: Tgraph -> Try ([TileFace],[TileFace])
tryPartComposeFaces :: Tgraph -> Try ([TileFace], [TileFace])
tryPartComposeFaces Tgraph
g = 
  do DartWingInfo
dwInfo <- Tgraph -> Try DartWingInfo
tryGetDartWingInfo Tgraph
g 
     ([TileFace], [TileFace]) -> Try ([TileFace], [TileFace])
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (([TileFace], [TileFace]) -> Try ([TileFace], [TileFace]))
-> ([TileFace], [TileFace]) -> Try ([TileFace], [TileFace])
forall a b. (a -> b) -> a -> b
$ DartWingInfo -> ([TileFace], [TileFace])
partComposeFacesFrom DartWingInfo
dwInfo
-- tryPartComposeFaces is used in an example showing failure of the connected, no crossing boundary check.


-- |Uses supplied dartwing info to get remainder faces and composed faces.
-- Does not assume forced and does not check the composed faces for connected/no crossing boundaries
partComposeFacesFrom :: DartWingInfo -> ([TileFace], [TileFace])
partComposeFacesFrom :: DartWingInfo -> ([TileFace], [TileFace])
partComposeFacesFrom = Bool -> DartWingInfo -> ([TileFace], [TileFace])
partCompFacesAssumeF Bool
False

{- 
-- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose)
-- and the composed faces (which may or may not constitute faces of a valid Tgraph).
-- It does not assume that g is forced which makes it less efficient than partComposeFacesF.
partComposeFaces:: Tgraph -> ([TileFace],[TileFace])
partComposeFaces = partCompFacesAssumeF False

-- |partComposeFacesF (does the same as partComposeFaces for a Forced Tgraph).
-- It produces a pair of the remainder faces (faces which will not compose)
-- and the composed faces.
partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace])
partComposeFacesF = partCompFacesAssumeF True . forgetF

 -}

-- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) 
-- and a composed (Forced) Tgraph.
-- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph.
-- The fact that the result is also Forced relies on a theorem.
partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph)
partComposeF :: Forced Tgraph -> ([TileFace], Forced Tgraph)
partComposeF Forced Tgraph
fg = ([TileFace]
remainder, Tgraph -> Forced Tgraph
forall a. a -> Forced a
labelAsForced (Tgraph -> Forced Tgraph) -> Tgraph -> Forced Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
newfaces) where
  (~[TileFace]
remainder,[TileFace]
newfaces) = Bool -> DartWingInfo -> ([TileFace], [TileFace])
partCompFacesAssumeF Bool
True (DartWingInfo -> ([TileFace], [TileFace]))
-> DartWingInfo -> ([TileFace], [TileFace])
forall a b. (a -> b) -> a -> b
$ Forced Tgraph -> DartWingInfo
getDartWingInfoForced Forced Tgraph
fg
  
-- |composeF - produces a composed Forced Tgraph from a Forced Tgraph.
-- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph.
-- The fact that the function is total and the result is also Forced relies on theorems
-- established for composing.
composeF:: Forced Tgraph -> Forced Tgraph
composeF :: Forced Tgraph -> Forced Tgraph
composeF = ([TileFace], Forced Tgraph) -> Forced Tgraph
forall a b. (a, b) -> b
snd (([TileFace], Forced Tgraph) -> Forced Tgraph)
-> (Forced Tgraph -> ([TileFace], Forced Tgraph))
-> Forced Tgraph
-> Forced Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forced Tgraph -> ([TileFace], Forced Tgraph)
partComposeF



-- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph.
-- Faces at a largeKiteCentre vertex will form kite faces when composed.
-- Faces at a largeDartBase vertex will form dart faces when composed.
-- Faces at an unknown vertex cannot be composed.
-- The record includes a faceMap from dart wings to faces at that vertex.
-- and a list of any faces (necessarily kites) not included in the faceMap (unMapped)
data DartWingInfo =  DartWingInfo 
     { DartWingInfo -> [Vertex]
largeKiteCentres  :: [Vertex] -- ^ dart wing vertices classified as large kite centres.
     , DartWingInfo -> [Vertex]
largeDartBases  :: [Vertex]  -- ^ dart wing vertices classified as large dart bases.
     , DartWingInfo -> [Vertex]
unknowns :: [Vertex] -- ^ unclassified (boundary) dart wing vertices.
     , DartWingInfo -> IntMap [TileFace]
faceMap :: VMap.IntMap [TileFace] -- ^ a mapping from dart wing vertices to faces at the vertex.
     , DartWingInfo -> [TileFace]
unMapped :: [TileFace] -- ^ any faces not at a dart wing vertex (necessarily kites)
     } deriving Vertex -> DartWingInfo -> ShowS
[DartWingInfo] -> ShowS
DartWingInfo -> String
(Vertex -> DartWingInfo -> ShowS)
-> (DartWingInfo -> String)
-> ([DartWingInfo] -> ShowS)
-> Show DartWingInfo
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> DartWingInfo -> ShowS
showsPrec :: Vertex -> DartWingInfo -> ShowS
$cshow :: DartWingInfo -> String
show :: DartWingInfo -> String
$cshowList :: [DartWingInfo] -> ShowS
showList :: [DartWingInfo] -> ShowS
Show

-- |Recover a list of faces (no repetitions) contained in the dart wing info.
-- (These should be all faces of the Tgraph used to make the dart wing info.)
recoverFaces :: DartWingInfo -> [TileFace]
recoverFaces :: DartWingInfo -> [TileFace]
recoverFaces DartWingInfo
dwInfo =  [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a]
nub ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (DartWingInfo -> [TileFace]
unMapped DartWingInfo
dwInfo [TileFace] -> [[TileFace]] -> [[TileFace]]
forall a. a -> [a] -> [a]
: IntMap [TileFace] -> [[TileFace]]
forall a. IntMap a -> [a]
VMap.elems (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo))


{- -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing,
-- returning as DartWingInfo. It does not assume g is forced and is more expensive than getDartWingInfoForced
getDartWingInfo:: Tgraph -> DartWingInfo
getDartWingInfo = getDWIassumeF False
 -}

-- |The given Tgraph is not assumed to be forced.
-- Getting the dart wing information makes use of the forced version
-- as well as the Tgraph so this uses tryForce first which can fail if
-- the Tgraph is found to be incorrect.
tryGetDartWingInfo :: Tgraph -> Try DartWingInfo
tryGetDartWingInfo :: Tgraph -> Try DartWingInfo
tryGetDartWingInfo Tgraph
g =
    do Forced Tgraph
fg <- String -> Try (Forced Tgraph) -> Try (Forced Tgraph)
forall a. String -> Try a -> Try a
onFail String
"tryGetDartWingInfo: incorrect Tgraph found.\n" (Try (Forced Tgraph) -> Try (Forced Tgraph))
-> Try (Forced Tgraph) -> Try (Forced Tgraph)
forall a b. (a -> b) -> a -> b
$ Tgraph -> Try (Forced Tgraph)
forall a. Forcible a => a -> Try (Forced a)
tryForceF Tgraph
g
       DartWingInfo -> Try DartWingInfo
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return (DartWingInfo -> Try DartWingInfo)
-> DartWingInfo -> Try DartWingInfo
forall a b. (a -> b) -> a -> b
$ Bool -> Tgraph -> Forced Tgraph -> DartWingInfo
getDWIassumeF Bool
False Tgraph
g Forced Tgraph
fg

-- | oldGetDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing,
-- returning as DartWingInfo. If only uses local information to classify each dart wing and can
-- therefore sometimes classify a dart wing as unknown unnecessarily.
-- In contrast tryGetDartWingInfo is accurate using information from forcing (so is not local)
oldGetDartWingInfo:: Tgraph -> DartWingInfo
oldGetDartWingInfo :: Tgraph -> DartWingInfo
oldGetDartWingInfo = Bool -> Tgraph -> DartWingInfo
oldGetDWIassumeF Bool
False

-- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg
-- and calculates a faceMap for each dart wing, returning as DartWingInfo.
-- The classification is much simplified knowing that the Tgraph is forced.
getDartWingInfoForced :: Forced Tgraph -> DartWingInfo
getDartWingInfoForced :: Forced Tgraph -> DartWingInfo
getDartWingInfoForced Forced Tgraph
fg = Bool -> Tgraph -> Forced Tgraph -> DartWingInfo
getDWIassumeF Bool
True (Forced Tgraph -> Tgraph
forall a. Forced a -> a
forgetF Forced Tgraph
fg) Forced Tgraph
fg

-- | getDWIassumeF (not exported but used to define 2 cases getDartWingInfoForced and tryGetDartWingInfo).
-- getDWIassumeF isForced g fg (where fg is forceF g), classifies the dart wings in g and calculates a faceMap for each dart wing,
-- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced.
-- When this is True, the classification is simpler and does not use fg.
getDWIassumeF:: Bool -> Tgraph -> Forced Tgraph -> DartWingInfo
getDWIassumeF :: Bool -> Tgraph -> Forced Tgraph -> DartWingInfo
getDWIassumeF Bool
isForced Tgraph
g Forced Tgraph
fg =  
  DartWingInfo { largeKiteCentres :: [Vertex]
largeKiteCentres = IntSet -> [Vertex]
IntSet.toList IntSet
allKcs
               , largeDartBases :: [Vertex]
largeDartBases = IntSet -> [Vertex]
IntSet.toList IntSet
allDbs
               , unknowns :: [Vertex]
unknowns = IntSet -> [Vertex]
IntSet.toList IntSet
allUnks
               , faceMap :: IntMap [TileFace]
faceMap = IntMap [TileFace]
dwFMap
               , unMapped :: [TileFace]
unMapped = [TileFace]
unused
               } where
  ([TileFace]
drts,[TileFace]
kts) = (TileFace -> Bool) -> [TileFace] -> ([TileFace], [TileFace])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)
  -- special case of vertexFacesMap for dart wings only
  -- using only relevant vertices where there is a dart wing.
  -- i.e only wings for darts and only oppVs and originVs for kites.
  -- The map is built first from darts, then kites are added.
  (IntMap [TileFace]
dwFMap,[TileFace]
unused) = ((IntMap [TileFace], [TileFace])
 -> TileFace -> (IntMap [TileFace], [TileFace]))
-> (IntMap [TileFace], [TileFace])
-> [TileFace]
-> (IntMap [TileFace], [TileFace])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap [TileFace], [TileFace])
-> TileFace -> (IntMap [TileFace], [TileFace])
insertK (IntMap [TileFace]
dartWMap,[]) [TileFace]
kts 
                    -- all kite halves added to relevant dart wings of the dart wing map.
    where           -- the unused list records half kites not added to any dart wing.
    dartWMap :: IntMap [TileFace]
dartWMap = (IntMap [TileFace] -> TileFace -> IntMap [TileFace])
-> IntMap [TileFace] -> [TileFace] -> IntMap [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap [TileFace] -> TileFace -> IntMap [TileFace]
insertD IntMap [TileFace]
forall a. IntMap a
VMap.empty [TileFace]
drts
                    -- maps all dart wing vertices to 1 or 2 half darts.
    insertD :: IntMap [TileFace] -> TileFace -> IntMap [TileFace]
insertD IntMap [TileFace]
vmap TileFace
f = (Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addD TileFace
f) (TileFace -> Vertex
wingV TileFace
f) IntMap [TileFace]
vmap
    addD :: a -> Maybe [a] -> Maybe [a]
addD a
f Maybe [a]
Nothing = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
f]
    addD a
f (Just [a]
fs) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
fs)
    insertK :: (IntMap [TileFace], [TileFace])
-> TileFace -> (IntMap [TileFace], [TileFace])
insertK (IntMap [TileFace]
vmap,[TileFace]
unsd) TileFace
f = 
      let opp :: Vertex
opp = TileFace -> Vertex
oppV TileFace
f
          org :: Vertex
org = TileFace -> Vertex
originV TileFace
f
      in  case (Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
opp IntMap [TileFace]
vmap, Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
org IntMap [TileFace]
vmap) of
            (Just [TileFace]
_ ,Just [TileFace]
_)     ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
opp (IntMap [TileFace] -> IntMap [TileFace])
-> IntMap [TileFace] -> IntMap [TileFace]
forall a b. (a -> b) -> a -> b
$ (Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
org IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Just [TileFace]
_ , Maybe [TileFace]
Nothing)   ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
opp IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Maybe [TileFace]
Nothing, Just [TileFace]
_ )   ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
org IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Maybe [TileFace]
Nothing, Maybe [TileFace]
Nothing)   ->  (IntMap [TileFace]
vmap, TileFace
fTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:[TileFace]
unsd) -- kite face not at any dart wing

    addK :: a -> Maybe [a] -> Maybe [a]
addK a
_ Maybe [a]
Nothing = Maybe [a]
forall a. Maybe a
Nothing  -- not added to map if it is not a dart wing vertex
    addK a
f (Just [a]
fs) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
fs)

  (IntSet
allKcs,IntSet
allDbs,IntSet
allUnks) = ((IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet))
-> (IntSet, IntSet, IntSet)
-> [TileFace]
-> (IntSet, IntSet, IntSet)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet)
processD (IntSet
IntSet.empty, IntSet
IntSet.empty, IntSet
IntSet.empty) [TileFace]
drts  
-- kcs = kite centres of larger kites,
-- dbs = dart bases of larger darts,
-- unks = unclassified dart wing vertices
-- Uses a triple of IntSets rather than lists
  processD :: (IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet)
processD (IntSet
kcs, IntSet
dbs, IntSet
unks) TileFace
drt =
    let w :: Vertex
w = TileFace -> Vertex
wingV TileFace
drt
        revLongE :: Dedge
revLongE = Dedge -> Dedge
reverseD (TileFace -> Dedge
longE TileFace
drt)
    in
        if Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
kcs Bool -> Bool -> Bool
|| Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
dbs then (IntSet
kcs, IntSet
dbs, IntSet
unks) else-- already classified
        let
            fcs :: [TileFace]
fcs = IntMap [TileFace]
dwFMap IntMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
w -- list of  faces at w
        in
            if Vertex
w 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]
map TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs) then (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) else 
                    -- wing is a half kite origin => largeDartBase
            if Dedge
revLongE Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Dedge) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
map TileFace -> Dedge
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart [TileFace]
fcs) then (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) else 
                    -- long edge drt shared with another dart => largeKiteCentre
            if Bool
isForced then (IntSet
kcs, IntSet
dbs, Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) else
            let     -- (when not already forced) do same checks but with forced faces 
                ffcs :: [TileFace]
ffcs = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> TileFace -> Bool
isAtV Vertex
w) (Forced Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Forced Tgraph
fg)
            in
                if Vertex
w 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]
map TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
ffcs) then (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) else 
                    -- wing is a half kite origin => largeDartBase
                if Dedge
revLongE Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Dedge) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
map TileFace -> Dedge
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart [TileFace]
ffcs) then (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) else 
                    -- long edge drt shared with another dart => largeKiteCentre
                (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) 



-- |partCompFacesAssumeF
-- (not exported but used to build 2 cases: partComposeFacesFrom, partComposeF)
-- If the boolean is True then assumptions are made that the DartWingIno
-- has come from a forced Tgraph,
-- making the remainder faces calculation more efficient.
partCompFacesAssumeF :: Bool ->  DartWingInfo -> ([TileFace],[TileFace])
partCompFacesAssumeF :: Bool -> DartWingInfo -> ([TileFace], [TileFace])
partCompFacesAssumeF Bool
isForced DartWingInfo
dwInfo = ([TileFace]
remainder, [TileFace]
newFaces) where
    ~[TileFace]
remainder = 
        if Bool
isForced
        then -- unMapped faces plus all faces at unknowns.
            DartWingInfo -> [TileFace]
unMapped DartWingInfo
dwInfo [TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++ (Vertex -> [TileFace]) -> [Vertex] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo VMap.!) (DartWingInfo -> [Vertex]
unknowns DartWingInfo
dwInfo)
        else -- all faces except those successfully used in making composed faces.
            DartWingInfo -> [TileFace]
recoverFaces DartWingInfo
dwInfo [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ ([[TileFace]] -> [TileFace]) -> [[[TileFace]]] -> [TileFace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[TileFace]]
groupRDs, [[TileFace]]
groupLDs, [[TileFace]]
groupRKs, [[TileFace]]
groupLKs]
    
    newFaces :: [TileFace]
newFaces = [TileFace]
newRDs [TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++ [TileFace]
newLDs [TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++ [TileFace]
newRKs [TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++ [TileFace]
newLKs

    newRDs :: [TileFace]
newRDs = ([TileFace] -> TileFace) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map [TileFace] -> TileFace
makenewRD [[TileFace]]
groupRDs 
    groupRDs :: [[TileFace]]
groupRDs = (Vertex -> Maybe [TileFace]) -> [Vertex] -> [[TileFace]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Vertex -> Maybe [TileFace]
groupRD (DartWingInfo -> [Vertex]
largeDartBases DartWingInfo
dwInfo)
    makenewRD :: [TileFace] -> TileFace
makenewRD [TileFace
rd,TileFace
lk] = Vertex -> Vertex -> Vertex -> TileFace
makeRD (TileFace -> Vertex
originV TileFace
lk) (TileFace -> Vertex
originV TileFace
rd) (TileFace -> Vertex
oppV TileFace
lk) 
    makenewRD [TileFace]
_       = String -> TileFace
forall a. HasCallStack => String -> a
error String
"composedFaceGroups: RD case"
    groupRD :: Vertex -> Maybe [TileFace]
groupRD Vertex
v = do  [TileFace]
fcs <- Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo)
                    TileFace
rd <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRD [TileFace]
fcs
                    TileFace
lk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
rd) [TileFace]
fcs
                    [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [TileFace
rd,TileFace
lk]

    newLDs :: [TileFace]
newLDs = ([TileFace] -> TileFace) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map [TileFace] -> TileFace
makenewLD [[TileFace]]
groupLDs 
    groupLDs :: [[TileFace]]
groupLDs = (Vertex -> Maybe [TileFace]) -> [Vertex] -> [[TileFace]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Vertex -> Maybe [TileFace]
groupLD (DartWingInfo -> [Vertex]
largeDartBases DartWingInfo
dwInfo) 
    makenewLD :: [TileFace] -> TileFace
makenewLD [TileFace
ld,TileFace
rk] = Vertex -> Vertex -> Vertex -> TileFace
makeLD (TileFace -> Vertex
originV TileFace
rk) (TileFace -> Vertex
oppV TileFace
rk) (TileFace -> Vertex
originV TileFace
ld)
    makenewLD [TileFace]
_       = String -> TileFace
forall a. HasCallStack => String -> a
error String
"composedFaceGroups: LD case"
    groupLD :: Vertex -> Maybe [TileFace]
groupLD Vertex
v = do  [TileFace]
fcs <- Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo)
                    TileFace
ld <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLD [TileFace]
fcs
                    TileFace
rk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
ld) [TileFace]
fcs
                    [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [TileFace
ld,TileFace
rk]

    newRKs :: [TileFace]
newRKs = ([TileFace] -> TileFace) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map [TileFace] -> TileFace
makenewRK [[TileFace]]
groupRKs 
    groupRKs :: [[TileFace]]
groupRKs = (Vertex -> Maybe [TileFace]) -> [Vertex] -> [[TileFace]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Vertex -> Maybe [TileFace]
groupRK (DartWingInfo -> [Vertex]
largeKiteCentres DartWingInfo
dwInfo) 
    makenewRK :: [TileFace] -> TileFace
makenewRK [TileFace
rd,TileFace
_,TileFace
rk] = Vertex -> Vertex -> Vertex -> TileFace
makeRK (TileFace -> Vertex
originV TileFace
rd) (TileFace -> Vertex
wingV TileFace
rk) (TileFace -> Vertex
originV TileFace
rk)
    makenewRK [TileFace]
_         = String -> TileFace
forall a. HasCallStack => String -> a
error String
"composedFaceGroups: RK case"
    groupRK :: Vertex -> Maybe [TileFace]
groupRK Vertex
v = do  [TileFace]
fcs <- Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo)
                    TileFace
rd <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRD [TileFace]
fcs
                    TileFace
lk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
rd) [TileFace]
fcs
                    TileFace
rk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingJoinE TileFace
lk) [TileFace]
fcs
                    [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [TileFace
rd,TileFace
lk,TileFace
rk]

    newLKs :: [TileFace]
newLKs = ([TileFace] -> TileFace) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map [TileFace] -> TileFace
makenewLK [[TileFace]]
groupLKs 
    groupLKs :: [[TileFace]]
groupLKs = (Vertex -> Maybe [TileFace]) -> [Vertex] -> [[TileFace]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Vertex -> Maybe [TileFace]
groupLK (DartWingInfo -> [Vertex]
largeKiteCentres DartWingInfo
dwInfo) 
    makenewLK :: [TileFace] -> TileFace
makenewLK [TileFace
ld,TileFace
_,TileFace
lk] = Vertex -> Vertex -> Vertex -> TileFace
makeLK (TileFace -> Vertex
originV TileFace
ld) (TileFace -> Vertex
originV TileFace
lk) (TileFace -> Vertex
wingV TileFace
lk)
    makenewLK [TileFace]
_         = String -> TileFace
forall a. HasCallStack => String -> a
error String
"composedFaceGroups: LK case"
    groupLK :: Vertex -> Maybe [TileFace]
groupLK Vertex
v = do  [TileFace]
fcs <- Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (DartWingInfo -> IntMap [TileFace]
faceMap DartWingInfo
dwInfo)
                    TileFace
ld <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLD [TileFace]
fcs
                    TileFace
rk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
ld) [TileFace]
fcs
                    TileFace
lk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingJoinE TileFace
rk) [TileFace]
fcs
                    [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [TileFace
ld,TileFace
rk,TileFace
lk]


-- |partCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) 
-- and a composed Tgraph. 
-- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails.
-- It does not assume the given Tgraph is forced.
-- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).
oldPartCompose:: Tgraph -> ([TileFace],Tgraph)
oldPartCompose :: Tgraph -> ([TileFace], Tgraph)
oldPartCompose Tgraph
g = Try ([TileFace], Tgraph) -> ([TileFace], Tgraph)
forall a. Try a -> a
runTry (Try ([TileFace], Tgraph) -> ([TileFace], Tgraph))
-> Try ([TileFace], Tgraph) -> ([TileFace], Tgraph)
forall a b. (a -> b) -> a -> b
$ String -> Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a. String -> Try a -> Try a
onFail String
"oldPartCompose:\n" (Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph))
-> Try ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a b. (a -> b) -> a -> b
$
  do let dwInfo :: DartWingInfo
dwInfo = Tgraph -> DartWingInfo
oldGetDartWingInfo Tgraph
g 
         (~[TileFace]
remainder,[TileFace]
newFaces) = DartWingInfo -> ([TileFace], [TileFace])
partComposeFacesFrom DartWingInfo
dwInfo
     Tgraph
checked <- [TileFace] -> Try Tgraph
tryConnectedNoCross [TileFace]
newFaces
     ([TileFace], Tgraph) -> Try ([TileFace], Tgraph)
forall a. a -> Either ShowS a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TileFace]
remainder,Tgraph
checked)


-- | oldGetDWIassumeF (not exported but used to define oldGetDartWingInfo).
-- oldGetDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing,
-- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced.
oldGetDWIassumeF:: Bool -> Tgraph -> DartWingInfo
oldGetDWIassumeF :: Bool -> Tgraph -> DartWingInfo
oldGetDWIassumeF Bool
isForced Tgraph
g =  
  DartWingInfo { largeKiteCentres :: [Vertex]
largeKiteCentres = IntSet -> [Vertex]
IntSet.toList IntSet
allKcs
               , largeDartBases :: [Vertex]
largeDartBases = IntSet -> [Vertex]
IntSet.toList IntSet
allDbs
               , unknowns :: [Vertex]
unknowns = IntSet -> [Vertex]
IntSet.toList IntSet
allUnks
               , faceMap :: IntMap [TileFace]
faceMap = IntMap [TileFace]
dwFMap
               , unMapped :: [TileFace]
unMapped = [TileFace]
unused
               } where
  ([TileFace]
drts,[TileFace]
kts) = (TileFace -> Bool) -> [TileFace] -> ([TileFace], [TileFace])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)
  -- special case of vertexFacesMap for dart wings only
  -- using only relevant vertices where there is a dart wing.
  -- i.e only wingVs for darts and only oppVs and originVs for kites.
  -- The map is built first from darts, then kites are added.
  (IntMap [TileFace]
dwFMap,[TileFace]
unused) = ((IntMap [TileFace], [TileFace])
 -> TileFace -> (IntMap [TileFace], [TileFace]))
-> (IntMap [TileFace], [TileFace])
-> [TileFace]
-> (IntMap [TileFace], [TileFace])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap [TileFace], [TileFace])
-> TileFace -> (IntMap [TileFace], [TileFace])
insertK (IntMap [TileFace]
dartWMap,[]) [TileFace]
kts
                    -- all kite halves added to relevant dart wings of the dart wing faces map
    where           -- the unused list records half kites not added to any dart wing
    dartWMap :: IntMap [TileFace]
dartWMap = (IntMap [TileFace] -> TileFace -> IntMap [TileFace])
-> IntMap [TileFace] -> [TileFace] -> IntMap [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap [TileFace] -> TileFace -> IntMap [TileFace]
insertD IntMap [TileFace]
forall a. IntMap a
VMap.empty [TileFace]
drts
                     -- maps all dart wing vertices to 1 or 2 half darts
    insertD :: IntMap [TileFace] -> TileFace -> IntMap [TileFace]
insertD IntMap [TileFace]
vmap TileFace
f = (Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addD TileFace
f) (TileFace -> Vertex
wingV TileFace
f) IntMap [TileFace]
vmap
    addD :: a -> Maybe [a] -> Maybe [a]
addD a
f Maybe [a]
Nothing = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
f]
    addD a
f (Just [a]
fs) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
fs)
    insertK :: (IntMap [TileFace], [TileFace])
-> TileFace -> (IntMap [TileFace], [TileFace])
insertK (IntMap [TileFace]
vmap,[TileFace]
unsd) TileFace
f = 
      let opp :: Vertex
opp = TileFace -> Vertex
oppV TileFace
f
          org :: Vertex
org = TileFace -> Vertex
originV TileFace
f
      in  case (Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
opp IntMap [TileFace]
vmap, Vertex -> IntMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
org IntMap [TileFace]
vmap) of
            (Just [TileFace]
_ ,Just [TileFace]
_)     ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
opp (IntMap [TileFace] -> IntMap [TileFace])
-> IntMap [TileFace] -> IntMap [TileFace]
forall a b. (a -> b) -> a -> b
$ (Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
org IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Just [TileFace]
_ , Maybe [TileFace]
Nothing)   ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
opp IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Maybe [TileFace]
Nothing, Just [TileFace]
_ )   ->  ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> IntMap [TileFace] -> IntMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter (TileFace -> Maybe [TileFace] -> Maybe [TileFace]
forall {a}. a -> Maybe [a] -> Maybe [a]
addK TileFace
f) Vertex
org IntMap [TileFace]
vmap, [TileFace]
unsd)
            (Maybe [TileFace]
Nothing, Maybe [TileFace]
Nothing)   ->  (IntMap [TileFace]
vmap, TileFace
fTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:[TileFace]
unsd)

    addK :: a -> Maybe [a] -> Maybe [a]
addK a
_ Maybe [a]
Nothing = Maybe [a]
forall a. Maybe a
Nothing  -- not added to map if it is not a dart wing vertex
    addK a
f (Just [a]
fs) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
fs)

  (IntSet
allKcs,IntSet
allDbs,IntSet
allUnks) = ((IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet))
-> (IntSet, IntSet, IntSet)
-> [TileFace]
-> (IntSet, IntSet, IntSet)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet)
processD (IntSet
IntSet.empty, IntSet
IntSet.empty, IntSet
IntSet.empty) [TileFace]
drts  
-- kcs = kite centres of larger kites,
-- dbs = dart bases of larger darts,
-- unks = unclassified dart wing vertices
-- Uses a triple of IntSets rather than lists
  processD :: (IntSet, IntSet, IntSet) -> TileFace -> (IntSet, IntSet, IntSet)
processD (IntSet
kcs, IntSet
dbs, IntSet
unks) rd :: TileFace
rd@(RD (Vertex
orig, Vertex
w, Vertex
_)) = -- classify wing tip w
    if Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
kcs Bool -> Bool -> Bool
|| Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
dbs then (IntSet
kcs, IntSet
dbs, IntSet
unks) else-- already classified
    let
        fcs :: [TileFace]
fcs = IntMap [TileFace]
dwFMap IntMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
w -- faces at w
--        Just fcs = VMap.lookup w dwFMap -- faces at w
    in
        if Vertex
w 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]
map TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs) then (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) else 
                -- wing is a half kite origin => largeDartBase
        if (Vertex
w,Vertex
orig) Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Dedge) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
map TileFace -> Dedge
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLD [TileFace]
fcs) then (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) else 
                -- long edge rd shared with an ld => largeKiteCentre
        if Bool
isForced Bool -> Bool -> Bool
|| [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
fcs Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
1 then (IntSet
kcs, IntSet
dbs, Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) else
        case TileFace -> [TileFace] -> Maybe TileFace
findFarK TileFace
rd [TileFace]
fcs of -- extra inspection only needed for unforced Tgraphs
        Maybe TileFace
Nothing -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) -- unknown if incomplete kite attached to short edge of rd
        Just rk :: TileFace
rk@(RK (Vertex, Vertex, Vertex)
_)  ->  
            case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
rk) [TileFace]
fcs of
            Just (LK (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) -- short edge rk shared with an lk => largeKiteCentres
            Just (LD (Vertex, Vertex, Vertex)
_) -> (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) -- short edge rk shared with an ld => largeDartBases
            Maybe TileFace
_ -> let 
                     newfcs :: [TileFace]
newfcs = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> TileFace -> Bool
isAtV (TileFace -> Vertex
wingV TileFace
rk)) (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)   -- faces at rk wing    
                 in
                 case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingLongE TileFace
rk) [TileFace]
newfcs of  -- short edge rk has nothing attached
                 Maybe TileFace
Nothing -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks)  -- long edge of rk has nothing attached => unknown
                 Just (LD (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) -- long edge rk shared with ld => largeKiteCentres
                 Just lk :: TileFace
lk@(LK (Vertex, Vertex, Vertex)
_) ->               -- long edge rk shared with lk
                      case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
lk) [TileFace]
newfcs of
                      Just (RK (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks)
                              -- short edge of this lk shared with another rk => largeKiteCentres
                      Just (RD (Vertex, Vertex, Vertex)
_) -> (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) 
                              -- short edge of this lk shared with rd => largeDartBases
                      Maybe TileFace
_ -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) 
                 Just TileFace
_ ->  String -> (IntSet, IntSet, IntSet)
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: illegal case for matchingLongE of a right kite"
                              -- short edge of this lk has nothing attached => unknown
        Just TileFace
_ -> String -> (IntSet, IntSet, IntSet)
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: non-kite returned by findFarK"

-- processD now uses a triple of IntSets rather than lists
  processD (IntSet
kcs, IntSet
dbs, IntSet
unks) ld :: TileFace
ld@(LD (Vertex
orig, Vertex
_, Vertex
w)) = -- classify wing tip w
    if Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
kcs Bool -> Bool -> Bool
|| Vertex
w Vertex -> IntSet -> Bool
`IntSet.member` IntSet
dbs then (IntSet
kcs, IntSet
dbs, IntSet
unks) else  -- already classified
    let
        fcs :: [TileFace]
fcs = IntMap [TileFace]
dwFMap IntMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
w -- faces at w
    in
        if Vertex
w 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]
map TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs) then (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks) else
                   -- wing is a half kite origin => largeDartBase
        if (Vertex
orig,Vertex
w) Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> Dedge) -> [TileFace] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
map TileFace -> Dedge
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRD [TileFace]
fcs) then (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) else
                   -- long edge ld shared with an rd => largeKiteCentre
        if Bool
isForced Bool -> Bool -> Bool
|| [TileFace] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [TileFace]
fcs Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
1 then (IntSet
kcs, IntSet
dbs, Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) else
        case TileFace -> [TileFace] -> Maybe TileFace
findFarK TileFace
ld [TileFace]
fcs of -- extra inspection only needed for unforced Tgraphs
          Maybe TileFace
Nothing -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) -- unknown if incomplete kite attached to short edge of ld
          Just lk :: TileFace
lk@(LK (Vertex, Vertex, Vertex)
_)  ->  
            case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
lk) [TileFace]
fcs of
            Just (RK (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) 
                  -- short edge lk shared with an rk => largeKiteCentres
            Just (RD (Vertex, Vertex, Vertex)
_) -> (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks)
                  -- short edge lk shared with an rd => largeDartBases
            Maybe TileFace
_ -> let 
                     newfcs :: [TileFace]
newfcs = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> TileFace -> Bool
isAtV (TileFace -> Vertex
wingV TileFace
lk)) (Tgraph -> [TileFace]
forall a. HasFaces a => a -> [TileFace]
faces Tgraph
g)   -- faces at lk wing  
                 in
                 case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingLongE TileFace
lk) [TileFace]
newfcs of -- short edge lk has nothing attached
                 Maybe TileFace
Nothing -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks)  -- long edge of lk has nothing attached => unknown
                 Just (RD (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks) -- long edge lk shared with rd => largeKiteCentres
                 Just rk :: TileFace
rk@(RK (Vertex, Vertex, Vertex)
_) ->               -- long edge lk is shared with an rk
                     case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
rk) [TileFace]
newfcs of
                     Just (LK (Vertex, Vertex, Vertex)
_) -> (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
kcs,IntSet
dbs,IntSet
unks)
                             -- short edge of this rk shared with another lk => largeKiteCentres
                     Just (LD (Vertex, Vertex, Vertex)
_) -> (IntSet
kcs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
dbs,IntSet
unks)
                             -- short edge of this rk shared with ld => largeDartBases
                     Maybe TileFace
_ -> (IntSet
kcs,IntSet
dbs,Vertex -> IntSet -> IntSet
IntSet.insert Vertex
w IntSet
unks) -- short edge of this rk has nothing attached => unknown
                 Just TileFace
_ ->  String -> (IntSet, IntSet, IntSet)
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: illegal case for matchingLongE of a left kite"

          Just TileFace
_ -> String -> (IntSet, IntSet, IntSet)
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: non-kite returned by findFarK"

  processD (IntSet, IntSet, IntSet)
_ TileFace
_ = String -> (IntSet, IntSet, IntSet)
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: processD applied to non-dart"

    -- find the two kite halves below a dart half, return the half kite furthest away (not attached to dart).
    -- Returns a Maybe.   rd produces an rk (or Nothing) ld produces an lk (or Nothing)
  findFarK :: TileFace -> [TileFace] -> Maybe TileFace
  findFarK :: TileFace -> [TileFace] -> Maybe TileFace
findFarK rd :: TileFace
rd@(RD (Vertex, Vertex, Vertex)
_) [TileFace]
fcs = do TileFace
lk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
rd) ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLK [TileFace]
fcs)
                              (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingJoinE TileFace
lk) ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRK [TileFace]
fcs)
  findFarK ld :: TileFace
ld@(LD (Vertex, Vertex, Vertex)
_) [TileFace]
fcs = do TileFace
rk <- (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingShortE TileFace
ld) ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRK [TileFace]
fcs)
                              (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TileFace -> TileFace -> Bool
matchingJoinE TileFace
rk)  ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLK [TileFace]
fcs)
  findFarK TileFace
_ [TileFace]
_ = String -> Maybe TileFace
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: findFarK applied to non-dart face"

{- 
-- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face)
-- using dart wing information. No longer used.
composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])]
composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where

    faceGroupRDs = map (\gp -> (makenewRD gp,gp)) groupRDs 
    groupRDs = mapMaybe groupRD (largeDartBases dwInfo)
    makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) 
    makenewRD _       = error "composedFaceGroups: RD case"
    groupRD v = do  fcs <- VMap.lookup v (faceMap dwInfo)
                    rd <- find isRD fcs
                    lk <- find (matchingShortE rd) fcs
                    return [rd,lk]

    faceGroupLDs = map (\gp -> (makenewLD gp,gp)) groupLDs 
    groupLDs = mapMaybe groupLD (largeDartBases dwInfo) 
    makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld)
    makenewLD _       = error "composedFaceGroups: LD case"
    groupLD v = do  fcs <- VMap.lookup v (faceMap dwInfo)
                    ld <- find isLD fcs
                    rk <- find (matchingShortE ld) fcs
                    return [ld,rk]

    faceGroupRKs = map (\gp -> (makenewRK gp,gp)) groupRKs 
    groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) 
    makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk)
    makenewRK _         = error "composedFaceGroups: RK case"
    groupRK v = do  fcs <- VMap.lookup v (faceMap dwInfo)
                    rd <- find isRD fcs
                    lk <- find (matchingShortE rd) fcs
                    rk <- find (matchingJoinE lk) fcs
                    return [rd,lk,rk]

    faceGroupLKs = map (\gp -> (makenewLK gp,gp)) groupLKs 
    groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) 
    makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk)
    makenewLK _         = error "composedFaceGroups: LK case"
    groupLK v = do  fcs <- VMap.lookup v (faceMap dwInfo)
                    ld <- find isLD fcs
                    rk <- find (matchingShortE ld) fcs
                    lk <- find (matchingJoinE rk) fcs
                    return [ld,rk,lk]

-}