module Text.CTPL0 where
import Control.Monad
import Data.Char
import Data.Chatty.AVL
import Data.List
data BufferState = BufferState { leftBehind :: String, thisChar :: Char, rightPending :: String }
data RegisterState = RegisterState { ax :: Integer, mk :: [String], rk :: [Int], ck :: [Int], cp :: Bool }
data InfoState = InfoState { instrStats :: AVL (Char, Int) }
data CTPL0State = CTPL0State { bufferState :: BufferState, programState :: BufferState, registerState :: RegisterState, infoState :: InfoState }
data Exec a = Succ a | Expired | ConfViol | SynViol deriving Show
newtype CTPL0 a = CTPL0 { runCTPL0 :: Int -> CTPL0State -> Exec (a, CTPL0State, Int) }
instance Monad CTPL0 where
return a = CTPL0 $ \i k -> Succ (a, k, i)
m >>= f = CTPL0 $ \i k ->
case runCTPL0 m i k of
Succ (a, k', i') -> runCTPL0 (f a) i' k'
Expired -> Expired
ConfViol -> ConfViol
SynViol -> SynViol
getState :: (CTPL0State -> a) -> CTPL0 a
getState f = CTPL0 $ \i k -> Succ (f k, k, i)
modState :: (CTPL0State -> CTPL0State) -> CTPL0 ()
modState f = CTPL0 $ \i k -> Succ ((), f k, i)
consumeTime :: CTPL0 ()
consumeTime = CTPL0 $ \i k -> if i >= 1 then Succ ((), k, i1) else Expired
confViol :: CTPL0 a
confViol = CTPL0 $ \_ _ -> ConfViol
synViol :: CTPL0 a
synViol = CTPL0 $ \_ _ -> SynViol
modBufferState :: (BufferState -> BufferState) -> CTPL0 ()
modBufferState f = modState $ \s -> s{bufferState = f $ bufferState s}
modProgramState :: (BufferState -> BufferState) -> CTPL0 ()
modProgramState f = modState $ \s -> s{programState = f $ programState s}
modRegisterState :: (RegisterState -> RegisterState) -> CTPL0 ()
modRegisterState f = modState $ \s -> s{registerState = f $ registerState s}
walkBuffer :: Int -> BufferState -> BufferState
walkBuffer 0 s = s
walkBuffer i s
| i < 0 = BufferState (drop (i) $ leftBehind s) (head $ drop (i1) $ leftBehind s) (reverse (take (i1) $ leftBehind s) ++ [thisChar s] ++ rightPending s)
| i > 0 = BufferState (reverse (take (i1) (rightPending s)) ++ [thisChar s] ++ leftBehind s) (head $ drop (i1) $ rightPending s) (drop i $ rightPending s)
getInstr :: CTPL0 Char
getInstr = do
k <- getState $ thisChar . programState
modProgramState $ walkBuffer 1
return k
endOfInstr :: CTPL0 Bool
endOfInstr = getState $ null . rightPending . programState
instrNumArg :: CTPL0 Int
instrNumArg = do
ks <- getState $ \s -> takeWhile isDigit (thisChar (programState s) : rightPending (programState s))
when (null ks) synViol
modProgramState $ walkBuffer $ length ks
return $ read ks
instrDelimArg :: CTPL0 String
instrDelimArg = do
ks <- getState $ \s -> takeWhile (/='$') (thisChar (programState s) : rightPending (programState s))
modProgramState $ walkBuffer $ length ks
k' <- getState $ (=='$') . thisChar . programState
unless k' synViol
modProgramState $ walkBuffer 1
return ks
getIP :: CTPL0 Int
getIP = getState $ length . leftBehind . programState
getCP :: CTPL0 Int
getCP = getState $ length . leftBehind . bufferState
canRelJump :: Int -> CTPL0 Bool
canRelJump 0 = return True
canRelJump i
| i < 0 = getState $ (>= i) . length . leftBehind . programState
| i > 0 = getState $ (>= i) . length . rightPending . programState
canRelWalk :: Int -> CTPL0 Bool
canRelWalk 0 = return True
canRelWalk i
| i < 0 = getState $ (>= i) . length . leftBehind . bufferState
| i > 0 = getState $ (>= i) . length . rightPending . bufferState
provided :: CTPL0 a -> CTPL0 Bool -> CTPL0 a
provided act test = do
b <- test
if b
then act
else confViol
sx :: RegisterState -> Integer
sx r | cp r = fromIntegral $ head $ ck r
sx r = ax r
setSX :: Integer -> RegisterState -> RegisterState
setSX i r | cp r = r{ck=fromIntegral i : tail (ck r)}
setSX i r = r{ax=i}
singleInstr :: CTPL0 ()
singleInstr = do
i <- getInstr
consumeTime
f <- getState $ instrStats . infoState
let f' = case avlLookup i f of
Nothing -> avlInsert (i,1) f
Just j -> avlInsert (i,j+1) f
modState $ \s -> s{infoState=InfoState f'}
case i of
'<' -> modBufferState (walkBuffer (1))
`provided` getState (not . null . leftBehind . bufferState)
'>' -> modBufferState (walkBuffer 1)
`provided` getState (not . null . rightPending . bufferState)
'+' -> do
num <- liftM fromIntegral instrNumArg
modRegisterState $ \s -> setSX (sx s + num) s
'-' -> do
num <- liftM fromIntegral instrNumArg
modRegisterState $ \s -> setSX (sx s num) s
'i' -> do
ch <- getInstr `provided` liftM not endOfInstr
modBufferState $ \s -> s{leftBehind=ch : leftBehind s}
'r' -> do
ch <- getInstr `provided` liftM not endOfInstr
modBufferState $ \s -> s{thisChar=ch}
'x' -> modBufferState (\s -> s{thisChar=head $ rightPending s, rightPending=tail $ rightPending s})
`provided` getState (not . null . rightPending . bufferState)
'I' -> do
cs <- instrDelimArg
modBufferState $ \s -> s{leftBehind = reverse cs ++ leftBehind s}
'a' -> do
ch <- getInstr `provided` liftM not endOfInstr
modBufferState $ \s -> s{rightPending=appendBeforeETX (rightPending s) [ch]}
'A' -> do
cs <- instrDelimArg
modBufferState $ \s -> s{rightPending=appendBeforeETX (rightPending s) cs}
'y' -> do
ch <- getState $ thisChar . bufferState
modRegisterState $ \s -> s{mk=[ch]:mk s}
'Y' -> do
ch <- getState $ thisChar . bufferState
modRegisterState (\s -> s{mk=(appendBeforeETX (head $ mk s) [ch]):tail (mk s)})
`provided` getState (not . null . mk . registerState)
'p' -> modRegisterState (\s -> s{mk=tail $ mk s})
`provided` getState (not . null . mk . registerState)
'P' -> do
cs <- getState (head . mk . registerState)
`provided` getState (not . null . mk . registerState)
modBufferState $ \s -> s{leftBehind = reverse (unetx cs) ++ leftBehind s}
'j' -> do
ax <- getState $ sx . registerState
b <- singleCond
when b $ do
ip <- getIP
let rel = fromIntegral ax ip
modProgramState (walkBuffer rel) `provided` canRelJump rel
'J' -> do
ax <- getState $ sx . registerState
b <- singleCond
when b $ do
let rel = fromIntegral ax
modProgramState (walkBuffer rel) `provided` canRelJump rel
'c' -> do
ax <- getState $ sx . registerState
b <- singleCond
when b $ do
ip <- getIP
let rel = fromIntegral ax ip
modProgramState (walkBuffer rel) `provided` canRelJump rel
modRegisterState $ \s -> s{rk=ip:rk s}
'f' -> do
r0 <- getState (head . rk . registerState)
`provided` getState (not . null . rk . registerState)
ip <- getIP
let rel = r0 ip
modProgramState (walkBuffer rel) `provided` canRelJump rel
modRegisterState $ \s -> s{rk=tail $ rk s}
'0' -> modRegisterState $ setSX 0
'Q' -> do
cp <- getCP
modRegisterState $ setSX $ fromIntegral cp
'm' -> do
ax <- getState $ fromIntegral . sx . registerState
cp <- getCP
let rel = ax cp
modBufferState (walkBuffer rel) `provided` canRelWalk rel
'C' -> modRegisterState (\s -> s{cp=True})
`provided` getState (not . null . ck . registerState)
'l' -> do
ch <- getState $ ord . thisChar . bufferState
modRegisterState $ setSX $ fromIntegral ch
's' -> do
ax <- getState $ fromIntegral . sx . registerState
modBufferState $ \s -> s{thisChar=chr ax}
'd' -> do
ax <- getState $ fromIntegral . sx . registerState
modRegisterState $ \s -> s{ck=ax:ck s}
'D' -> do
ax' <- getState (fromIntegral . head . ck . registerState)
`provided` getState (not . null . ck . registerState)
modRegisterState $ \s -> s{ax=ax',ck=tail (ck s)}
'k' -> modRegisterState (\s -> s{ck=tail (ck s)})
`provided` getState (not . null . ck . registerState)
o -> synViol
unless (i=='C') $ modRegisterState $ \s -> s{cp=False}
singleCond :: CTPL0 Bool
singleCond = do
i <- getInstr `provided` liftM not endOfInstr
case i of
'U' -> getState $ isUpper . thisChar . bufferState
'L' -> getState $ isLower . thisChar . bufferState
'z' -> getState $ (==0) . sx . registerState
't' -> return True
'N' -> getState $ isDigit . thisChar . bufferState
'e' -> getState $ null . rightPending . bufferState
'!' -> liftM not singleCond
'|' -> liftM2 (||) singleCond singleCond
'&' -> liftM2 (&&) singleCond singleCond
'q' -> do
ch <- getInstr `provided` liftM not endOfInstr
getState $ (==ch) . thisChar . bufferState
'l' -> do
cp <- getCP
getState $ (cp <) . fromIntegral . sx . registerState
'g' -> do
cp <- getCP
getState $ (cp >) . fromIntegral . sx . registerState
'E' -> do
cp <- getCP
getState $ (cp ==) . fromIntegral . sx . registerState
'C' -> do
sxp <- getState $ cp . registerState
if sxp
then modRegisterState (\s -> s{cp=False})
else modRegisterState (\s -> s{cp=True})
`provided` getState (not . null . ck . registerState)
singleCond
'=' -> liftM2 (==)
(getState $ ax . registerState)
(getState $ fromIntegral . head . ck . registerState)
`provided` getState (not . null . ck . registerState)
'<' -> liftM2 (<)
(getState $ ax . registerState)
(getState $ fromIntegral . head . ck . registerState)
`provided` getState (not . null . ck . registerState)
'>' -> liftM2 (>)
(getState $ ax . registerState)
(getState $ fromIntegral . head . ck . registerState)
`provided` getState (not . null . ck . registerState)
'k' -> do
modRegisterState (\s -> s{ck=tail $ ck s})
`provided` getState (not . null . ck . registerState)
singleCond
o -> synViol
procInstrs :: CTPL0 ()
procInstrs = singleInstr `asLongAs` liftM not endOfInstr
where asLongAs act test = do
b <- test
when b $ act >> asLongAs act test
evalCTPL0' :: String -> String -> Int -> Exec (String, Int, Integer, Int, [] (Char, Int))
evalCTPL0' program buffer limit =
let state0 = CTPL0State buffer0 program0 register0 info0
buffer0
| null buffer = BufferState [] (chr 3) []
| otherwise = BufferState [] (head buffer) (tail buffer ++ [chr 3])
program0
| null program = BufferState [] (chr 3) []
| otherwise = BufferState [] (head program) (tail program ++ [chr 3])
register0 = RegisterState 0 [] [length program] [0] False
info0 = InfoState EmptyAVL
imprf avl = sortBy (\b a -> snd a `compare` snd b) $ avlInorder avl
in case runCTPL0 procInstrs limit state0 of
Succ (_, CTPL0State b p r f, i) -> Succ (unetx (reverse (leftBehind b) ++ [thisChar b] ++ rightPending b), i, ax r, head $ ck r, imprf $ instrStats f)
ConfViol -> ConfViol
SynViol -> SynViol
Expired -> Expired
evalCTPL0 :: String -> String -> Int -> Exec String
evalCTPL0 program buffer limit =
case evalCTPL0' program buffer limit of
Succ (s,_,_,_,_) -> Succ s
ConfViol -> ConfViol
SynViol -> SynViol
Expired -> Expired
unetx :: String -> String
unetx [] = []
unetx s
| s == [chr 3] = []
| last s == chr 3 = init s
| otherwise = s
appendBeforeETX :: String -> String -> String
appendBeforeETX [] t = t
appendBeforeETX s t
| s == [chr 3] = t++[chr 3]
| last s == chr 3 = init s ++ t ++ [chr 3]
| otherwise = s ++ t