summaryrefslogtreecommitdiff
path: root/Text/CTPL0.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Text/CTPL0.hs')
-rw-r--r--Text/CTPL0.hs95
1 files changed, 88 insertions, 7 deletions
diff --git a/Text/CTPL0.hs b/Text/CTPL0.hs
index fe57583..f2a4c66 100644
--- a/Text/CTPL0.hs
+++ b/Text/CTPL0.hs
@@ -1,15 +1,64 @@
-module Text.CTPL0 where
+-- | The old CTPL0 virtual machine. This one is outdated, but will still be supported for a while.
+module Text.CTPL0 (Exec(..), CTPL0(..), CTPL0State(..), BufferState(..), RegisterState(..), InfoState(..), unetx, endOfInstr, singleInstr, procInstrs, evalCTPL0', evalCTPL0) where
+
+import Control.Applicative
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
+-- | A character buffer. Represented as a triplet of left behind chars, the current char and the pending chars.
+data BufferState = BufferState {
+ leftBehind :: String, -- ^ Already seen. String reversed!
+ thisChar :: Char, -- ^ The current char.
+ rightPending :: String -- ^ The pending chars.
+ }
+
+-- | A record for register and stack state.
+data RegisterState = RegisterState {
+ ax :: Integer, -- ^ Accumulator register (AX)
+ mk :: [String], -- ^ Tape stack (MK)
+ rk :: [Int], -- ^ Return address stack (RK)
+ ck :: [Int], -- ^ Number stack (CK). The top element may be used like a register.
+ cp :: Bool -- ^ If set, the next instruction will use the top element of CK instead of AX. (Say: ``SX is CK top'' in contrast to ``SX is AX'')
+ }
+
+-- | A statistics record (might be used by a profiler some time in future...)
+data InfoState = InfoState {
+ instrStats :: AVL (Char, Int) -- ^ Statistics on how often each instruction has been executed.
+ }
+
+-- | The overall state record.
+data CTPL0State = CTPL0State {
+ bufferState :: BufferState, -- ^ Tape buffer.
+ programState :: BufferState, -- ^ Program buffer.
+ registerState :: RegisterState, -- ^ Register state record.
+ infoState :: InfoState -- ^ Statistics record.
+ }
+
+-- | Monad displaying success or failure.
+data Exec a = Succ a -- ^ Execution succeeded :)
+ | Expired -- ^ Nope. Time has expired. Program took too long to finish. You might want to increase time limit.
+ | ConfViol -- ^ Nope. Confidence violation. This may have several reasons, e.g. popping from an empty stack, jumping out of program bounds, ...
+ | SynViol -- ^ Nope. Syntax violation. I encountered an instruction (or condition) I do not understand.
+ deriving Show
+
+instance Monad Exec where
+ return = Succ
+ (Succ a) >>= f = f a
+ Expired >>= f = Expired
+ ConfViol >>= f = ConfViol
+ SynViol >>= f = SynViol
+
+instance Applicative Exec where
+ pure = return
+ (<*>) = ap
+
+instance Functor Exec where
+ fmap = liftM
+
+-- | The VM's execution monad. Behaves like a 'StateT' carrying a 'CTPL0State' wrapped around the 'Exec' monad. Also responsible for time consumption and passing.
newtype CTPL0 a = CTPL0 { runCTPL0 :: Int -> CTPL0State -> Exec (a, CTPL0State, Int) }
instance Monad CTPL0 where
@@ -21,45 +70,64 @@ instance Monad CTPL0 where
ConfViol -> ConfViol
SynViol -> SynViol
+instance Applicative CTPL0 where
+ pure = return
+ (<*>) = ap
+
+instance Functor CTPL0 where
+ fmap = liftM
+
+-- | Gets the carried 'CTPL0State' and runs a function on it.
getState :: (CTPL0State -> a) -> CTPL0 a
getState f = CTPL0 $ \i k -> Succ (f k, k, i)
+-- | Runs a function on the carried 'CTPL0State'.
modState :: (CTPL0State -> CTPL0State) -> CTPL0 ()
modState f = CTPL0 $ \i k -> Succ ((), f k, i)
+-- | Consume virtual time. Raise 'Expired' if limit is reached.
consumeTime :: CTPL0 ()
consumeTime = CTPL0 $ \i k -> if i >= 1 then Succ ((), k, i-1) else Expired
+-- | Raise a 'ConfViol'.
confViol :: CTPL0 a
confViol = CTPL0 $ \_ _ -> ConfViol
+-- | Raise a 'SynViol'.
synViol :: CTPL0 a
synViol = CTPL0 $ \_ _ -> SynViol
+-- | Modify the tape buffer`s state by running a function on it.
modBufferState :: (BufferState -> BufferState) -> CTPL0 ()
modBufferState f = modState $ \s -> s{bufferState = f $ bufferState s}
+-- | Modify the program buffer`s state by running a function on it.
modProgramState :: (BufferState -> BufferState) -> CTPL0 ()
modProgramState f = modState $ \s -> s{programState = f $ programState s}
+-- | Modify the register state record by running a function on it.
modRegisterState :: (RegisterState -> RegisterState) -> CTPL0 ()
modRegisterState f = modState $ \s -> s{registerState = f $ registerState s}
+-- | Walk in the buffer. A positive number specifies walking to the right, a negative one to the left.
walkBuffer :: Int -> BufferState -> BufferState
walkBuffer 0 s = s
walkBuffer i s
| i < 0 = BufferState (drop (-i) $ leftBehind s) (head $ drop (-i-1) $ leftBehind s) (reverse (take (-i-1) $ leftBehind s) ++ [thisChar s] ++ rightPending s)
| i > 0 = BufferState (reverse (take (i-1) (rightPending s)) ++ [thisChar s] ++ leftBehind s) (head $ drop (i-1) $ rightPending s) (drop i $ rightPending s)
+-- | Fetch the next instruction.
getInstr :: CTPL0 Char
getInstr = do
k <- getState $ thisChar . programState
modProgramState $ walkBuffer 1
return k
+-- | Have we reached the end of the program tape?
endOfInstr :: CTPL0 Bool
endOfInstr = getState $ null . rightPending . programState
+-- | Fetch numeric argument (as many digits as we can get)
instrNumArg :: CTPL0 Int
instrNumArg = do
ks <- getState $ \s -> takeWhile isDigit (thisChar (programState s) : rightPending (programState s))
@@ -67,6 +135,7 @@ instrNumArg = do
modProgramState $ walkBuffer $ length ks
return $ read ks
+-- | Fetch string argument (delimited by '$')
instrDelimArg :: CTPL0 String
instrDelimArg = do
ks <- getState $ \s -> takeWhile (/='$') (thisChar (programState s) : rightPending (programState s))
@@ -76,24 +145,29 @@ instrDelimArg = do
modProgramState $ walkBuffer 1
return ks
+-- | Get position in program buffer.
getIP :: CTPL0 Int
getIP = getState $ length . leftBehind . programState
+-- | Get position in tape buffer.
getCP :: CTPL0 Int
getCP = getState $ length . leftBehind . bufferState
+-- | Are we able to walk that far in the program buffer?
canRelJump :: Int -> CTPL0 Bool
canRelJump 0 = return True
canRelJump i
| i < 0 = getState $ (>= -i) . length . leftBehind . programState
| i > 0 = getState $ (>= i) . length . rightPending . programState
+-- | Are we able to walk that far in the tape buffer?
canRelWalk :: Int -> CTPL0 Bool
canRelWalk 0 = return True
canRelWalk i
| i < 0 = getState $ (>= -i) . length . leftBehind . bufferState
| i > 0 = getState $ (>= i) . length . rightPending . bufferState
+-- | Run an action (first arg) iff the test (second arg) succeeds. Raise 'ConfViol' otherwise.
provided :: CTPL0 a -> CTPL0 Bool -> CTPL0 a
provided act test = do
b <- test
@@ -101,15 +175,17 @@ provided act test = do
then act
else confViol
--- SX points to AX by default, but to CK(0) after 'C'
+-- | SX is AX by default, but CK top after `C'
sx :: RegisterState -> Integer
sx r | cp r = fromIntegral $ head $ ck r
sx r = ax r
+-- | Set SX (AX or CK top) value.
setSX :: Integer -> RegisterState -> RegisterState
setSX i r | cp r = r{ck=fromIntegral i : tail (ck r)}
setSX i r = r{ax=i}
+-- | Run the next instruction in program.
singleInstr :: CTPL0 ()
singleInstr = do
i <- getInstr
@@ -314,12 +390,14 @@ singleCond = do
-- Catch others
o -> synViol
+-- | Run the entire program.
procInstrs :: CTPL0 ()
procInstrs = singleInstr `asLongAs` liftM not endOfInstr
where asLongAs act test = do
b <- test
when b $ act >> asLongAs act test
+-- | A handy wrapper around 'procInstrs'. Arguments: program, tape, time limit. Results: tape, leftover time, AX, CK top, instruction stats.
evalCTPL0' :: String -> String -> Int -> Exec (String, Int, Integer, Int, [] (Char, Int))
evalCTPL0' program buffer limit =
let state0 = CTPL0State buffer0 program0 register0 info0
@@ -338,6 +416,7 @@ evalCTPL0' program buffer limit =
SynViol -> SynViol
Expired -> Expired
+-- | Another handy wrapper around 'procInstr'. Less clumsy than 'evalCTPL0'', but provides less information. Arguments: program, tape, time limit. Results: tape only.
evalCTPL0 :: String -> String -> Int -> Exec String
evalCTPL0 program buffer limit =
case evalCTPL0' program buffer limit of
@@ -346,6 +425,7 @@ evalCTPL0 program buffer limit =
SynViol -> SynViol
Expired -> Expired
+-- | Remove a trailing ETX (if there is one).
unetx :: String -> String
unetx [] = []
unetx s
@@ -353,6 +433,7 @@ unetx s
| last s == chr 3 = init s
| otherwise = s
+-- | Append right before the trailing ETX. If there is no ETX, string will be appended at the end.
appendBeforeETX :: String -> String -> String
appendBeforeETX [] t = t
appendBeforeETX s t