{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}

{-|
Module:      Boardgame.ColoredGraph
Description: A graph library specialized for boardgames. Colored graphs have
             colors, or values, on each vertex and each edge.

This module contains helper functions for games that can be modeled as graphs.

It contains a few functions for creating graphs of different shapes and with
different properties. 'hexHexGraph', 'paraHexGraph', 'rectOctGraph', and more.

It also contains a few functions that can automatically implement
'Boardgame.PositionalGame' for most cases. These are named after the function
they implement, prefixed with @coloredGraph@ and the addition of how the
implement them. For example 'coloredGraphGetVertexPosition' and
'coloredGraphSetBidirectedEdgePosition'.
-}
module Boardgame.ColoredGraph (
    ColoredGraph
  , ColoredGraphTransformer(..)
  , hexHexGraph
  , paraHexGraph
  , rectOctGraph
  , triHexGraph
  , completeGraph
  , mapValues
  , mapEdges
  , filterValues
  , filterEdges
  , filterG
  , components
  , anyConnections
  , edgePath
  , inARow
  , values
  , winningSetPaths
  , winningSetPaths'
  , coloredGraphVertexPositions
  , coloredGraphSetVertexPosition
  , coloredGraphGetVertexPosition
  , coloredGraphEdgePositions
  , coloredGraphGetEdgePosition
  , coloredGraphSetEdgePosition
  , coloredGraphSetBidirectedEdgePosition
) where

import Data.Map (Map, mapMaybeWithKey, filterWithKey)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.List ( find, intersect, (\\) )
import Data.Maybe ( fromJust, isJust, listToMaybe, mapMaybe )
import Data.Tree (Tree(..), foldTree)
import Control.Monad ((<=<))
import Data.Bifunctor ( bimap, Bifunctor (first, second) )
import Boardgame (Position(..))


-- | A Graph with colored vertices and edges. The key of the map is 'i', the

--   "coordinates". The value of the map is a tuple of vertices color 'a', and

--   a list of edges. The edges are tuples of edge color 'b' and

--   "target coordinate" 'i'.

type ColoredGraph i a b = Map i (a, Map i b)

type Coordinate = (Int, Int)

-- The six directions of neighbours on a hexagonal grid.

hexDirections :: [Coordinate]
hexDirections :: [Coordinate]
hexDirections =
  [ (Int
1, Int
0)
  , (Int
1, -Int
1)
  , (Int
0, -Int
1)
  , (-Int
1, Int
0)
  , (-Int
1, Int
1)
  , (Int
0, Int
1)
  ]

-- Returns the six neighboring coordinates of the given coordinate on a

-- hexagonal grid.

hexNeighbors :: Coordinate -> [Coordinate]
hexNeighbors :: Coordinate -> [Coordinate]
hexNeighbors (Int
i, Int
j) = (Int -> Int) -> (Int -> Int) -> Coordinate -> Coordinate
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) (Coordinate -> Coordinate) -> [Coordinate] -> [Coordinate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
hexDirections

-- The eight directions of neighbours on a square grid.

octoDirections :: [Coordinate]
octoDirections :: [Coordinate]
octoDirections =
  [ (Int
1, Int
0)
  , (Int
1, -Int
1)
  , (Int
0, -Int
1)
  , (-Int
1, -Int
1)
  , (-Int
1, Int
0)
  , (-Int
1, Int
1)
  , (Int
0, Int
1)
  , (Int
1, Int
1)
  ]

-- Returns the eight neighboring coordinates of the given coordinate on a

-- square grid.

octoNeighbors :: Coordinate -> [Coordinate]
octoNeighbors :: Coordinate -> [Coordinate]
octoNeighbors (Int
i, Int
j) = (Int -> Int) -> (Int -> Int) -> Coordinate -> Coordinate
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) (Coordinate -> Coordinate) -> [Coordinate] -> [Coordinate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
octoDirections




-- Maps over the individual values of a tuple.

mapBoth :: (a -> b) -> (a, a) -> (b, b)
mapBoth :: (a -> b) -> (a, a) -> (b, b)
mapBoth a -> b
f (a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)

-- Combines two tuples using the given function.

binaryOp :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
binaryOp :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
binaryOp a -> b -> c
op (a
x, a
y) (b
z, b
w) = (a -> b -> c
op a
x b
z, a -> b -> c
op a
y b
w)


hexHexGraphRing :: Int -> [Coordinate]
hexHexGraphRing :: Int -> [Coordinate]
hexHexGraphRing Int
base = [[Coordinate]] -> [Coordinate]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Int -> [Coordinate]
oneSide Int
k | Int
k <- [Int
0..Int
5]]
  where
    oneSide :: Int -> [Coordinate]
    oneSide :: Int -> [Coordinate]
oneSide Int
i = [(Int -> Int -> Int) -> Coordinate -> Coordinate -> Coordinate
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
binaryOp (\Int
z Int
w -> Int
baseInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
z Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) ([Coordinate]
hexDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i) ([Coordinate]
hexDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! ((Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
6)) | Int
k <- [Int
1..Int
base]]

-- Returns the distance between two hexagonal coordinates.

distance :: Coordinate -> Coordinate -> Int
distance :: Coordinate -> Coordinate -> Int
distance (Int
x, Int
y) (Int
i, Int
j) = (Int -> Int
forall a. Num a => a -> a
abs(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Num a => a -> a
abs(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Num a => a -> a
abs(Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

-- | Creates a hexagon shaped graph of hexagon vertices (each vertex has six

--   outgoing edges) with the given radius.

--

--   The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' is at

--   the center. The color of edges will also be a '(Int, Int)' tuple that

--   shows the "direction" of the edge.

hexHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int)
hexHexGraph :: Int -> ColoredGraph Coordinate Position Coordinate
hexHexGraph Int
radius = [(Coordinate, (Position, Map Coordinate Coordinate))]
-> ColoredGraph Coordinate Position Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((\Coordinate
z -> (Coordinate
z , (Position
Empty, [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Coordinate, Coordinate)] -> Map Coordinate Coordinate)
-> [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall a b. (a -> b) -> a -> b
$ ((Coordinate, Coordinate) -> Bool)
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
radius) (Int -> Bool)
-> ((Coordinate, Coordinate) -> Int)
-> (Coordinate, Coordinate)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinate -> Coordinate -> Int
distance (Int
0, Int
0) (Coordinate -> Int)
-> ((Coordinate, Coordinate) -> Coordinate)
-> (Coordinate, Coordinate)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinate, Coordinate) -> Coordinate
forall a b. (a, b) -> a
fst) ([(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)])
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a b. (a -> b) -> a -> b
$ (\Int
i -> (Coordinate -> [Coordinate]
hexNeighbors Coordinate
z [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i, [Coordinate]
hexDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i)) (Int -> (Coordinate, Coordinate))
-> [Int] -> [(Coordinate, Coordinate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
5]))) (Coordinate -> (Coordinate, (Position, Map Coordinate Coordinate)))
-> [Coordinate]
-> [(Coordinate, (Position, Map Coordinate Coordinate))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
nodes)
  where
    nodes :: [Coordinate]
    nodes :: [Coordinate]
nodes = (Int
0, Int
0) Coordinate -> [Coordinate] -> [Coordinate]
forall a. a -> [a] -> [a]
: (Int -> [Coordinate]) -> [Int] -> [Coordinate]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Coordinate]
hexHexGraphRing [Int
1..Int
radiusInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]





-- | Creates a parallelogram shaped graph of hexagon vertices (each vertex has

--   six outgoing edges) with the given side length.

--

--   The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' is at

--   the center. The color of edges will also be a '(Int, Int)' tuple that

--   shows the "direction" of the edge.

paraHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int)
paraHexGraph :: Int -> ColoredGraph Coordinate Position Coordinate
paraHexGraph Int
n = [(Coordinate, (Position, Map Coordinate Coordinate))]
-> ColoredGraph Coordinate Position Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((\Coordinate
z -> (Coordinate
z , (Position
Empty, [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Coordinate, Coordinate)] -> Map Coordinate Coordinate)
-> [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall a b. (a -> b) -> a -> b
$ ((Coordinate, Coordinate) -> Bool)
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((\(Int
i, Int
j) -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (Coordinate -> Bool)
-> ((Coordinate, Coordinate) -> Coordinate)
-> (Coordinate, Coordinate)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinate, Coordinate) -> Coordinate
forall a b. (a, b) -> a
fst) ([(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)])
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a b. (a -> b) -> a -> b
$ (\Int
i -> (Coordinate -> [Coordinate]
hexNeighbors Coordinate
z [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i, [Coordinate]
hexDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i)) (Int -> (Coordinate, Coordinate))
-> [Int] -> [(Coordinate, Coordinate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
5]))) (Coordinate -> (Coordinate, (Position, Map Coordinate Coordinate)))
-> [Coordinate]
-> [(Coordinate, (Position, Map Coordinate Coordinate))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
nodes)
  where
    nodes :: [Coordinate]
    nodes :: [Coordinate]
nodes = [(Int
i, Int
j) | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

-- | Creates a rectangular shaped graph of octagon vertices (each vertex has

--   eight outgoing edges) with the given width and height.

--

--   The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' the top

--   left vertex. The color of edges will also be a '(Int, Int)' tuple that

--   shows the "direction" of the edge.

rectOctGraph :: Int -> Int -> ColoredGraph (Int, Int) Position (Int, Int)
rectOctGraph :: Int -> Int -> ColoredGraph Coordinate Position Coordinate
rectOctGraph Int
m Int
n = [(Coordinate, (Position, Map Coordinate Coordinate))]
-> ColoredGraph Coordinate Position Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((\Coordinate
z -> (Coordinate
z , (Position
Empty, [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Coordinate, Coordinate)] -> Map Coordinate Coordinate)
-> [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall a b. (a -> b) -> a -> b
$ ((Coordinate, Coordinate) -> Bool)
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((\(Int
i, Int
j) -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (Coordinate -> Bool)
-> ((Coordinate, Coordinate) -> Coordinate)
-> (Coordinate, Coordinate)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinate, Coordinate) -> Coordinate
forall a b. (a, b) -> a
fst) ([(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)])
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a b. (a -> b) -> a -> b
$ (\Int
i -> (Coordinate -> [Coordinate]
octoNeighbors Coordinate
z [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i, [Coordinate]
octoDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i)) (Int -> (Coordinate, Coordinate))
-> [Int] -> [(Coordinate, Coordinate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
7]))) (Coordinate -> (Coordinate, (Position, Map Coordinate Coordinate)))
-> [Coordinate]
-> [(Coordinate, (Position, Map Coordinate Coordinate))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
nodes)
  where
    nodes :: [Coordinate]
    nodes :: [Coordinate]
nodes = [(Int
i, Int
j) | Int
i <- [Int
0..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

-- | Creates a triangular shaped graph of hexagon vertices (each vertex has

--   six outgoing edges) with the given side length.

--

--   The "coordinates" of the graph will be '(Int, Int)' where '(1, n-1)',

--   '(n-1, 1)' and '(n-1, n-1)' are the 3 corners. The color of edges will

--   also be a '(Int, Int)' tuple that shows the "direction" of the edge.

triHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int)
triHexGraph :: Int -> ColoredGraph Coordinate Position Coordinate
triHexGraph Int
n = [(Coordinate, (Position, Map Coordinate Coordinate))]
-> ColoredGraph Coordinate Position Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((\Coordinate
z -> (Coordinate
z, (Position
Empty, [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Coordinate, Coordinate)] -> Map Coordinate Coordinate)
-> [(Coordinate, Coordinate)] -> Map Coordinate Coordinate
forall a b. (a -> b) -> a -> b
$ ((Coordinate, Coordinate) -> Bool)
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((\(Int
i, Int
j) -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n) (Coordinate -> Bool)
-> ((Coordinate, Coordinate) -> Coordinate)
-> (Coordinate, Coordinate)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinate, Coordinate) -> Coordinate
forall a b. (a, b) -> a
fst) ([(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)])
-> [(Coordinate, Coordinate)] -> [(Coordinate, Coordinate)]
forall a b. (a -> b) -> a -> b
$ (\Int
i -> (Coordinate -> [Coordinate]
hexNeighbors Coordinate
z [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i, [Coordinate]
hexDirections [Coordinate] -> Int -> Coordinate
forall a. [a] -> Int -> a
!! Int
i)) (Int -> (Coordinate, Coordinate))
-> [Int] -> [(Coordinate, Coordinate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. Int
5]))) (Coordinate -> (Coordinate, (Position, Map Coordinate Coordinate)))
-> [Coordinate]
-> [(Coordinate, (Position, Map Coordinate Coordinate))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coordinate]
nodes)
  where
    nodes :: [Coordinate]
    nodes :: [Coordinate]
nodes = [(Int
i, Int
j) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n]

-- | Creates a complete graph with n vertices.

completeGraph :: Int -> ColoredGraph Int () ()
completeGraph :: Int -> ColoredGraph Int () ()
completeGraph Int
n = [(Int, ((), Map Int ()))] -> ColoredGraph Int () ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Int
i, ((), [(Int, ())] -> Map Int ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
j, ()) | Int
j <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j])) | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]







-- Returns the first value that is accepted by the predicate, or 'Nothing'.

firstJust :: (a -> Maybe b) -> [a] -> Maybe b
firstJust :: (a -> Maybe b) -> [a] -> Maybe b
firstJust a -> Maybe b
f = [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe ([b] -> Maybe b) -> ([a] -> [b]) -> [a] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f

-- Maps the vertices, and their outgoing edges with values, and collects the

-- 'Just' results.

mapMaybeG :: Ord i => ((a, Map i b) -> Maybe c) -> ColoredGraph i a b -> ColoredGraph i c b
mapMaybeG :: ((a, Map i b) -> Maybe c)
-> ColoredGraph i a b -> ColoredGraph i c b
mapMaybeG (a, Map i b) -> Maybe c
f ColoredGraph i a b
g = ((c, Map i b) -> (c, Map i b))
-> ColoredGraph i c b -> ColoredGraph i c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map i b -> Map i b) -> (c, Map i b) -> (c, Map i b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((i -> b -> Bool) -> Map i b -> Map i b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\i
k b
_ -> i -> ColoredGraph i c b -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member i
k ColoredGraph i c b
g'))) ColoredGraph i c b
g'
  where
    g' :: ColoredGraph i c b
g' = ((a, Map i b) -> Maybe (c, Map i b))
-> ColoredGraph i a b -> ColoredGraph i c b
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (\(a
a, Map i b
xs) -> (, Map i b
xs) (c -> (c, Map i b)) -> Maybe c -> Maybe (c, Map i b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, Map i b) -> Maybe c
f (a
a, Map i b
xs)) ColoredGraph i a b
g

-- | Filters out any vertices whose value, and their outgoing edges with

--   values, is not accepted by the predicate.

filterG :: Ord i => ((a, Map i b) -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterG :: ((a, Map i b) -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterG (a, Map i b) -> Bool
pred = ((a, Map i b) -> Maybe a)
-> ColoredGraph i a b -> ColoredGraph i a b
forall i a b c.
Ord i =>
((a, Map i b) -> Maybe c)
-> ColoredGraph i a b -> ColoredGraph i c b
mapMaybeG (\(a
z, Map i b
w) -> if (a, Map i b) -> Bool
pred (a
z, Map i b
w) then a -> Maybe a
forall a. a -> Maybe a
Just a
z else Maybe a
forall a. Maybe a
Nothing)

-- | Filters out any vertices whose value is not accepted by the predicate.

filterValues :: Ord i => (a -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterValues :: (a -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterValues a -> Bool
pred = ((a, Map i b) -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
forall i a b.
Ord i =>
((a, Map i b) -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterG (((a, Map i b) -> Bool)
 -> ColoredGraph i a b -> ColoredGraph i a b)
-> ((a, Map i b) -> Bool)
-> ColoredGraph i a b
-> ColoredGraph i a b
forall a b. (a -> b) -> a -> b
$ a -> Bool
pred (a -> Bool) -> ((a, Map i b) -> a) -> (a, Map i b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Map i b) -> a
forall a b. (a, b) -> a
fst

-- | Maps the values of vertices with the given function.

mapValues :: Ord i => (a -> c) -> ColoredGraph i a b -> ColoredGraph i c b
mapValues :: (a -> c) -> ColoredGraph i a b -> ColoredGraph i c b
mapValues = ((a, Map i b) -> (c, Map i b))
-> ColoredGraph i a b -> ColoredGraph i c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Map i b) -> (c, Map i b))
 -> ColoredGraph i a b -> ColoredGraph i c b)
-> ((a -> c) -> (a, Map i b) -> (c, Map i b))
-> (a -> c)
-> ColoredGraph i a b
-> ColoredGraph i c b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> c) -> (a, Map i b) -> (c, Map i b)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first

-- | Maps the values of edges with the given function.

mapEdges :: Ord i => (b -> c) -> ColoredGraph i a b -> ColoredGraph i a c
mapEdges :: (b -> c) -> ColoredGraph i a b -> ColoredGraph i a c
mapEdges = ((a, Map i b) -> (a, Map i c))
-> ColoredGraph i a b -> ColoredGraph i a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Map i b) -> (a, Map i c))
 -> ColoredGraph i a b -> ColoredGraph i a c)
-> ((b -> c) -> (a, Map i b) -> (a, Map i c))
-> (b -> c)
-> ColoredGraph i a b
-> ColoredGraph i a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map i b -> Map i c) -> (a, Map i b) -> (a, Map i c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Map i b -> Map i c) -> (a, Map i b) -> (a, Map i c))
-> ((b -> c) -> Map i b -> Map i c)
-> (b -> c)
-> (a, Map i b)
-> (a, Map i c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> c) -> Map i b -> Map i c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- Returns a list of "coordinates" for vertices whose value, and their outgoing

-- edges with values, are accepted by the predicate.

nodesPred :: (a -> Map i b -> Bool) -> ColoredGraph i a b -> [i]
nodesPred :: (a -> Map i b -> Bool) -> ColoredGraph i a b -> [i]
nodesPred a -> Map i b -> Bool
pred ColoredGraph i a b
g = (i, (a, Map i b)) -> i
forall a b. (a, b) -> a
fst ((i, (a, Map i b)) -> i) -> [(i, (a, Map i b))] -> [i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((i, (a, Map i b)) -> Bool)
-> [(i, (a, Map i b))] -> [(i, (a, Map i b))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> Map i b -> Bool) -> (a, Map i b) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Map i b -> Bool
pred ((a, Map i b) -> Bool)
-> ((i, (a, Map i b)) -> (a, Map i b)) -> (i, (a, Map i b)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i, (a, Map i b)) -> (a, Map i b)
forall a b. (a, b) -> b
snd) (ColoredGraph i a b -> [(i, (a, Map i b))]
forall k a. Map k a -> [(k, a)]
Map.toList ColoredGraph i a b
g)

-- | Filters out any edges whose value is not accepted by the predicate.

filterEdges :: (b -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterEdges :: (b -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterEdges b -> Bool
pred = ((a, Map i b) -> (a, Map i b))
-> ColoredGraph i a b -> ColoredGraph i a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Map i b) -> (a, Map i b))
 -> ColoredGraph i a b -> ColoredGraph i a b)
-> ((a, Map i b) -> (a, Map i b))
-> ColoredGraph i a b
-> ColoredGraph i a b
forall a b. (a -> b) -> a -> b
$ (Map i b -> Map i b) -> (a, Map i b) -> (a, Map i b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Map i b -> Map i b) -> (a, Map i b) -> (a, Map i b))
-> (Map i b -> Map i b) -> (a, Map i b) -> (a, Map i b)
forall a b. (a -> b) -> a -> b
$ (b -> Bool) -> Map i b -> Map i b
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter b -> Bool
pred

-- Returns a path from i to j, including what edge value to take.

path :: Ord i => ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path :: ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path = Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
forall i a b.
Ord i =>
Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path' Set i
forall a. Set a
Set.empty

-- Returns a path from i to j, including what edge value to take. With a set of

-- already visited "coordinates".

path' :: Ord i => Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path' :: Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path' Set i
s ColoredGraph i a b
g i
i i
j
  | i
i i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
j = [(b, i)] -> Maybe [(b, i)]
forall a. a -> Maybe a
Just []
  | Bool
otherwise = ((i, b) -> Maybe [(b, i)]) -> [(i, b)] -> Maybe [(b, i)]
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust (\(i
k, b
d) -> ((b
d, i
k)(b, i) -> [(b, i)] -> [(b, i)]
forall a. a -> [a] -> [a]
:) ([(b, i)] -> [(b, i)]) -> Maybe [(b, i)] -> Maybe [(b, i)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
forall i a b.
Ord i =>
Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)]
path' Set i
s' ColoredGraph i a b
g i
k i
j) ([(i, b)] -> Maybe [(b, i)]) -> [(i, b)] -> Maybe [(b, i)]
forall a b. (a -> b) -> a -> b
$ ((i, b) -> Bool) -> [(i, b)] -> [(i, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(i
k, b
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ i
k i -> Set i -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set i
s') [(i, b)]
neighbours
  where
    neighbours :: [(i, b)]
neighbours = Map i b -> [(i, b)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map i b -> [(i, b)]) -> Map i b -> [(i, b)]
forall a b. (a -> b) -> a -> b
$ (a, Map i b) -> Map i b
forall a b. (a, b) -> b
snd ((a, Map i b) -> Map i b) -> (a, Map i b) -> Map i b
forall a b. (a -> b) -> a -> b
$ ColoredGraph i a b
g ColoredGraph i a b -> i -> (a, Map i b)
forall k a. Ord k => Map k a -> k -> a
Map.! i
i
    s' :: Set i
s' = i -> Set i -> Set i
forall a. Ord a => a -> Set a -> Set a
Set.insert i
i Set i
s


-- | A list of all vertices grouped by connected components.

components :: (Eq i, Ord i) => ColoredGraph i a b -> [[i]]
components :: ColoredGraph i a b -> [[i]]
components = [[i]] -> ColoredGraph i a b -> [[i]]
forall i a b. (Eq i, Ord i) => [[i]] -> ColoredGraph i a b -> [[i]]
components' []
  where
    components' :: (Eq i, Ord i) => [[i]] -> ColoredGraph i a b -> [[i]]
    components' :: [[i]] -> ColoredGraph i a b -> [[i]]
components' [[i]]
state  ColoredGraph i a b
g = case (i -> Bool) -> [i] -> Maybe i
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\i
k -> ([i] -> Bool) -> [[i]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (i -> [i] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem i
k) [[i]]
state) (ColoredGraph i a b -> [i]
forall k a. Map k a -> [k]
Map.keys ColoredGraph i a b
g) of
      Just i
i -> [[i]] -> ColoredGraph i a b -> [[i]]
forall i a b. (Eq i, Ord i) => [[i]] -> ColoredGraph i a b -> [[i]]
components' (ColoredGraph i a b -> i -> [i]
forall i a b. Ord i => ColoredGraph i a b -> i -> [i]
component  ColoredGraph i a b
g i
i [i] -> [[i]] -> [[i]]
forall a. a -> [a] -> [a]
: [[i]]
state)  ColoredGraph i a b
g
      Maybe i
Nothing -> [[i]]
state


-- List all the connected nodes starting from one node, also known as a connected component.

component :: Ord i => ColoredGraph i a b -> i -> [i]
component :: ColoredGraph i a b -> i -> [i]
component  ColoredGraph i a b
g = ([i], Set i) -> [i]
forall a b. (a, b) -> a
fst (([i], Set i) -> [i]) -> (i -> ([i], Set i)) -> i -> [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set i -> ColoredGraph i a b -> i -> ([i], Set i)
forall i a b.
Ord i =>
Set i -> ColoredGraph i a b -> i -> ([i], Set i)
component' Set i
forall a. Set a
Set.empty  ColoredGraph i a b
g
  where
    component' :: Ord i => Set i -> ColoredGraph i a b -> i -> ([i], Set i)
    component' :: Set i -> ColoredGraph i a b -> i -> ([i], Set i)
component' Set i
inputState  ColoredGraph i a b
g i
i = (i
i i -> [i] -> [i]
forall a. a -> [a] -> [a]
: [i]
xs, Set i
newState)
      where
        neighbours :: [(i, b)]
neighbours = Map i b -> [(i, b)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map i b -> [(i, b)]) -> Map i b -> [(i, b)]
forall a b. (a -> b) -> a -> b
$ (a, Map i b) -> Map i b
forall a b. (a, b) -> b
snd ((a, Map i b) -> Map i b) -> (a, Map i b) -> Map i b
forall a b. (a -> b) -> a -> b
$ ColoredGraph i a b
g ColoredGraph i a b -> i -> (a, Map i b)
forall k a. Ord k => Map k a -> k -> a
Map.! i
i
        ([i]
xs, Set i
newState) = (([i], Set i) -> i -> ([i], Set i))
-> ([i], Set i) -> [i] -> ([i], Set i)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([i], Set i) -> i -> ([i], Set i)
tmp ([], i -> Set i -> Set i
forall a. Ord a => a -> Set a -> Set a
Set.insert i
i Set i
inputState) ((i, b) -> i
forall a b. (a, b) -> a
fst ((i, b) -> i) -> [(i, b)] -> [i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(i, b)]
neighbours)

        tmp :: ([i], Set i) -> i -> ([i], Set i)
tmp ([i]
ks, Set i
state) i
k
          | i
k i -> Set i -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set i
state = ([i]
ks, Set i
state)
          | Bool
otherwise = let ([i]
x, Set i
y) = Set i -> ColoredGraph i a b -> i -> ([i], Set i)
forall i a b.
Ord i =>
Set i -> ColoredGraph i a b -> i -> ([i], Set i)
component' Set i
state  ColoredGraph i a b
g i
k in ([i]
ks [i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++ [i]
x, Set i
y)

-- | Returns a list of vertex values from the given graph.

values :: ColoredGraph i a b -> [a]
values :: ColoredGraph i a b -> [a]
values = ((a, Map i b) -> a) -> [(a, Map i b)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Map i b) -> a
forall a b. (a, b) -> a
fst ([(a, Map i b)] -> [a])
-> (ColoredGraph i a b -> [(a, Map i b)])
-> ColoredGraph i a b
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColoredGraph i a b -> [(a, Map i b)]
forall k a. Map k a -> [a]
Map.elems

-- | Returns a graph formed from a subset of vertices and

--   all edges connecting those vertices in the original graph.

inducedSubgraph :: Eq i => ColoredGraph i a b -> [i] -> ColoredGraph i a b
inducedSubgraph :: ColoredGraph i a b -> [i] -> ColoredGraph i a b
inducedSubgraph ColoredGraph i a b
g [i]
nodes = (i -> (a, Map i b) -> Maybe (a, Map i b))
-> ColoredGraph i a b -> ColoredGraph i a b
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
mapMaybeWithKey i -> (a, Map i b) -> Maybe (a, Map i b)
forall a b. i -> (a, Map i b) -> Maybe (a, Map i b)
tmp ColoredGraph i a b
g
  where
    tmp :: i -> (a, Map i b) -> Maybe (a, Map i b)
tmp i
i (a
a, Map i b
xs) = if i
i i -> [i] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [i]
nodes
      then (a, Map i b) -> Maybe (a, Map i b)
forall a. a -> Maybe a
Just (a
a, (i -> b -> Bool) -> Map i b -> Map i b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey (Bool -> b -> Bool
forall a b. a -> b -> a
const (Bool -> b -> Bool) -> (i -> Bool) -> i -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> [i] -> Bool) -> [i] -> i -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip i -> [i] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [i]
nodes) Map i b
xs)
      else Maybe (a, Map i b)
forall a. Maybe a
Nothing

-- | For every component of G, count how many groups of nodes they overlap with

--   and check if the predicate holds on the count. If it matches on any

--   component then return that component. We also try to return only the parts

--   of the component that are necessary for our predicate to hold.

anyConnections :: Ord i => (Int -> Bool) -> [[i]] -> ColoredGraph i a b -> Maybe [i]
anyConnections :: (Int -> Bool) -> [[i]] -> ColoredGraph i a b -> Maybe [i]
anyConnections Int -> Bool
pred [[i]]
groups = ([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
forall i a b.
Ord i =>
([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
findComponent [i] -> Bool
cond
  where
    cond :: [i] -> Bool
cond [i]
z = Int -> Bool
pred (Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ [[i]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[i]] -> Int) -> [[i]] -> Int
forall a b. (a -> b) -> a -> b
$ ([i] -> Bool) -> [[i]] -> [[i]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([i] -> Bool) -> [i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null ([i] -> Bool) -> ([i] -> [i]) -> [i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> [i] -> [i]
forall a. Eq a => [a] -> [a] -> [a]
intersect [i]
z) [[i]]
groups

-- | Is there a component along edges with value `dir` that has a length

--   accepted by `pred`? If there is we return a subset of that component that

--   matches the predicate

inARow :: (Ord i, Eq b) => (Int -> Bool) -> b -> ColoredGraph i a b -> Maybe [i]
inARow :: (Int -> Bool) -> b -> ColoredGraph i a b -> Maybe [i]
inARow Int -> Bool
pred b
dir = ([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
forall i a b.
Ord i =>
([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
findComponent (Int -> Bool
pred (Int -> Bool) -> ([i] -> Int) -> [i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (ColoredGraph i a b -> Maybe [i])
-> (ColoredGraph i a b -> ColoredGraph i a b)
-> ColoredGraph i a b
-> Maybe [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
forall b i a.
(b -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b
filterEdges (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
dir)

-- | Try to find a component of the graph that matches the predicate.

--   The component that is returned is minimized using a greedy

--   search while still matching our predicate.

findComponent :: Ord i => ([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
findComponent :: ([i] -> Bool) -> ColoredGraph i a b -> Maybe [i]
findComponent [i] -> Bool
pred ColoredGraph i a b
g = [i] -> [i]
minimizeComponent ([i] -> [i]) -> Maybe [i] -> Maybe [i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([i] -> Bool) -> [[i]] -> Maybe [i]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find [i] -> Bool
pred (ColoredGraph i a b -> [[i]]
forall i a b. (Eq i, Ord i) => ColoredGraph i a b -> [[i]]
components ColoredGraph i a b
g)
  where
    -- Remove elements from xs while the condition holds.

    minimizeComponent :: [i] -> [i]
minimizeComponent [i]
xs = [i] -> ([i] -> [i]) -> Maybe [i] -> [i]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [i]
xs [i] -> [i]
minimizeComponent (Maybe [i] -> [i]) -> Maybe [i] -> [i]
forall a b. (a -> b) -> a -> b
$ ([i] -> Bool) -> [[i]] -> Maybe [i]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find [i] -> Bool
cond ([[i]] -> Maybe [i]) -> [[i]] -> Maybe [i]
forall a b. (a -> b) -> a -> b
$ [i] -> [[i]]
forall i. [i] -> [[i]]
oneRemoved [i]
xs
      where
        -- The condition we want to hold is our

        -- predicate and that we only have one component.

        cond :: [i] -> Bool
cond [i]
z = [i] -> Bool
pred [i]
z Bool -> Bool -> Bool
&& Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [[i]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ColoredGraph i a b -> [[i]]
forall i a b. (Eq i, Ord i) => ColoredGraph i a b -> [[i]]
components (ColoredGraph i a b -> [[i]]) -> ColoredGraph i a b -> [[i]]
forall a b. (a -> b) -> a -> b
$ ColoredGraph i a b -> [i] -> ColoredGraph i a b
forall i a b.
Eq i =>
ColoredGraph i a b -> [i] -> ColoredGraph i a b
inducedSubgraph ColoredGraph i a b
g [i]
z)
        -- Lists where we have removed one element from the input.

        oneRemoved :: [i] -> [[i]]
        oneRemoved :: [i] -> [[i]]
oneRemoved [] = []
        oneRemoved [i
x] = [[]]
        oneRemoved (i
x:[i]
xs) = [i]
xs [i] -> [[i]] -> [[i]]
forall a. a -> [a] -> [a]
: ((i
xi -> [i] -> [i]
forall a. a -> [a] -> [a]
:) ([i] -> [i]) -> [[i]] -> [[i]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [i] -> [[i]]
forall i. [i] -> [[i]]
oneRemoved [i]
xs)

-- | Returns the winning sets representing paths from one set of nodes to

--   another on a graph.

winningSetPaths :: Ord i => ColoredGraph i a b -> [i] -> [i] -> [[i]]
winningSetPaths :: ColoredGraph i a b -> [i] -> [i] -> [[i]]
winningSetPaths ColoredGraph i a b
g [i]
is [i]
js = [[[i]]] -> [[i]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [((Bool, i) -> [[[i]]] -> [[i]]) -> Tree (Bool, i) -> [[i]]
forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (\(Bool
isLeaf, i
z) [[[i]]]
xs -> if Bool
isLeaf then [[i
z]] else ([[i]] -> [[i]]) -> [[[i]]] -> [[i]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([i] -> [i]) -> [[i]] -> [[i]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i
zi -> [i] -> [i]
forall a. a -> [a] -> [a]
:)) [[[i]]]
xs) (Tree (Bool, i) -> [[i]]) -> Tree (Bool, i) -> [[i]]
forall a b. (a -> b) -> a -> b
$ ColoredGraph i a b
-> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
forall i a b.
Ord i =>
ColoredGraph i a b
-> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
winningSetPaths' ColoredGraph i a b
g Map i Bool
start i
i Map i Bool
goal | i
i <- [i]
is]
  where
    allTrue :: Map i Bool
allTrue = Bool
True Bool -> ColoredGraph i a b -> Map i Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ColoredGraph i a b
g
    start :: Map i Bool
start = (i -> Map i Bool -> Map i Bool) -> Map i Bool -> [i] -> Map i Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (i -> Bool -> Map i Bool -> Map i Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
`Map.insert` Bool
False) Map i Bool
allTrue [i]
is

    allFalse :: Map i Bool
allFalse = Bool
False Bool -> ColoredGraph i a b -> Map i Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ColoredGraph i a b
g
    goal :: Map i Bool
goal = (i -> Map i Bool -> Map i Bool) -> Map i Bool -> [i] -> Map i Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (i -> Bool -> Map i Bool -> Map i Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
`Map.insert` Bool
True) Map i Bool
allFalse [i]
js

-- | Returns a tree representing all paths from a starting node too any node in

--   the goal. The paths do not "touch" themselves and they only use a set of

--   allowed nodes. That they don't touch means that we generate exactly the

--   minimum set of winning sets that cover reaching from our starting node to

--   the goal.

winningSetPaths' :: Ord i => ColoredGraph i a b -> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
winningSetPaths' :: ColoredGraph i a b
-> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
winningSetPaths' ColoredGraph i a b
g Map i Bool
allowed i
i Map i Bool
goal = (Bool, i) -> Forest (Bool, i) -> Tree (Bool, i)
forall a. a -> Forest a -> Tree a
Node (Bool
False, i
i) (Forest (Bool, i) -> Tree (Bool, i))
-> Forest (Bool, i) -> Tree (Bool, i)
forall a b. (a -> b) -> a -> b
$ (\i
k -> if Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ i -> Map i Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
k Map i Bool
goal then (Bool, i) -> Forest (Bool, i) -> Tree (Bool, i)
forall a. a -> Forest a -> Tree a
Node (Bool
True, i
k) [] else ColoredGraph i a b
-> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
forall i a b.
Ord i =>
ColoredGraph i a b
-> Map i Bool -> i -> Map i Bool -> Tree (Bool, i)
winningSetPaths' ColoredGraph i a b
g Map i Bool
allowed' i
k Map i Bool
goal) (i -> Tree (Bool, i)) -> [i] -> Forest (Bool, i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [i]
neighbourIndices
  where
    neighbourIndices :: [i]
neighbourIndices = (i -> Bool) -> [i] -> [i]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool) -> (i -> Maybe Bool) -> i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> Map i Bool -> Maybe Bool) -> Map i Bool -> i -> Maybe Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip i -> Map i Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map i Bool
allowed) ([i] -> [i]) -> [i] -> [i]
forall a b. (a -> b) -> a -> b
$ Map i b -> [i]
forall k a. Map k a -> [k]
Map.keys (Map i b -> [i]) -> Map i b -> [i]
forall a b. (a -> b) -> a -> b
$ (a, Map i b) -> Map i b
forall a b. (a, b) -> b
snd ((a, Map i b) -> Map i b) -> (a, Map i b) -> Map i b
forall a b. (a -> b) -> a -> b
$ Maybe (a, Map i b) -> (a, Map i b)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (a, Map i b) -> (a, Map i b))
-> Maybe (a, Map i b) -> (a, Map i b)
forall a b. (a -> b) -> a -> b
$ i -> ColoredGraph i a b -> Maybe (a, Map i b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
i ColoredGraph i a b
g
    allowed' :: Map i Bool
allowed' = (i -> Map i Bool -> Map i Bool) -> Map i Bool -> [i] -> Map i Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (i -> Bool -> Map i Bool -> Map i Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
`Map.insert` Bool
False) Map i Bool
allowed [i]
neighbourIndices

-- | Takes a path of vertices and returns a path of edges. Where the edges are

--   pairs of from and to vertices.

edgePath :: [a] -> [(a, a)]
edgePath :: [a] -> [(a, a)]
edgePath [a]
a = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
a ([a] -> [a]
forall a. [a] -> [a]
tail [a]
a)

-- | A standard implementation of 'MyLib.positions' for games

--   with an underlying 'ColoredGraph' played on the vertices.

--

--   For 'ColoredGraph's, this is a synonym of 'values'.

coloredGraphVertexPositions :: (ColoredGraphTransformer i a b g, Ord i) => g -> [a]
coloredGraphVertexPositions :: g -> [a]
coloredGraphVertexPositions = ColoredGraph i a b -> [a]
forall i a b. ColoredGraph i a b -> [a]
values (ColoredGraph i a b -> [a])
-> (g -> ColoredGraph i a b) -> g -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g -> ColoredGraph i a b
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph

-- | A standard implementation of 'MyLib.getPosition' for games

--   with an underlying 'ColoredGraph' played on the vertices.

coloredGraphGetVertexPosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> i -> Maybe a
coloredGraphGetVertexPosition :: g -> i -> Maybe a
coloredGraphGetVertexPosition g
g i
i = (a, Map i b) -> a
forall a b. (a, b) -> a
fst ((a, Map i b) -> a) -> Maybe (a, Map i b) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> Map i (a, Map i b) -> Maybe (a, Map i b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
i (g -> Map i (a, Map i b)
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph g
g)

-- | A standard implementation of 'MyLib.setPosition' for games

--   with an underlying 'ColoredGraph' played on the vertices.

coloredGraphSetVertexPosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> i -> a -> Maybe g
coloredGraphSetVertexPosition :: g -> i -> a -> Maybe g
coloredGraphSetVertexPosition g
g i
i a
p = if i -> Map i (a, Map i b) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member i
i Map i (a, Map i b)
c
    then g -> Maybe g
forall a. a -> Maybe a
Just (g -> Maybe g) -> g -> Maybe g
forall a b. (a -> b) -> a -> b
$ g -> Map i (a, Map i b) -> g
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b -> g
fromColoredGraph g
g (Map i (a, Map i b) -> g) -> Map i (a, Map i b) -> g
forall a b. (a -> b) -> a -> b
$ ((a, Map i b) -> (a, Map i b))
-> i -> Map i (a, Map i b) -> Map i (a, Map i b)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(a
_, Map i b
xs) -> (a
p, Map i b
xs)) i
i Map i (a, Map i b)
c
    else Maybe g
forall a. Maybe a
Nothing
  where
    c :: Map i (a, Map i b)
c = g -> Map i (a, Map i b)
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph g
g

-- | A standard implementation of 'MyLib.positions' for games

--   with an underlying 'ColoredGraph' played on the edges.

coloredGraphEdgePositions :: (ColoredGraphTransformer i a b g, Ord i) => g -> [b]
coloredGraphEdgePositions :: g -> [b]
coloredGraphEdgePositions = Map i b -> [b]
forall k a. Map k a -> [a]
Map.elems (Map i b -> [b])
-> ((a, Map i b) -> Map i b) -> (a, Map i b) -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Map i b) -> Map i b
forall a b. (a, b) -> b
snd ((a, Map i b) -> [b]) -> (g -> [(a, Map i b)]) -> g -> [b]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Map i (a, Map i b) -> [(a, Map i b)]
forall k a. Map k a -> [a]
Map.elems (Map i (a, Map i b) -> [(a, Map i b)])
-> (g -> Map i (a, Map i b)) -> g -> [(a, Map i b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g -> Map i (a, Map i b)
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph

-- | A standard implementation of 'MyLib.getPosition' for games

--   with an underlying 'ColoredGraph' played on the edges.

coloredGraphGetEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> Maybe b
coloredGraphGetEdgePosition :: g -> (i, i) -> Maybe b
coloredGraphGetEdgePosition g
g (i
from, i
to) = i -> Map i (a, Map i b) -> Maybe (a, Map i b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
from (g -> Map i (a, Map i b)
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph g
g) Maybe (a, Map i b) -> ((a, Map i b) -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (i -> Map i b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
to (Map i b -> Maybe b)
-> ((a, Map i b) -> Map i b) -> (a, Map i b) -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Map i b) -> Map i b
forall a b. (a, b) -> b
snd)

-- | A standard implementation of 'MyLib.setPosition' for games

--   with an underlying 'ColoredGraph' played on the vertices.

coloredGraphSetEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> b -> Maybe g
coloredGraphSetEdgePosition :: g -> (i, i) -> b -> Maybe g
coloredGraphSetEdgePosition g
g (i
from, i
to) b
p = i -> Map i (a, Map i b) -> Maybe (a, Map i b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup i
from Map i (a, Map i b)
c Maybe (a, Map i b) -> ((a, Map i b) -> Maybe g) -> Maybe g
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \(a
a, Map i b
edges) -> if i -> Map i b -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member i
to Map i b
edges
      then g -> Maybe g
forall a. a -> Maybe a
Just (g -> Maybe g) -> g -> Maybe g
forall a b. (a -> b) -> a -> b
$ g -> Map i (a, Map i b) -> g
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b -> g
fromColoredGraph g
g (Map i (a, Map i b) -> g) -> Map i (a, Map i b) -> g
forall a b. (a -> b) -> a -> b
$ i -> (a, Map i b) -> Map i (a, Map i b) -> Map i (a, Map i b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert i
from (a
a, i -> b -> Map i b -> Map i b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert i
to b
p Map i b
edges) Map i (a, Map i b)
c
      else Maybe g
forall a. Maybe a
Nothing
  where
    c :: Map i (a, Map i b)
c = g -> Map i (a, Map i b)
forall i a b g.
ColoredGraphTransformer i a b g =>
g -> ColoredGraph i a b
toColoredGraph g
g

-- | Like 'coloredGraphSetEdgePosition' but sets the value to the edges in both

--   directions.

coloredGraphSetBidirectedEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> b -> Maybe g
coloredGraphSetBidirectedEdgePosition :: g -> (i, i) -> b -> Maybe g
coloredGraphSetBidirectedEdgePosition g
c (i
from, i
to) b
p = g -> (i, i) -> b -> Maybe g
forall i a b g.
(ColoredGraphTransformer i a b g, Ord i) =>
g -> (i, i) -> b -> Maybe g
coloredGraphSetEdgePosition g
c (i
from, i
to) b
p Maybe g -> (g -> Maybe g) -> Maybe g
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \g
c' -> g -> (i, i) -> b -> Maybe g
forall i a b g.
(ColoredGraphTransformer i a b g, Ord i) =>
g -> (i, i) -> b -> Maybe g
coloredGraphSetEdgePosition g
c' (i
to, i
from) b
p

-- | A utility class for transforming to and from 'ColoredGraph'.

--

--   New-types of 'ColoredGraph' can derive this using the

--   'GeneralizedNewtypeDeriving' language extension.

class ColoredGraphTransformer i a b g | g -> i, g -> a, g -> b where
  -- | "Extracts" the 'ColoredGraph' from a container type.

  toColoredGraph :: g -> ColoredGraph i a b
  -- | "Inserts" the 'ColoredGraph' into an already existing container type.

  fromColoredGraph :: g -> ColoredGraph i a b -> g

instance ColoredGraphTransformer i a b (ColoredGraph i a b) where
  toColoredGraph :: ColoredGraph i a b -> ColoredGraph i a b
toColoredGraph ColoredGraph i a b
c = ColoredGraph i a b
c
  fromColoredGraph :: ColoredGraph i a b -> ColoredGraph i a b -> ColoredGraph i a b
fromColoredGraph ColoredGraph i a b
_ = ColoredGraph i a b -> ColoredGraph i a b
forall a. a -> a
id