{-# LANGUAGE DeriveGeneric #-}
module Examples.Contrived where

import           Teacher

import           NLambda      hiding (a, b, c, d, e, f, g, h, i, j, k, l, m, n,
                               o, p, q, r, s, t, u, v, w, x, y, z)

-- Explicit Prelude, as NLambda has quite some clashes
import           Data.Either  (Either (..))
import           Data.Maybe   (Maybe (..))
import           Prelude      (Bool (..), Eq, Ord, Show, ($), (.))
import qualified Prelude

import           GHC.Generics (Generic)

-- Example automaton from the whiteboard. Three orbits with 0, 1 and 2
-- registers. The third orbit has a local symmetry (S2).
data Example1 = Initial | S1 Atom | S2 (Atom, Atom)
  deriving (Show, Eq, Ord, Generic)
instance BareNominalType Example1
example1 = automaton
    -- states, 4 orbits (of which one unreachable)
    (singleton Initial
        `union` map S1 atoms
        `union` map S2 atomsPairs)
    -- alphabet
    atoms
    -- transitions
    (map (\a -> (Initial, a, S1 a)) atoms
        `union` map (\a -> (S1 a, a, Initial)) atoms
        `union` mapFilter (\(a, b) -> maybeIf (neq a b) (S1 a, b, S2 (a, b))) atomsPairs
        `union` mapFilter (\(a, b, c) -> maybeIf (eq a c \/ eq b c) (S2 (a, b), c, Initial)) atomsTriples
        `union` mapFilter (\(a, b, c) -> maybeIf (neq a c /\ neq b c) (S2 (a, b), c, S1 c)) atomsTriples)
    -- initial states
    (singleton Initial)
    -- final states
    (map S2 atomsPairs)


-- Accepts all even words (ignores the alphabet). Two orbits, with a
-- trivial action. No registers.
data Aut2 = Even | Odd deriving (Eq, Ord, Show, Generic)
instance BareNominalType Aut2
example2 = automaton
    -- states, two orbits
    (fromList [Even, Odd])
    -- alphabet
    atoms
    -- transitions
    (map (\a -> (Even, a, Odd)) atoms
        `union` map (\a -> (Odd, a, Even)) atoms)
    -- initial states
    (singleton Even)
    -- final states
    (singleton Even)


-- Accepts all non-empty words with the same symbol. Three orbits: the initial
-- state, a state with a register and a sink state.
data Aut3 = Empty | Stored Atom | Sink deriving (Eq, Ord, Show, Generic)
instance BareNominalType Aut3
example3 = automaton
    -- states, three orbits
    (fromList [Empty, Sink]
        `union` map Stored atoms)
    -- alphabet
    atoms
    -- transitions
    (map (\a -> (Empty, a, Stored a)) atoms
        `union` map (\a -> (Stored a, a, Stored a)) atoms
        `union` map (\(a,b) -> (Stored a, b, Sink)) differentAtomsPairs
        `union` map (\a -> (Sink, a, Sink)) atoms)
    -- initial states
    (singleton Empty)
    -- final states
    (map Stored atoms)


-- Example showing that a local symmetry is not always the full symmetric group
-- or trivial. Five (reachable) orbits. The state Symm a b c has a C3 symmetry,
-- i.e. we can shift: Symm a b c ~ Symm b c a, but not swap: Symm a b c !~
-- Symm a c b (here ~ means bisimilar).
data Aut4 = Aut4Init              -- Initial state
          | First Atom            -- State after reading 1 symbol
          | Second Atom Atom      -- After reading two different symbols
          | Symm Atom Atom Atom   -- Accepting state with C3 symmetry
          | Sorted Atom Atom Atom -- State without symmetry
  deriving (Eq, Ord, Show, Generic)
instance BareNominalType Aut4

example4 = automaton
    -- states
    (singleton Aut4Init
        `union` map First atoms
        `union` map (unc2 Second) atomsPairs
        `union` map (unc3 Symm) atomsTriples
        `union` map (unc3 Sorted) atomsTriples)
    -- alphabet
    atoms
    -- transitions
    (map (\a -> (Aut4Init, a, First a)) atoms
        `union` map (\a -> (First a, a, Aut4Init)) atoms
        `union` map (\(a, b) -> (First a, b, Second a b)) differentAtomsPairs
        `union` map (\(a, b) -> (Second a b, a, Aut4Init)) atomsPairs
        `union` map (\(a, b) -> (Second a b, b, Aut4Init)) atomsPairs
        `union` mapFilter (\(a, b, c) -> maybeIf (c `neq` a /\ c `neq` b) (Second a b, c, Symm a b c)) atomsTriples
        `union` mapFilter (\(a, b, c, d) -> maybeIf (d `neq` a /\ d `neq` b /\ d `neq` c) (Symm a b c, d, Aut4Init)) atomsQuadruples
        `union` map (\(a, b, c) -> (Symm a b c, a, Sorted a b c)) atomsTriples
        `union` map (\(a, b, c) -> (Symm a b c, b, Sorted b c a)) atomsTriples
        `union` map (\(a, b, c) -> (Symm a b c, c, Sorted c a b)) atomsTriples
        `union` mapFilter (\(a, b, c, d) -> maybeIf (d `neq` a /\ d `neq` b /\ d `neq` c) (Sorted a b c, d, First d)) atomsQuadruples
        `union` map (\(a, b, c) -> (Sorted a b c, a, Sorted a b c)) atomsTriples
        `union` map (\(a, b, c) -> (Sorted a b c, b, Symm a b c)) atomsTriples
        `union` map (\(a, b, c) -> (Sorted a b c, c, Aut4Init)) atomsTriples)
    -- initial states
    (singleton Aut4Init)
    -- final states
    (map (unc3 Symm) atomsTriples)
    where
        atomsQuadruples = map (\[a,b,c,d] -> (a,b,c,d)) $ replicateAtoms 4
        unc2 f (a,b) = f a b
        unc3 f (a,b,c) = f a b c