{-# LANGUAGE TemplateHaskell, RankNTypes #-}

-- |Module `TuringMachine.Interpreter.Tape` include type of Turing machine's
--  tape and useful functions for working with it.
module TuringMachine.Interpreter.Tape (
    Tape,
    top,
    move,
    fromString,
  ) where

import TuringMachine.SymbolOrMove
import Lens

import System.Console.ANSI (
    SGR (Reset, SetConsoleIntensity, SetColor),
    ConsoleLayer (Foreground),
    Color(Green),
    ColorIntensity (Vivid),
    ConsoleIntensity (BoldIntensity),
    setSGRCode
  )

type TapeSymbol = ShowedSymbol

type TapePart = [TapeSymbol]

data Tape = Tape
  { Tape -> TapePart
_left  :: TapePart
  , Tape -> TapeSymbol
_top   :: TapeSymbol
  , Tape -> TapePart
_right :: TapePart
  }

instance Eq Tape where
    (Tape TapePart
l1 TapeSymbol
t1 TapePart
r1) == :: Tape -> Tape -> Bool
== (Tape TapePart
l2 TapeSymbol
t2 TapePart
r2) =
        TapeSymbol
t1 TapeSymbol -> TapeSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== TapeSymbol
t2 Bool -> Bool -> Bool
&&
        TapePart
l1 TapePart -> TapePart -> Bool
forall a. Eq a => a -> a -> Bool
== TapePart
l2 Bool -> Bool -> Bool
&&
        TapePart
r1 TapePart -> TapePart -> Bool
forall a. Eq a => a -> a -> Bool
== TapePart
r2

instance Show Tape where
    show :: Tape -> String
show (Tape TapePart
l TapeSymbol
t TapePart
r) =
        TapePart -> String
forall a. Show a => a -> String
show TapePart
l String -> ShowS
forall a. [a] -> [a] -> [a]
++
        [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity] String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++
        TapeSymbol -> String
forall a. Show a => a -> String
show TapeSymbol
t String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"]" String -> ShowS
forall a. [a] -> [a] -> [a]
++
        [SGR] -> String
setSGRCode [SGR
Reset] String -> ShowS
forall a. [a] -> [a] -> [a]
++
        TapePart -> String
forall a. Show a => a -> String
show TapePart
r

makeLenses ''Tape

move :: Move -> Getter Tape Tape
move :: Move -> Getter Tape Tape
move = (Tape -> Tape) -> Optic' (->) f Tape Tape
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Tape -> Tape) -> Optic' (->) f Tape Tape)
-> (Move -> Tape -> Tape) -> Move -> Optic' (->) f Tape Tape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Move -> Tape -> Tape
go where
    go :: Move -> Tape -> Tape
go Move
m (Tape TapePart
l TapeSymbol
t TapePart
r)
        | Move
m Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
== Move
toLeft =
            let l' :: TapePart
l' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
l then [] else TapePart -> TapePart
forall a. [a] -> [a]
tail TapePart
l
                t' :: TapeSymbol
t' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
l then TapeSymbol
blank else TapePart -> TapeSymbol
forall a. [a] -> a
head TapePart
l
                r' :: TapePart
r' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
r Bool -> Bool -> Bool
&& TapeSymbol -> Bool
isBlank TapeSymbol
t then [] else TapeSymbol
t TapeSymbol -> TapePart -> TapePart
forall a. a -> [a] -> [a]
: TapePart
r
            in  TapePart -> TapeSymbol -> TapePart -> Tape
Tape TapePart
l' TapeSymbol
t' TapePart
r'
        | Bool
otherwise =
            let l' :: TapePart
l' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
l Bool -> Bool -> Bool
&& TapeSymbol -> Bool
isBlank TapeSymbol
t then [] else TapeSymbol
t TapeSymbol -> TapePart -> TapePart
forall a. a -> [a] -> [a]
: TapePart
l
                t' :: TapeSymbol
t' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
r then TapeSymbol
blank else TapePart -> TapeSymbol
forall a. [a] -> a
head TapePart
r
                r' :: TapePart
r' = if TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
r then [] else TapePart -> TapePart
forall a. [a] -> [a]
tail TapePart
r
            in  TapePart -> TapeSymbol -> TapePart -> Tape
Tape TapePart
l' TapeSymbol
t' TapePart
r'

fromString :: String -> Int -> Tape
fromString :: String -> Int -> Tape
fromString String
s Int
i =
    let (TapePart
l, TapeSymbol
t, TapePart
r) = Int -> TapePart -> (TapePart, TapeSymbol, TapePart)
splitByIndex Int
i (TapePart -> (TapePart, TapeSymbol, TapePart))
-> TapePart -> (TapePart, TapeSymbol, TapePart)
forall a b. (a -> b) -> a -> b
$ String -> TapePart
forall s. ShowedSymbolClass s => [s] -> TapePart
showedSymbols String
s
    in  TapePart -> TapeSymbol -> TapePart -> Tape
Tape (TapePart -> TapePart
forall a. [a] -> [a]
reverse TapePart
l) TapeSymbol
t TapePart
r
      where
        splitByIndex :: Int -> TapePart -> (TapePart, TapeSymbol, TapePart)
splitByIndex Int
i_ TapePart
s'_
            | TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
s'_ = ([], TapeSymbol
blank, [])
            | Int
i_ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0   = ([], TapeSymbol
blank, Int -> TapeSymbol -> TapePart
forall a. Int -> a -> [a]
replicate (-Int
i_Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) TapeSymbol
blank TapePart -> TapePart -> TapePart
forall a. [a] -> [a] -> [a]
++ TapePart
s'_)
            | Bool
otherwise = Int -> TapePart -> (TapePart, TapeSymbol, TapePart)
splitByIndex' Int
i_ TapePart
s'_
        splitByIndex' :: Int -> TapePart -> (TapePart, TapeSymbol, TapePart)
splitByIndex' Int
i_ TapePart
s'_
            | TapePart -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TapePart
s'_ = (Int -> TapeSymbol -> TapePart
forall a. Int -> a -> [a]
replicate Int
i_ TapeSymbol
blank, TapeSymbol
blank, [])
            | Int
i_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = ([], TapePart -> TapeSymbol
forall a. [a] -> a
head TapePart
s'_, TapePart -> TapePart
forall a. [a] -> [a]
tail TapePart
s'_)
            | Bool
otherwise =
                let (TapePart
l', TapeSymbol
t', TapePart
r') = Int -> TapePart -> (TapePart, TapeSymbol, TapePart)
splitByIndex' (Int
i_Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (TapePart -> TapePart
forall a. [a] -> [a]
tail TapePart
s'_)
                in  (TapePart -> TapeSymbol
forall a. [a] -> a
head TapePart
s'_ TapeSymbol -> TapePart -> TapePart
forall a. a -> [a] -> [a]
: TapePart
l', TapeSymbol
t', TapePart
r')