-- |This module provides types for representing turing machines in a format suitable for the service: https://turingmachinesimulator.com/
-- Below this format will be called Tms.

module TmsType where

import Data.List (intercalate)
import GHC.Unicode (isAlphaNum)

import Prettyprinter

-- |Type of Tms tape square action.
--
-- 'Leave' is leave any character unchanged.
--
-- 'ChangeFromTo f t' is change it from 'f' to 't'.
data TmsTapeSquare = Leave | ChangeFromTo Char Char
    deriving (TmsTapeSquare -> TmsTapeSquare -> Bool
(TmsTapeSquare -> TmsTapeSquare -> Bool)
-> (TmsTapeSquare -> TmsTapeSquare -> Bool) -> Eq TmsTapeSquare
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c/= :: TmsTapeSquare -> TmsTapeSquare -> Bool
== :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c== :: TmsTapeSquare -> TmsTapeSquare -> Bool
Eq, Eq TmsTapeSquare
Eq TmsTapeSquare
-> (TmsTapeSquare -> TmsTapeSquare -> Ordering)
-> (TmsTapeSquare -> TmsTapeSquare -> Bool)
-> (TmsTapeSquare -> TmsTapeSquare -> Bool)
-> (TmsTapeSquare -> TmsTapeSquare -> Bool)
-> (TmsTapeSquare -> TmsTapeSquare -> Bool)
-> (TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare)
-> (TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare)
-> Ord TmsTapeSquare
TmsTapeSquare -> TmsTapeSquare -> Bool
TmsTapeSquare -> TmsTapeSquare -> Ordering
TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare
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 :: TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare
$cmin :: TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare
max :: TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare
$cmax :: TmsTapeSquare -> TmsTapeSquare -> TmsTapeSquare
>= :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c>= :: TmsTapeSquare -> TmsTapeSquare -> Bool
> :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c> :: TmsTapeSquare -> TmsTapeSquare -> Bool
<= :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c<= :: TmsTapeSquare -> TmsTapeSquare -> Bool
< :: TmsTapeSquare -> TmsTapeSquare -> Bool
$c< :: TmsTapeSquare -> TmsTapeSquare -> Bool
compare :: TmsTapeSquare -> TmsTapeSquare -> Ordering
$ccompare :: TmsTapeSquare -> TmsTapeSquare -> Ordering
$cp1Ord :: Eq TmsTapeSquare
Ord)

-- |Type of Tms tape head movement
data TmsTapeHeadMovement = MoveLeft | Stay | MoveRight
    deriving (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
(TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> Eq TmsTapeHeadMovement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c/= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
== :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c== :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
Eq, Eq TmsTapeHeadMovement
Eq TmsTapeHeadMovement
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Ordering)
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> (TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool)
-> (TmsTapeHeadMovement
    -> TmsTapeHeadMovement -> TmsTapeHeadMovement)
-> (TmsTapeHeadMovement
    -> TmsTapeHeadMovement -> TmsTapeHeadMovement)
-> Ord TmsTapeHeadMovement
TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
TmsTapeHeadMovement -> TmsTapeHeadMovement -> Ordering
TmsTapeHeadMovement -> TmsTapeHeadMovement -> TmsTapeHeadMovement
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 :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> TmsTapeHeadMovement
$cmin :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> TmsTapeHeadMovement
max :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> TmsTapeHeadMovement
$cmax :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> TmsTapeHeadMovement
>= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c>= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
> :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c> :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
<= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c<= :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
< :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
$c< :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Bool
compare :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Ordering
$ccompare :: TmsTapeHeadMovement -> TmsTapeHeadMovement -> Ordering
$cp1Ord :: Eq TmsTapeHeadMovement
Ord)

instance Show TmsTapeHeadMovement where
    show :: TmsTapeHeadMovement -> String
show TmsTapeHeadMovement
MoveLeft  = String
"<"
    show TmsTapeHeadMovement
Stay      = String
"-"
    show TmsTapeHeadMovement
MoveRight = String
">"

-- |Type of Tms State.
newtype TmsState = TmsState String
    deriving (TmsState -> TmsState -> Bool
(TmsState -> TmsState -> Bool)
-> (TmsState -> TmsState -> Bool) -> Eq TmsState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmsState -> TmsState -> Bool
$c/= :: TmsState -> TmsState -> Bool
== :: TmsState -> TmsState -> Bool
$c== :: TmsState -> TmsState -> Bool
Eq, Eq TmsState
Eq TmsState
-> (TmsState -> TmsState -> Ordering)
-> (TmsState -> TmsState -> Bool)
-> (TmsState -> TmsState -> Bool)
-> (TmsState -> TmsState -> Bool)
-> (TmsState -> TmsState -> Bool)
-> (TmsState -> TmsState -> TmsState)
-> (TmsState -> TmsState -> TmsState)
-> Ord TmsState
TmsState -> TmsState -> Bool
TmsState -> TmsState -> Ordering
TmsState -> TmsState -> TmsState
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 :: TmsState -> TmsState -> TmsState
$cmin :: TmsState -> TmsState -> TmsState
max :: TmsState -> TmsState -> TmsState
$cmax :: TmsState -> TmsState -> TmsState
>= :: TmsState -> TmsState -> Bool
$c>= :: TmsState -> TmsState -> Bool
> :: TmsState -> TmsState -> Bool
$c> :: TmsState -> TmsState -> Bool
<= :: TmsState -> TmsState -> Bool
$c<= :: TmsState -> TmsState -> Bool
< :: TmsState -> TmsState -> Bool
$c< :: TmsState -> TmsState -> Bool
compare :: TmsState -> TmsState -> Ordering
$ccompare :: TmsState -> TmsState -> Ordering
$cp1Ord :: Eq TmsState
Ord)

-- |Type of Tms command for one tape.
-- TmsSingleTapeCommand (action, movement).
newtype TmsSingleTapeCommand = TmsSingleTapeCommand (TmsTapeSquare, TmsTapeHeadMovement)
    deriving (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
(TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> Eq TmsSingleTapeCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c/= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
== :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c== :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
Eq, Eq TmsSingleTapeCommand
Eq TmsSingleTapeCommand
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Ordering)
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> (TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool)
-> (TmsSingleTapeCommand
    -> TmsSingleTapeCommand -> TmsSingleTapeCommand)
-> (TmsSingleTapeCommand
    -> TmsSingleTapeCommand -> TmsSingleTapeCommand)
-> Ord TmsSingleTapeCommand
TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
TmsSingleTapeCommand -> TmsSingleTapeCommand -> Ordering
TmsSingleTapeCommand
-> TmsSingleTapeCommand -> TmsSingleTapeCommand
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 :: TmsSingleTapeCommand
-> TmsSingleTapeCommand -> TmsSingleTapeCommand
$cmin :: TmsSingleTapeCommand
-> TmsSingleTapeCommand -> TmsSingleTapeCommand
max :: TmsSingleTapeCommand
-> TmsSingleTapeCommand -> TmsSingleTapeCommand
$cmax :: TmsSingleTapeCommand
-> TmsSingleTapeCommand -> TmsSingleTapeCommand
>= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c>= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
> :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c> :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
<= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c<= :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
< :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
$c< :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Bool
compare :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Ordering
$ccompare :: TmsSingleTapeCommand -> TmsSingleTapeCommand -> Ordering
$cp1Ord :: Eq TmsSingleTapeCommand
Ord)

-- |Type of Tms single tape command
type OneTapeTMCommand = (TmsState, TmsSingleTapeCommand, TmsState)

toTmsCommand :: OneTapeTMCommand -> TmsCommand
toTmsCommand :: OneTapeTMCommand -> TmsCommand
toTmsCommand (TmsState
ini, TmsSingleTapeCommand
cmd, TmsState
fol) = (TmsState, [TmsSingleTapeCommand], TmsState) -> TmsCommand
TmsCommand (TmsState
ini, [TmsSingleTapeCommand
cmd], TmsState
fol)

-- |Type of Tms command for entire Turing machine.
newtype TmsCommand = TmsCommand (TmsState, [TmsSingleTapeCommand], TmsState)
    deriving (TmsCommand -> TmsCommand -> Bool
(TmsCommand -> TmsCommand -> Bool)
-> (TmsCommand -> TmsCommand -> Bool) -> Eq TmsCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmsCommand -> TmsCommand -> Bool
$c/= :: TmsCommand -> TmsCommand -> Bool
== :: TmsCommand -> TmsCommand -> Bool
$c== :: TmsCommand -> TmsCommand -> Bool
Eq, Eq TmsCommand
Eq TmsCommand
-> (TmsCommand -> TmsCommand -> Ordering)
-> (TmsCommand -> TmsCommand -> Bool)
-> (TmsCommand -> TmsCommand -> Bool)
-> (TmsCommand -> TmsCommand -> Bool)
-> (TmsCommand -> TmsCommand -> Bool)
-> (TmsCommand -> TmsCommand -> TmsCommand)
-> (TmsCommand -> TmsCommand -> TmsCommand)
-> Ord TmsCommand
TmsCommand -> TmsCommand -> Bool
TmsCommand -> TmsCommand -> Ordering
TmsCommand -> TmsCommand -> TmsCommand
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 :: TmsCommand -> TmsCommand -> TmsCommand
$cmin :: TmsCommand -> TmsCommand -> TmsCommand
max :: TmsCommand -> TmsCommand -> TmsCommand
$cmax :: TmsCommand -> TmsCommand -> TmsCommand
>= :: TmsCommand -> TmsCommand -> Bool
$c>= :: TmsCommand -> TmsCommand -> Bool
> :: TmsCommand -> TmsCommand -> Bool
$c> :: TmsCommand -> TmsCommand -> Bool
<= :: TmsCommand -> TmsCommand -> Bool
$c<= :: TmsCommand -> TmsCommand -> Bool
< :: TmsCommand -> TmsCommand -> Bool
$c< :: TmsCommand -> TmsCommand -> Bool
compare :: TmsCommand -> TmsCommand -> Ordering
$ccompare :: TmsCommand -> TmsCommand -> Ordering
$cp1Ord :: Eq TmsCommand
Ord)

-- |Type of Tms format.
-- Tms            (name,   init      accept        commands,     tapeAlphabets).
newtype Tms = Tms (String, TmsState, [TmsState], [TmsCommand], [String])
    deriving (Tms -> Tms -> Bool
(Tms -> Tms -> Bool) -> (Tms -> Tms -> Bool) -> Eq Tms
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tms -> Tms -> Bool
$c/= :: Tms -> Tms -> Bool
== :: Tms -> Tms -> Bool
$c== :: Tms -> Tms -> Bool
Eq)

instance Show Tms where
  show :: Tms -> String
show
    ( Tms
        ( String
name,
          TmsState String
initial,
          [TmsState]
acStates,
          [TmsCommand]
commands,
          [String]
tapeAlphabets
          )
      ) = Doc String -> String
forall a. Show a => a -> String
show (Doc String -> String) -> Doc String -> String
forall a b. (a -> b) -> a -> b
$
      [[String]] -> Doc String
printKeyValue
        [ [String
"name", String
name],
          [String
"init", ShowS
filterStateName String
initial],
          [String
"accept", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((TmsState -> String) -> [TmsState] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TmsState String
tmsName) -> ShowS
filterStateName String
tmsName) [TmsState]
acStates)]
        ]
        Doc String -> Doc String -> Doc String
forall a. Semigroup a => a -> a -> a
<> Doc String
forall ann. Doc ann
line
        Doc String -> Doc String -> Doc String
forall a. Semigroup a => a -> a -> a
<> [Doc String] -> Doc String
forall ann. [Doc ann] -> Doc ann
vcat (Doc String -> [Doc String] -> [Doc String]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc String
forall ann. Doc ann
line ((TmsCommand -> Doc String) -> [TmsCommand] -> [Doc String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc String
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc String)
-> (TmsCommand -> String) -> TmsCommand -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TmsCommand -> String
showTmsCommand) [TmsCommand]
commands))
        where
            printKeyValue :: [[String]] -> Doc String
            printKeyValue :: [[String]] -> Doc String
printKeyValue = [Doc String] -> Doc String
forall ann. [Doc ann] -> Doc ann
vcat ([Doc String] -> Doc String)
-> ([[String]] -> [Doc String]) -> [[String]] -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> Doc String) -> [[String]] -> [Doc String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Doc String] -> Doc String
forall ann. [Doc ann] -> Doc ann
sep ([Doc String] -> Doc String)
-> ([Doc String] -> [Doc String]) -> [Doc String] -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc String -> [Doc String] -> [Doc String]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc String
forall ann. Doc ann
colon) ([Doc String] -> Doc String)
-> ([String] -> [Doc String]) -> [String] -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc String) -> [String] -> [Doc String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc String
forall a ann. Pretty a => a -> Doc ann
pretty)
            showTmsCommand :: TmsCommand -> String
            showTmsCommand :: TmsCommand -> String
showTmsCommand (TmsCommand (TmsState
ini, [TmsSingleTapeCommand]
tapeCommands, TmsState
fol)) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([(Char, TmsTapeHeadMovement, Char)] -> String)
-> [[(Char, TmsTapeHeadMovement, Char)]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (TmsState
-> TmsState -> [(Char, TmsTapeHeadMovement, Char)] -> String
showSingleCmd TmsState
ini TmsState
fol) ([[(Char, TmsTapeHeadMovement, Char)]] -> [String])
-> [[(Char, TmsTapeHeadMovement, Char)]] -> [String]
forall a b. (a -> b) -> a -> b
$ [[(Char, TmsTapeHeadMovement, Char)]]
-> [[(Char, TmsTapeHeadMovement, Char)]]
forall a. [[a]] -> [[a]]
combine ([[(Char, TmsTapeHeadMovement, Char)]]
 -> [[(Char, TmsTapeHeadMovement, Char)]])
-> [[(Char, TmsTapeHeadMovement, Char)]]
-> [[(Char, TmsTapeHeadMovement, Char)]]
forall a b. (a -> b) -> a -> b
$ (String
 -> TmsSingleTapeCommand -> [(Char, TmsTapeHeadMovement, Char)])
-> [String]
-> [TmsSingleTapeCommand]
-> [[(Char, TmsTapeHeadMovement, Char)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((String, TmsSingleTapeCommand)
 -> [(Char, TmsTapeHeadMovement, Char)])
-> String
-> TmsSingleTapeCommand
-> [(Char, TmsTapeHeadMovement, Char)]
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (String, TmsSingleTapeCommand)
-> [(Char, TmsTapeHeadMovement, Char)]
extCommand) [String]
tapeAlphabets [TmsSingleTapeCommand]
tapeCommands
            extCommand :: (String, TmsSingleTapeCommand) -> [(Char, TmsTapeHeadMovement, Char)]
            extCommand :: (String, TmsSingleTapeCommand)
-> [(Char, TmsTapeHeadMovement, Char)]
extCommand (String
alph, TmsSingleTapeCommand (TmsTapeSquare
Leave, TmsTapeHeadMovement
mv)) =
                [(Char
ch, TmsTapeHeadMovement
mv, Char
ch) | Char
ch <- Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
alph]
            extCommand (String
_,    TmsSingleTapeCommand (ChangeFromTo Char
cF Char
cT, TmsTapeHeadMovement
mv)) =
                [(Char
cF, TmsTapeHeadMovement
mv, Char
cT)]
            combine :: [[a]] -> [[a]]
combine = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. [a] -> [a]
reverse ([[a]] -> [[a]]) -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[a]] -> [a] -> [[a]]) -> [[a]] -> [[a]] -> [[a]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[[a]]
combs [a]
cur -> (a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:) ([a] -> a -> [a]) -> [[a]] -> [a -> [a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]]
combs [a -> [a]] -> [a] -> [[a]]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a]
cur) [[]]
            showSingleCmd :: TmsState -> TmsState -> [(Char, TmsTapeHeadMovement, Char)] -> String
            showSingleCmd :: TmsState
-> TmsState -> [(Char, TmsTapeHeadMovement, Char)] -> String
showSingleCmd (TmsState String
ini) (TmsState String
fol) [(Char, TmsTapeHeadMovement, Char)]
cmds = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$
                                    [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
sep (Doc Any -> [Doc Any] -> [Doc Any]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc Any
forall ann. Doc ann
comma (String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (ShowS
filterStateName String
ini) Doc Any -> [Doc Any] -> [Doc Any]
forall a. a -> [a] -> [a]
: [Doc Any]
forall ann. [Doc ann]
iniSquares)) Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
line Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<>
                                    [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
sep (Doc Any -> [Doc Any] -> [Doc Any]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc Any
forall ann. Doc ann
comma (String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (ShowS
filterStateName String
fol) Doc Any -> [Doc Any] -> [Doc Any]
forall a. a -> [a] -> [a]
: [Doc Any]
forall ann. [Doc ann]
folSquares [Doc Any] -> [Doc Any] -> [Doc Any]
forall a. [a] -> [a] -> [a]
++ [Doc Any]
forall ann. [Doc ann]
moves))
                where
                    iniSquares :: [Doc ann]
iniSquares = ((Char, TmsTapeHeadMovement, Char) -> Doc ann)
-> [(Char, TmsTapeHeadMovement, Char)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> ((Char, TmsTapeHeadMovement, Char) -> String)
-> (Char, TmsTapeHeadMovement, Char)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
1 (Char -> String)
-> ((Char, TmsTapeHeadMovement, Char) -> Char)
-> (Char, TmsTapeHeadMovement, Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, TmsTapeHeadMovement, Char) -> Char
forall a b c. (a, b, c) -> a
fst3) [(Char, TmsTapeHeadMovement, Char)]
cmds
                    moves :: [Doc ann]
moves      = ((Char, TmsTapeHeadMovement, Char) -> Doc ann)
-> [(Char, TmsTapeHeadMovement, Char)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> ((Char, TmsTapeHeadMovement, Char) -> String)
-> (Char, TmsTapeHeadMovement, Char)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TmsTapeHeadMovement -> String
forall a. Show a => a -> String
show (TmsTapeHeadMovement -> String)
-> ((Char, TmsTapeHeadMovement, Char) -> TmsTapeHeadMovement)
-> (Char, TmsTapeHeadMovement, Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, TmsTapeHeadMovement, Char) -> TmsTapeHeadMovement
forall a b c. (a, b, c) -> b
snd3) [(Char, TmsTapeHeadMovement, Char)]
cmds
                    folSquares :: [Doc ann]
folSquares = ((Char, TmsTapeHeadMovement, Char) -> Doc ann)
-> [(Char, TmsTapeHeadMovement, Char)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> ((Char, TmsTapeHeadMovement, Char) -> String)
-> (Char, TmsTapeHeadMovement, Char)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
1 (Char -> String)
-> ((Char, TmsTapeHeadMovement, Char) -> Char)
-> (Char, TmsTapeHeadMovement, Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, TmsTapeHeadMovement, Char) -> Char
forall a b c. (a, b, c) -> c
thd3) [(Char, TmsTapeHeadMovement, Char)]
cmds

-- |Process string so that it does not contain illegal characters.
filterStateName :: String -> String
filterStateName :: ShowS
filterStateName = Char -> Char -> ShowS
forall a. Eq a => a -> a -> [a] -> [a]
replace Char
'^' Char
'v' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c [Char
'_', Char
'^'])
  where
    replace :: Eq a => a -> a -> [a] -> [a]
    replace :: a -> a -> [a] -> [a]
replace = [a] -> a -> a -> [a] -> [a]
forall a. Eq a => [a] -> a -> a -> [a] -> [a]
replace' []
    replace' :: Eq a => [a] -> a -> a -> [a] -> [a]
    replace' :: [a] -> a -> a -> [a] -> [a]
replace' [a]
r a
x a
y [] = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
r
    replace' [a]
r a
x a
y (a
z:[a]
zs)
        | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
z =    [a] -> a -> a -> [a] -> [a]
forall a. Eq a => [a] -> a -> a -> [a] -> [a]
replace' (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
r) a
x a
y [a]
zs
        | Bool
otherwise = [a] -> a -> a -> [a] -> [a]
forall a. Eq a => [a] -> a -> a -> [a] -> [a]
replace' (a
za -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
r) a
x a
y [a]
zs

fst3 :: (a, b, c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

snd3 :: (a, b, c) -> b
snd3 :: (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b

thd3 :: (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c