{-# LANGUAGE DeriveFunctor, OverloadedLists #-}
module Algebra.Graph.Label (
Semiring (..), zero, (<+>), StarSemiring (..), Dioid,
NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite,
Distance, distance, getDistance, Capacity, capacity, getCapacity,
Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum,
Path, Label, isZero, RegularExpression,
Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath
) where
import Control.Applicative
import Control.Monad
import Data.Coerce
import Data.Maybe
import Data.Monoid (Any (..), Monoid (..), Sum (..))
import Data.Semigroup (Max (..), Min (..), Semigroup (..))
import Data.Set (Set)
import GHC.Exts (IsList (..))
import Algebra.Graph.Internal
import qualified Data.Set as Set
class (Monoid a, Semigroup a) => Semiring a where
one :: a
(<.>) :: a -> a -> a
class Semiring a => StarSemiring a where
star :: a -> a
class Semiring a => Dioid a
zero :: Monoid a => a
zero = mempty
(<+>) :: Semigroup a => a -> a -> a
(<+>) = (<>)
infixr 6 <+>
infixr 7 <.>
instance Semiring Any where
one = Any True
Any x <.> Any y = Any (x && y)
instance StarSemiring Any where
star _ = Any True
instance Dioid Any
newtype NonNegative a = NonNegative (Extended a)
deriving (Applicative, Eq, Functor, Ord, Monad)
instance (Num a, Show a) => Show (NonNegative a) where
show (NonNegative Infinite ) = "infinite"
show (NonNegative (Finite x)) = show x
instance Num a => Bounded (NonNegative a) where
minBound = unsafeFinite 0
maxBound = infinite
instance (Num a, Ord a) => Num (NonNegative a) where
fromInteger x | f < 0 = error "NonNegative values cannot be negative"
| otherwise = unsafeFinite f
where
f = fromInteger x
(+) = coerce ((+) :: Extended a -> Extended a -> Extended a)
(*) = coerce ((*) :: Extended a -> Extended a -> Extended a)
negate _ = error "NonNegative values cannot be negated"
signum (NonNegative Infinite) = 1
signum x = signum <$> x
abs = id
finite :: (Num a, Ord a) => a -> Maybe (NonNegative a)
finite x | x < 0 = Nothing
| otherwise = Just (unsafeFinite x)
finiteWord :: Word -> NonNegative Word
finiteWord = unsafeFinite
unsafeFinite :: a -> NonNegative a
unsafeFinite = NonNegative . Finite
infinite :: NonNegative a
infinite = NonNegative Infinite
getFinite :: NonNegative a -> Maybe a
getFinite (NonNegative x) = fromExtended x
newtype Capacity a = Capacity (Max (NonNegative a))
deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)
instance Show a => Show (Capacity a) where
show (Capacity (Max (NonNegative (Finite x)))) = show x
show _ = "capacity infinite"
instance (Num a, Ord a) => Semiring (Capacity a) where
one = capacity infinite
(<.>) = min
instance (Num a, Ord a) => StarSemiring (Capacity a) where
star _ = one
instance (Num a, Ord a) => Dioid (Capacity a)
capacity :: NonNegative a -> Capacity a
capacity = Capacity . Max
getCapacity :: Capacity a -> NonNegative a
getCapacity (Capacity (Max x)) = x
newtype Count a = Count (Sum (NonNegative a))
deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)
instance Show a => Show (Count a) where
show (Count (Sum (NonNegative (Finite x)))) = show x
show _ = "count infinite"
instance (Num a, Ord a) => Semiring (Count a) where
one = 1
(<.>) = (*)
instance (Num a, Ord a) => StarSemiring (Count a) where
star x | x == zero = one
| otherwise = count infinite
count :: NonNegative a -> Count a
count = Count . Sum
getCount :: Count a -> NonNegative a
getCount (Count (Sum x)) = x
newtype Distance a = Distance (Min (NonNegative a))
deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)
instance Show a => Show (Distance a) where
show (Distance (Min (NonNegative (Finite x)))) = show x
show _ = "distance infinite"
instance (Num a, Ord a) => Semiring (Distance a) where
one = 0
(<.>) = (+)
instance (Num a, Ord a) => StarSemiring (Distance a) where
star _ = one
instance (Num a, Ord a) => Dioid (Distance a)
distance :: NonNegative a -> Distance a
distance = Distance . Min
getDistance :: Distance a -> NonNegative a
getDistance (Distance (Min x)) = x
data Extended a = Finite a | Infinite
deriving (Eq, Functor, Ord, Show)
instance Applicative Extended where
pure = Finite
(<*>) = ap
instance Monad Extended where
return = pure
Infinite >>= _ = Infinite
Finite x >>= f = f x
fromExtended :: Extended a -> Maybe a
fromExtended (Finite a) = Just a
fromExtended Infinite = Nothing
instance (Num a, Eq a) => Num (Extended a) where
fromInteger = Finite . fromInteger
(+) = liftA2 (+)
Finite 0 * _ = Finite 0
_ * Finite 0 = Finite 0
x * y = liftA2 (*) x y
negate = fmap negate
signum = fmap signum
abs = fmap abs
newtype Minimum a = Minimum (Extended a)
deriving (Applicative, Eq, Functor, Ord, Monad)
getMinimum :: Minimum a -> Maybe a
getMinimum (Minimum x) = fromExtended x
noMinimum :: Minimum a
noMinimum = Minimum Infinite
instance Ord a => Semigroup (Minimum a) where
(<>) = min
instance (Monoid a, Ord a) => Monoid (Minimum a) where
mempty = noMinimum
mappend = (<>)
instance (Monoid a, Ord a) => Semiring (Minimum a) where
one = pure mempty
(<.>) = liftA2 mappend
instance (Monoid a, Ord a) => Dioid (Minimum a)
instance Show a => Show (Minimum a) where
show (Minimum Infinite ) = "one"
show (Minimum (Finite x)) = show x
instance IsList a => IsList (Minimum a) where
type Item (Minimum a) = Item a
fromList = Minimum . Finite . fromList
toList (Minimum x) = toList $ fromMaybe errorMessage (fromExtended x)
where
errorMessage = error "Minimum.toList applied to noMinimum value."
newtype PowerSet a = PowerSet { getPowerSet :: Set a }
deriving (Eq, Monoid, Ord, Semigroup, Show)
instance (Monoid a, Ord a) => Semiring (PowerSet a) where
one = PowerSet (Set.singleton mempty)
PowerSet x <.> PowerSet y = PowerSet (setProductWith mappend x y)
instance (Monoid a, Ord a) => Dioid (PowerSet a) where
data Label a = Zero
| One
| Symbol a
| Label a :+: Label a
| Label a :*: Label a
| Star (Label a)
deriving Functor
infixl 6 :+:
infixl 7 :*:
instance IsList (Label a) where
type Item (Label a) = a
fromList = foldr ((<>) . Symbol) Zero
toList = error "Label.toList cannot be given a reasonable definition"
instance Show a => Show (Label a) where
showsPrec p label = case label of
Zero -> shows (0 :: Int)
One -> shows (1 :: Int)
Symbol x -> shows x
x :+: y -> showParen (p >= 6) $ showsPrec 6 x . (" | " ++) . showsPrec 6 y
x :*: y -> showParen (p >= 7) $ showsPrec 7 x . (" ; " ++) . showsPrec 7 y
Star x -> showParen (p >= 8) $ showsPrec 8 x . ("*" ++)
instance Semigroup (Label a) where
Zero <> x = x
x <> Zero = x
One <> One = One
One <> Star x = Star x
Star x <> One = Star x
x <> y = x :+: y
instance Monoid (Label a) where
mempty = Zero
mappend = (<>)
instance Semiring (Label a) where
one = One
One <.> x = x
x <.> One = x
Zero <.> _ = Zero
_ <.> Zero = Zero
x <.> y = x :*: y
instance StarSemiring (Label a) where
star Zero = One
star One = One
star (Star x) = star x
star x = Star x
isZero :: Label a -> Bool
isZero Zero = True
isZero _ = False
type RegularExpression a = Label a
data Optimum o a = Optimum { getOptimum :: o, getArgument :: a }
deriving (Eq, Ord, Show)
instance (Eq o, Monoid a, Monoid o) => Semigroup (Optimum o a) where
Optimum o1 a1 <> Optimum o2 a2
| o1 == o2 = Optimum o1 (mappend a1 a2)
| otherwise = Optimum o a
where
o = mappend o1 o2
a = if o == o1 then a1 else a2
instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where
mempty = Optimum mempty mempty
mappend = (<>)
instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where
one = Optimum one one
Optimum o1 a1 <.> Optimum o2 a2 = Optimum (o1 <.> o2) (a1 <.> a2)
instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where
star (Optimum o a) = Optimum (star o) (star a)
instance (Eq o, Dioid a, Dioid o) => Dioid (Optimum o a) where
type Path a = [(a, a)]
type ShortestPath e a = Optimum (Distance e) (Minimum (Path a))
type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a))
type CountShortestPaths e = Optimum (Distance e) (Count Integer)
type WidestPath e a = Optimum (Capacity e) (Minimum (Path a))