module Tgraph.Compose
( compose
, partCompose
, tryPartCompose
, uncheckedCompose
, uncheckedPartCompose
, partComposeFaces
, composedFaces
, DartWingInfo(..)
, getDartWingInfo
, composedFaceGroups
) where
import Data.List ((\\), find, foldl',nub)
import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!))
import Data.Maybe (mapMaybe)
import Tgraph.Prelude
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
uncheckedCompose:: Tgraph -> Tgraph
uncheckedCompose :: Tgraph -> Tgraph
uncheckedCompose = ([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)
uncheckedPartCompose
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:: Tgraph -> Try ([TileFace],Tgraph)
tryPartCompose :: Tgraph -> Try ([TileFace], Tgraph)
tryPartCompose Tgraph
g =
do let ([TileFace]
remainder,[TileFace]
newFaces) = Tgraph -> ([TileFace], [TileFace])
partComposeFaces Tgraph
g
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 String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TileFace]
remainder,Tgraph
checked)
uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph)
uncheckedPartCompose :: Tgraph -> ([TileFace], Tgraph)
uncheckedPartCompose Tgraph
g = ([TileFace]
remainder, [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
newfaces) where
([TileFace]
remainder,[TileFace]
newfaces) = Tgraph -> ([TileFace], [TileFace])
partComposeFaces Tgraph
g
partComposeFaces:: Tgraph -> ([TileFace],[TileFace])
partComposeFaces :: Tgraph -> ([TileFace], [TileFace])
partComposeFaces Tgraph
g = ([TileFace]
remainder,[TileFace]
newfaces) where
compositions :: [(TileFace, [TileFace])]
compositions = DartWingInfo -> [(TileFace, [TileFace])]
composedFaceGroups (DartWingInfo -> [(TileFace, [TileFace])])
-> DartWingInfo -> [(TileFace, [TileFace])]
forall a b. (a -> b) -> a -> b
$ Tgraph -> DartWingInfo
getDartWingInfo Tgraph
g
newfaces :: [TileFace]
newfaces = ((TileFace, [TileFace]) -> TileFace)
-> [(TileFace, [TileFace])] -> [TileFace]
forall a b. (a -> b) -> [a] -> [b]
map (TileFace, [TileFace]) -> TileFace
forall a b. (a, b) -> a
fst [(TileFace, [TileFace])]
compositions
groups :: [[TileFace]]
groups = ((TileFace, [TileFace]) -> [TileFace])
-> [(TileFace, [TileFace])] -> [[TileFace]]
forall a b. (a -> b) -> [a] -> [b]
map (TileFace, [TileFace]) -> [TileFace]
forall a b. (a, b) -> b
snd [(TileFace, [TileFace])]
compositions
remainder :: [TileFace]
remainder = Tgraph -> [TileFace]
faces Tgraph
g [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TileFace]]
groups
composedFaces:: Tgraph -> [TileFace]
composedFaces :: Tgraph -> [TileFace]
composedFaces = ([TileFace], [TileFace]) -> [TileFace]
forall a b. (a, b) -> b
snd (([TileFace], [TileFace]) -> [TileFace])
-> (Tgraph -> ([TileFace], [TileFace])) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> ([TileFace], [TileFace])
partComposeFaces
data DartWingInfo = DartWingInfo
{ DartWingInfo -> [Vertex]
largeKiteCentres :: [Vertex]
, DartWingInfo -> [Vertex]
largeDartBases :: [Vertex]
, DartWingInfo -> [Vertex]
unknowns :: [Vertex]
, DartWingInfo -> IntMap [TileFace]
faceMap :: VMap.IntMap [TileFace]
} 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
getDartWingInfo:: Tgraph -> DartWingInfo
getDartWingInfo :: Tgraph -> DartWingInfo
getDartWingInfo Tgraph
g = DartWingInfo {largeKiteCentres :: [Vertex]
largeKiteCentres = [Vertex]
allKcs, largeDartBases :: [Vertex]
largeDartBases = [Vertex]
allDbs, unknowns :: [Vertex]
unknowns = [Vertex]
allUnks, faceMap :: IntMap [TileFace]
faceMap = IntMap [TileFace]
dwFMap} where
drts :: [TileFace]
drts = Tgraph -> [TileFace]
darts Tgraph
g
dwFMap :: IntMap [TileFace]
dwFMap = [Vertex] -> [TileFace] -> IntMap [TileFace]
vertexFacesMap ([Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
nub ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ (TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
wingV [TileFace]
drts) (Tgraph -> [TileFace]
faces Tgraph
g)
([Vertex]
allKcs,[Vertex]
allDbs,[Vertex]
allUnks) = (([Vertex], [Vertex], [Vertex])
-> TileFace -> ([Vertex], [Vertex], [Vertex]))
-> ([Vertex], [Vertex], [Vertex])
-> [TileFace]
-> ([Vertex], [Vertex], [Vertex])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Vertex], [Vertex], [Vertex])
-> TileFace -> ([Vertex], [Vertex], [Vertex])
processD ([],[],[]) [TileFace]
drts
processD :: ([Vertex], [Vertex], [Vertex])
-> TileFace -> ([Vertex], [Vertex], [Vertex])
processD ([Vertex]
kcs, [Vertex]
dbs, [Vertex]
unks) rd :: TileFace
rd@(RD (Vertex
orig, Vertex
w, Vertex
_)) =
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` [Vertex]
kcs Bool -> Bool -> Bool
|| Vertex
w Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
dbs then ([Vertex]
kcs, [Vertex]
dbs, [Vertex]
unks) else
let
fcs :: [TileFace]
fcs = IntMap [TileFace]
dwFMap IntMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
w
in
if [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 ([Vertex]
kcs, [Vertex]
dbs, Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks) else
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]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs) then ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks) else
if (Vertex
w,Vertex
orig) (Vertex, Vertex) -> [(Vertex, Vertex)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> (Vertex, Vertex)) -> [TileFace] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> (Vertex, Vertex)
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLD [TileFace]
fcs) then (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks) else
case TileFace -> [TileFace] -> Maybe TileFace
findFarK TileFace
rd [TileFace]
fcs of
Maybe TileFace
Nothing -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
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
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
Just (LD (Vertex, Vertex, Vertex)
_) -> ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks)
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]
faces Tgraph
g)
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
Maybe TileFace
Nothing -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
Just (LD (Vertex, Vertex, Vertex)
_) -> (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
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]
newfcs of
Just (RK (Vertex, Vertex, Vertex)
_) -> (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
Just (RD (Vertex, Vertex, Vertex)
_) -> ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks)
Maybe TileFace
_ -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
Just TileFace
_ -> String -> ([Vertex], [Vertex], [Vertex])
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: illegal case for matchingLongE of a right kite"
Just TileFace
_ -> String -> ([Vertex], [Vertex], [Vertex])
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: non-kite returned by findFarK"
processD ([Vertex]
kcs, [Vertex]
dbs, [Vertex]
unks) ld :: TileFace
ld@(LD (Vertex
orig, Vertex
_, Vertex
w)) =
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` [Vertex]
kcs Bool -> Bool -> Bool
|| Vertex
w Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
dbs then ([Vertex]
kcs, [Vertex]
dbs, [Vertex]
unks) else
let
fcs :: [TileFace]
fcs = IntMap [TileFace]
dwFMap IntMap [TileFace] -> Vertex -> [TileFace]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
w
in
if [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 ([Vertex]
kcs, [Vertex]
dbs, Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks) else
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]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite [TileFace]
fcs) then ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks) else
if (Vertex
w,Vertex
orig) (Vertex, Vertex) -> [(Vertex, Vertex)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TileFace -> (Vertex, Vertex)) -> [TileFace] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> (Vertex, Vertex)
longE ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRD [TileFace]
fcs) then (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks) else
case TileFace -> [TileFace] -> Maybe TileFace
findFarK TileFace
ld [TileFace]
fcs of
Maybe TileFace
Nothing -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
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
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
Just (RD (Vertex, Vertex, Vertex)
_) -> ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks)
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]
faces Tgraph
g)
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
Maybe TileFace
Nothing -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
Just (RD (Vertex, Vertex, Vertex)
_) -> (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
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]
newfcs of
Just (LK (Vertex, Vertex, Vertex)
_) -> (Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
kcs,[Vertex]
dbs,[Vertex]
unks)
Just (LD (Vertex, Vertex, Vertex)
_) -> ([Vertex]
kcs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
dbs,[Vertex]
unks)
Maybe TileFace
_ -> ([Vertex]
kcs,[Vertex]
dbs,Vertex
wVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
unks)
Just TileFace
_ -> String -> ([Vertex], [Vertex], [Vertex])
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: illegal case for matchingLongE of a left kite"
Just TileFace
_ -> String -> ([Vertex], [Vertex], [Vertex])
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: non-kite returned by findFarK"
processD ([Vertex], [Vertex], [Vertex])
_ TileFace
_ = String -> ([Vertex], [Vertex], [Vertex])
forall a. HasCallStack => String -> a
error String
"getDartWingInfo: processD applied to non-dart"
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"
composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])]
composedFaceGroups :: DartWingInfo -> [(TileFace, [TileFace])]
composedFaceGroups DartWingInfo
dwInfo = [(TileFace, [TileFace])]
faceGroupRDs [(TileFace, [TileFace])]
-> [(TileFace, [TileFace])] -> [(TileFace, [TileFace])]
forall a. [a] -> [a] -> [a]
++ [(TileFace, [TileFace])]
faceGroupLDs [(TileFace, [TileFace])]
-> [(TileFace, [TileFace])] -> [(TileFace, [TileFace])]
forall a. [a] -> [a] -> [a]
++ [(TileFace, [TileFace])]
faceGroupRKs [(TileFace, [TileFace])]
-> [(TileFace, [TileFace])] -> [(TileFace, [TileFace])]
forall a. [a] -> [a] -> [a]
++ [(TileFace, [TileFace])]
faceGroupLKs where
faceGroupRDs :: [(TileFace, [TileFace])]
faceGroupRDs = ([TileFace] -> (TileFace, [TileFace]))
-> [[TileFace]] -> [(TileFace, [TileFace])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TileFace]
gp -> ([TileFace] -> TileFace
makeRD [TileFace]
gp,[TileFace]
gp)) [[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)
makeRD :: [TileFace] -> TileFace
makeRD [TileFace
rd,TileFace
lk] = (Vertex, Vertex, Vertex) -> TileFace
forall rep. rep -> HalfTile rep
RD(TileFace -> Vertex
originV TileFace
lk, TileFace -> Vertex
originV TileFace
rd, TileFace -> Vertex
oppV TileFace
lk)
makeRD [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]
faceGroupLDs :: [(TileFace, [TileFace])]
faceGroupLDs = ([TileFace] -> (TileFace, [TileFace]))
-> [[TileFace]] -> [(TileFace, [TileFace])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TileFace]
gp -> ([TileFace] -> TileFace
makeLD [TileFace]
gp,[TileFace]
gp)) [[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)
makeLD :: [TileFace] -> TileFace
makeLD [TileFace
ld,TileFace
rk] = (Vertex, Vertex, Vertex) -> TileFace
forall rep. rep -> HalfTile rep
LD(TileFace -> Vertex
originV TileFace
rk, TileFace -> Vertex
oppV TileFace
rk, TileFace -> Vertex
originV TileFace
ld)
makeLD [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]
faceGroupRKs :: [(TileFace, [TileFace])]
faceGroupRKs = ([TileFace] -> (TileFace, [TileFace]))
-> [[TileFace]] -> [(TileFace, [TileFace])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TileFace]
gp -> ([TileFace] -> TileFace
makeRK [TileFace]
gp,[TileFace]
gp)) [[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)
makeRK :: [TileFace] -> TileFace
makeRK [TileFace
rd,TileFace
_,TileFace
rk] = (Vertex, Vertex, Vertex) -> TileFace
forall rep. rep -> HalfTile rep
RK(TileFace -> Vertex
originV TileFace
rd, TileFace -> Vertex
wingV TileFace
rk, TileFace -> Vertex
originV TileFace
rk)
makeRK [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]
faceGroupLKs :: [(TileFace, [TileFace])]
faceGroupLKs = ([TileFace] -> (TileFace, [TileFace]))
-> [[TileFace]] -> [(TileFace, [TileFace])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TileFace]
gp -> ([TileFace] -> TileFace
makeLK [TileFace]
gp,[TileFace]
gp)) [[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)
makeLK :: [TileFace] -> TileFace
makeLK [TileFace
ld,TileFace
_,TileFace
lk] = (Vertex, Vertex, Vertex) -> TileFace
forall rep. rep -> HalfTile rep
LK(TileFace -> Vertex
originV TileFace
ld, TileFace -> Vertex
originV TileFace
lk, TileFace -> Vertex
wingV TileFace
lk)
makeLK [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]