{-# LANGUAGE TemplateHaskell, RankNTypes #-}
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')