-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Internal
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : [email protected]
-- Stability  : experimental
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module defines various internal utilities and data structures used
-- throughout the library, such as lists with fast concatenation. The API
-- is unstable and unsafe, and is exposed only for documentation.
-----------------------------------------------------------------------------
module Algebra.Graph.Internal (
    -- * Data structures
    List,

    -- * Graph traversal
    Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, foldr1Safe,
    maybeF,

    -- * Utilities
    cartesianProductWith, coerce00, coerce10, coerce20, coerce01, coerce11,
    coerce21
    ) where

import Data.Coerce
import Data.Foldable
import Data.IntSet (IntSet)
import Data.Semigroup (Endo (..))
import Data.Set (Set)

import qualified Data.IntSet as IntSet
import qualified Data.Set    as Set
import qualified GHC.Exts    as Exts

-- | An abstract list data type with /O(1)/ time concatenation (the current
-- implementation uses difference lists). Here @a@ is the type of list elements.
-- 'List' @a@ is a 'Monoid': 'mempty' corresponds to the empty list and two lists
-- can be concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Singleton
-- lists can be constructed using the function 'pure' from the 'Applicative'
-- instance. 'List' @a@ is also an instance of 'IsList', therefore you can use
-- list literals, e.g. @[1,4]@ @::@ 'List' @Int@ is the same as 'pure' @1@
-- 'Data.Semigroup.<>' 'pure' @4@; note that this requires the @OverloadedLists@
-- GHC extension. To extract plain Haskell lists you can use the 'toList'
-- function from the 'Foldable' instance.
newtype List a = List (Endo [a]) deriving (List a
[List a] -> List a
List a -> List a -> List a
forall {a}. Semigroup (List a)
forall a. List a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [List a] -> List a
forall a. List a -> List a -> List a
mconcat :: [List a] -> List a
$cmconcat :: forall a. [List a] -> List a
mappend :: List a -> List a -> List a
$cmappend :: forall a. List a -> List a -> List a
mempty :: List a
$cmempty :: forall a. List a
Monoid, NonEmpty (List a) -> List a
List a -> List a -> List a
forall b. Integral b => b -> List a -> List a
forall a. NonEmpty (List a) -> List a
forall a. List a -> List a -> List a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> List a -> List a
stimes :: forall b. Integral b => b -> List a -> List a
$cstimes :: forall a b. Integral b => b -> List a -> List a
sconcat :: NonEmpty (List a) -> List a
$csconcat :: forall a. NonEmpty (List a) -> List a
<> :: List a -> List a -> List a
$c<> :: forall a. List a -> List a -> List a
Semigroup)

instance Show a => Show (List a) where
    show :: List a -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Eq a => Eq (List a) where
    List a
x == :: List a -> List a -> Bool
== List a
y = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
x forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
y

instance Ord a => Ord (List a) where
    compare :: List a -> List a -> Ordering
compare List a
x List a
y = forall a. Ord a => a -> a -> Ordering
compare (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
x) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
y)

-- TODO: Add rewrite rules? fromList . toList == toList . fromList == id
instance Exts.IsList (List a) where
    type Item (List a) = a
    fromList :: [Item (List a)] -> List a
fromList        = forall a. Endo [a] -> List a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => a -> a -> a
(<>)
    toList :: List a -> [Item (List a)]
toList (List Endo [a]
x) = forall a. Endo a -> a -> a
appEndo Endo [a]
x []

instance Foldable List where
    foldMap :: forall m a. Monoid m => (a -> m) -> List a -> m
foldMap a -> m
f = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
Exts.toList
    toList :: forall a. List a -> [a]
toList    = forall l. IsList l => l -> [Item l]
Exts.toList

instance Functor List where
    fmap :: forall a b. (a -> b) -> List a -> List b
fmap a -> b
f = forall l. IsList l => [Item l] -> l
Exts.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Applicative List where
    pure :: forall a. a -> List a
pure    = forall a. Endo [a] -> List a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
    List (a -> b)
f <*> :: forall a b. List (a -> b) -> List a -> List b
<*> List a
x = forall l. IsList l => [Item l] -> l
Exts.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
x)

instance Monad List where
    return :: forall a. a -> List a
return  = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    List a
x >>= :: forall a b. List a -> (a -> List b) -> List b
>>= a -> List b
f = forall l. IsList l => [Item l] -> l
Exts.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> List b
f)

-- | The /focus/ of a graph expression is a flattened representation of the
-- subgraph under focus, its context, as well as the list of all encountered
-- vertices. See 'Algebra.Graph.removeEdge' for a use-case example.
data Focus a = Focus
    { forall a. Focus a -> Bool
ok :: Bool     -- ^ True if focus on the specified subgraph is obtained.
    , forall a. Focus a -> List a
is :: List a   -- ^ Inputs into the focused subgraph.
    , forall a. Focus a -> List a
os :: List a   -- ^ Outputs out of the focused subgraph.
    , forall a. Focus a -> List a
vs :: List a } -- ^ All vertices (leaves) of the graph expression.

-- | Focus on the empty graph.
emptyFocus :: Focus a
emptyFocus :: forall a. Focus a
emptyFocus = forall a. Bool -> List a -> List a -> List a -> Focus a
Focus Bool
False forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Focus on the graph with a single vertex, given a predicate indicating
-- whether the vertex is of interest.
vertexFocus :: (a -> Bool) -> a -> Focus a
vertexFocus :: forall a. (a -> Bool) -> a -> Focus a
vertexFocus a -> Bool
f a
x = forall a. Bool -> List a -> List a -> List a -> Focus a
Focus (a -> Bool
f a
x) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)

-- | Overlay two foci.
overlayFoci :: Focus a -> Focus a -> Focus a
overlayFoci :: forall a. Focus a -> Focus a -> Focus a
overlayFoci Focus a
x Focus a
y = forall a. Bool -> List a -> List a -> List a -> Focus a
Focus (forall a. Focus a -> Bool
ok Focus a
x Bool -> Bool -> Bool
|| forall a. Focus a -> Bool
ok Focus a
y) (forall a. Focus a -> List a
is Focus a
x forall a. Semigroup a => a -> a -> a
<> forall a. Focus a -> List a
is Focus a
y) (forall a. Focus a -> List a
os Focus a
x forall a. Semigroup a => a -> a -> a
<> forall a. Focus a -> List a
os Focus a
y) (forall a. Focus a -> List a
vs Focus a
x forall a. Semigroup a => a -> a -> a
<> forall a. Focus a -> List a
vs Focus a
y)

-- | Connect two foci.
connectFoci :: Focus a -> Focus a -> Focus a
connectFoci :: forall a. Focus a -> Focus a -> Focus a
connectFoci Focus a
x Focus a
y = forall a. Bool -> List a -> List a -> List a -> Focus a
Focus (forall a. Focus a -> Bool
ok Focus a
x Bool -> Bool -> Bool
|| forall a. Focus a -> Bool
ok Focus a
y) (List a
xs forall a. Semigroup a => a -> a -> a
<> forall a. Focus a -> List a
is Focus a
y) (forall a. Focus a -> List a
os Focus a
x forall a. Semigroup a => a -> a -> a
<> List a
ys) (forall a. Focus a -> List a
vs Focus a
x forall a. Semigroup a => a -> a -> a
<> forall a. Focus a -> List a
vs Focus a
y)
  where
    xs :: List a
xs = if forall a. Focus a -> Bool
ok Focus a
y then forall a. Focus a -> List a
vs Focus a
x else forall a. Focus a -> List a
is Focus a
x
    ys :: List a
ys = if forall a. Focus a -> Bool
ok Focus a
x then forall a. Focus a -> List a
vs Focus a
y else forall a. Focus a -> List a
os Focus a
y

-- | A safe version of 'foldr1'.
foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a
foldr1Safe :: forall a. (a -> a -> a) -> [a] -> Maybe a
foldr1Safe a -> a -> a
f = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b. (a -> b -> a) -> a -> Maybe b -> Maybe a
maybeF a -> a -> a
f) forall a. Maybe a
Nothing
{-# INLINE foldr1Safe #-}

-- | An auxiliary function that tries to apply a function to a base case and a
-- 'Maybe' value and returns 'Just' the result or 'Just' the base case.
maybeF :: (a -> b -> a) -> a -> Maybe b -> Maybe a
maybeF :: forall a b. (a -> b -> a) -> a -> Maybe b -> Maybe a
maybeF a -> b -> a
f a
x = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
x (a -> b -> a
f a
x)
{-# INLINE maybeF #-}

-- TODO: Can we implement this faster via 'Set.cartesianProduct'?
-- | Compute the Cartesian product of two sets, applying a function to each
-- resulting pair.
cartesianProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c
cartesianProductWith :: forall c a b. Ord c => (a -> b -> c) -> Set a -> Set b -> Set c
cartesianProductWith a -> b -> c
f Set a
x Set b
y =
    forall a. Ord a => [a] -> Set a
Set.fromList [ a -> b -> c
f a
a b
b | a
a <- forall a. Set a -> [a]
Set.toAscList Set a
x, b
b <- forall a. Set a -> [a]
Set.toAscList Set b
y ]

-- TODO: Get rid of this boilerplate.

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce00 :: Coercible f g => f x -> g x
coerce00 :: forall (f :: * -> *) (g :: * -> *) x. Coercible f g => f x -> g x
coerce00 = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce10 :: (Coercible a b, Coercible f g) => (a -> f x) -> (b -> g x)
coerce10 :: forall a b (f :: * -> *) (g :: * -> *) x.
(Coercible a b, Coercible f g) =>
(a -> f x) -> b -> g x
coerce10 = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce20 :: (Coercible a b, Coercible c d, Coercible f g)
         => (a -> c -> f x) -> (b -> d -> g x)
coerce20 :: forall a b c d (f :: * -> *) (g :: * -> *) x.
(Coercible a b, Coercible c d, Coercible f g) =>
(a -> c -> f x) -> b -> d -> g x
coerce20 = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce01 :: (Coercible a b, Coercible f g) => (f x -> a) -> (g x -> b)
coerce01 :: forall a b (f :: * -> *) (g :: * -> *) x.
(Coercible a b, Coercible f g) =>
(f x -> a) -> g x -> b
coerce01 = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce11 :: (Coercible a b, Coercible c d, Coercible f g)
         => (a -> f x -> c) -> (b -> g x -> d)
coerce11 :: forall a b c d (f :: * -> *) (g :: * -> *) x.
(Coercible a b, Coercible c d, Coercible f g) =>
(a -> f x -> c) -> b -> g x -> d
coerce11 = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Help GHC with type inference when direct use of 'coerce' does not compile.
coerce21 :: (Coercible a b, Coercible c d, Coercible p q, Coercible f g)
         => (a -> c -> f x -> p) -> (b -> d -> g x -> q)
coerce21 :: forall a b c d p q (f :: * -> *) (g :: * -> *) x.
(Coercible a b, Coercible c d, Coercible p q, Coercible f g) =>
(a -> c -> f x -> p) -> b -> d -> g x -> q
coerce21 = coerce :: forall a b. Coercible a b => a -> b
coerce