{-# LANGUAGE OverloadedLists, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Labelled.Example.Automaton
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- 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 contains a simple example of using edge-labelled graphs defined
-- in the module "Algebra.Graph.Labelled" for working with finite automata.
-----------------------------------------------------------------------------
module Algebra.Graph.Labelled.Example.Automaton where

import Data.Map    (Map)
import Data.Monoid (Any (..))

import Algebra.Graph.Label
import Algebra.Graph.Labelled
import Algebra.Graph.ToGraph

import qualified Data.Map as Map

-- | The alphabet of actions for ordering coffee or tea.
data Alphabet = Coffee -- ^ Order coffee
              | Tea    -- ^ Order tea
              | Cancel -- ^ Cancel payment or order
              | Pay    -- ^ Pay for the order
              deriving (Alphabet
Alphabet -> Alphabet -> Bounded Alphabet
forall a. a -> a -> Bounded a
maxBound :: Alphabet
$cmaxBound :: Alphabet
minBound :: Alphabet
$cminBound :: Alphabet
Bounded, Int -> Alphabet
Alphabet -> Int
Alphabet -> [Alphabet]
Alphabet -> Alphabet
Alphabet -> Alphabet -> [Alphabet]
Alphabet -> Alphabet -> Alphabet -> [Alphabet]
(Alphabet -> Alphabet)
-> (Alphabet -> Alphabet)
-> (Int -> Alphabet)
-> (Alphabet -> Int)
-> (Alphabet -> [Alphabet])
-> (Alphabet -> Alphabet -> [Alphabet])
-> (Alphabet -> Alphabet -> [Alphabet])
-> (Alphabet -> Alphabet -> Alphabet -> [Alphabet])
-> Enum Alphabet
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Alphabet -> Alphabet -> Alphabet -> [Alphabet]
$cenumFromThenTo :: Alphabet -> Alphabet -> Alphabet -> [Alphabet]
enumFromTo :: Alphabet -> Alphabet -> [Alphabet]
$cenumFromTo :: Alphabet -> Alphabet -> [Alphabet]
enumFromThen :: Alphabet -> Alphabet -> [Alphabet]
$cenumFromThen :: Alphabet -> Alphabet -> [Alphabet]
enumFrom :: Alphabet -> [Alphabet]
$cenumFrom :: Alphabet -> [Alphabet]
fromEnum :: Alphabet -> Int
$cfromEnum :: Alphabet -> Int
toEnum :: Int -> Alphabet
$ctoEnum :: Int -> Alphabet
pred :: Alphabet -> Alphabet
$cpred :: Alphabet -> Alphabet
succ :: Alphabet -> Alphabet
$csucc :: Alphabet -> Alphabet
Enum, Alphabet -> Alphabet -> Bool
(Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Bool) -> Eq Alphabet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alphabet -> Alphabet -> Bool
$c/= :: Alphabet -> Alphabet -> Bool
== :: Alphabet -> Alphabet -> Bool
$c== :: Alphabet -> Alphabet -> Bool
Eq, Eq Alphabet
Eq Alphabet
-> (Alphabet -> Alphabet -> Ordering)
-> (Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Alphabet)
-> (Alphabet -> Alphabet -> Alphabet)
-> Ord Alphabet
Alphabet -> Alphabet -> Bool
Alphabet -> Alphabet -> Ordering
Alphabet -> Alphabet -> Alphabet
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Alphabet -> Alphabet -> Alphabet
$cmin :: Alphabet -> Alphabet -> Alphabet
max :: Alphabet -> Alphabet -> Alphabet
$cmax :: Alphabet -> Alphabet -> Alphabet
>= :: Alphabet -> Alphabet -> Bool
$c>= :: Alphabet -> Alphabet -> Bool
> :: Alphabet -> Alphabet -> Bool
$c> :: Alphabet -> Alphabet -> Bool
<= :: Alphabet -> Alphabet -> Bool
$c<= :: Alphabet -> Alphabet -> Bool
< :: Alphabet -> Alphabet -> Bool
$c< :: Alphabet -> Alphabet -> Bool
compare :: Alphabet -> Alphabet -> Ordering
$ccompare :: Alphabet -> Alphabet -> Ordering
$cp1Ord :: Eq Alphabet
Ord, Int -> Alphabet -> ShowS
[Alphabet] -> ShowS
Alphabet -> String
(Int -> Alphabet -> ShowS)
-> (Alphabet -> String) -> ([Alphabet] -> ShowS) -> Show Alphabet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alphabet] -> ShowS
$cshowList :: [Alphabet] -> ShowS
show :: Alphabet -> String
$cshow :: Alphabet -> String
showsPrec :: Int -> Alphabet -> ShowS
$cshowsPrec :: Int -> Alphabet -> ShowS
Show)

-- | The state of the order.
data State = Choice   -- ^ Choosing what to order
           | Payment  -- ^ Making the payment
           | Complete -- ^ The order is complete
           deriving (State
State -> State -> Bounded State
forall a. a -> a -> Bounded a
maxBound :: State
$cmaxBound :: State
minBound :: State
$cminBound :: State
Bounded, Int -> State
State -> Int
State -> [State]
State -> State
State -> State -> [State]
State -> State -> State -> [State]
(State -> State)
-> (State -> State)
-> (Int -> State)
-> (State -> Int)
-> (State -> [State])
-> (State -> State -> [State])
-> (State -> State -> [State])
-> (State -> State -> State -> [State])
-> Enum State
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: State -> State -> State -> [State]
$cenumFromThenTo :: State -> State -> State -> [State]
enumFromTo :: State -> State -> [State]
$cenumFromTo :: State -> State -> [State]
enumFromThen :: State -> State -> [State]
$cenumFromThen :: State -> State -> [State]
enumFrom :: State -> [State]
$cenumFrom :: State -> [State]
fromEnum :: State -> Int
$cfromEnum :: State -> Int
toEnum :: Int -> State
$ctoEnum :: Int -> State
pred :: State -> State
$cpred :: State -> State
succ :: State -> State
$csucc :: State -> State
Enum, State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Eq State
Eq State
-> (State -> State -> Ordering)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> State)
-> (State -> State -> State)
-> Ord State
State -> State -> Bool
State -> State -> Ordering
State -> State -> State
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: State -> State -> State
$cmin :: State -> State -> State
max :: State -> State -> State
$cmax :: State -> State -> State
>= :: State -> State -> Bool
$c>= :: State -> State -> Bool
> :: State -> State -> Bool
$c> :: State -> State -> Bool
<= :: State -> State -> Bool
$c<= :: State -> State -> Bool
< :: State -> State -> Bool
$c< :: State -> State -> Bool
compare :: State -> State -> Ordering
$ccompare :: State -> State -> Ordering
$cp1Ord :: Eq State
Ord, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

-- TODO: Add an illustration.
-- | An example automaton for ordering coffee or tea.
--
-- @
-- order = 'overlays' [ 'Choice'  '-<'['Coffee', 'Tea']'>-' 'Payment'
--                  , 'Choice'  '-<'['Cancel'     ]'>-' 'Complete'
--                  , 'Payment' '-<'['Cancel'     ]'>-' 'Choice'
--                  , 'Payment' '-<'['Pay'        ]'>-' 'Complete' ]
-- @
coffeeTeaAutomaton :: Automaton Alphabet State
coffeeTeaAutomaton :: Automaton Alphabet State
coffeeTeaAutomaton = [Automaton Alphabet State] -> Automaton Alphabet State
forall e a. Monoid e => [Graph e a] -> Graph e a
overlays [ State
Choice  State
-> RegularExpression Alphabet
-> (State, RegularExpression Alphabet)
forall a e. a -> e -> (a, e)
-<[Item (RegularExpression Alphabet)
Alphabet
Coffee, Item (RegularExpression Alphabet)
Alphabet
Tea](State, RegularExpression Alphabet)
-> State -> Automaton Alphabet State
forall a e. (a, e) -> a -> Graph e a
>- State
Payment
                              , State
Payment State
-> RegularExpression Alphabet
-> (State, RegularExpression Alphabet)
forall a e. a -> e -> (a, e)
-<[Item (RegularExpression Alphabet)
Alphabet
Pay        ](State, RegularExpression Alphabet)
-> State -> Automaton Alphabet State
forall a e. (a, e) -> a -> Graph e a
>- State
Complete
                              , State
Choice  State
-> RegularExpression Alphabet
-> (State, RegularExpression Alphabet)
forall a e. a -> e -> (a, e)
-<[Item (RegularExpression Alphabet)
Alphabet
Cancel     ](State, RegularExpression Alphabet)
-> State -> Automaton Alphabet State
forall a e. (a, e) -> a -> Graph e a
>- State
Complete
                              , State
Payment State
-> RegularExpression Alphabet
-> (State, RegularExpression Alphabet)
forall a e. a -> e -> (a, e)
-<[Item (RegularExpression Alphabet)
Alphabet
Cancel     ](State, RegularExpression Alphabet)
-> State -> Automaton Alphabet State
forall a e. (a, e) -> a -> Graph e a
>- State
Choice ]

-- | The map of 'State' reachability.
--
-- @
-- reachability = Map.'Map.fromList' $ map (\s -> (s, 'reachable' s 'order')) ['Choice' ..]
-- @
--
-- Or, when evaluated:
--
-- @
-- reachability = Map.'Map.fromList' [ ('Choice'  , ['Choice'  , 'Payment', 'Complete'])
--                             , ('Payment' , ['Payment' , 'Choice' , 'Complete'])
--                             , ('Complete', ['Complete'                   ]) ]
-- @
reachability :: Map State [State]
reachability :: Map State [State]
reachability = [(State, [State])] -> Map State [State]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(State, [State])] -> Map State [State])
-> [(State, [State])] -> Map State [State]
forall a b. (a -> b) -> a -> b
$ (State -> (State, [State])) -> [State] -> [(State, [State])]
forall a b. (a -> b) -> [a] -> [b]
map (\State
s -> (State
s, ToVertex (Graph Any State)
-> Graph Any State -> [ToVertex (Graph Any State)]
forall t.
(ToGraph t, Ord (ToVertex t)) =>
ToVertex t -> t -> [ToVertex t]
reachable ToVertex (Graph Any State)
State
s Graph Any State
skeleton)) [Item [State]
State
Choice ..]
  where
    skeleton :: Graph Any State
    skeleton :: Graph Any State
skeleton = (RegularExpression Alphabet -> Any)
-> Automaton Alphabet State -> Graph Any State
forall e f a. (e -> f) -> Graph e a -> Graph f a
emap (Bool -> Any
Any (Bool -> Any)
-> (RegularExpression Alphabet -> Bool)
-> RegularExpression Alphabet
-> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool)
-> (RegularExpression Alphabet -> Bool)
-> RegularExpression Alphabet
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegularExpression Alphabet -> Bool
forall a. Label a -> Bool
isZero) Automaton Alphabet State
coffeeTeaAutomaton