diff options
Diffstat (limited to 'Text')
| -rw-r--r-- | Text/CTPL.hs | 105 | ||||
| -rw-r--r-- | Text/CTPL0.hs | 95 | ||||
| -rw-r--r-- | Text/CTPL0n.hs | 581 |
3 files changed, 749 insertions, 32 deletions
diff --git a/Text/CTPL.hs b/Text/CTPL.hs index 6ca1f66..34f6869 100644 --- a/Text/CTPL.hs +++ b/Text/CTPL.hs @@ -1,5 +1,8 @@ +-- | Compiler for CTPL, generating CTPL0 code. + module Text.CTPL where +import Control.Applicative hiding (many, Const, some) import Control.Monad import Data.Char import Data.Monoid @@ -7,10 +10,35 @@ import Text.Chatty.Parser import Text.Chatty.Parser.Carrier import qualified Text.CTPL0 as Null -data Procedure = Procedure { procName :: String, procInstr :: Instruction, procAddr :: Int } -data CTPLState = CTPLState { definedProcs :: [Procedure] } -data Exec a = Succ a | NoSuchProc String | SyntaxFault deriving Show -data CTPL a = CTPL { runCTPL :: CTPLState -> Exec (a, CTPLState, String -> String) } +-- | Compiler configuration. +data CCConfig = CCConfig { + ccTarget :: CCTarget -- ^ Target VM + } + +-- | Target VM +data CCTarget = OldVM -- ^ produce output compatible with the old VM (Text.CTPL0) + | NewVM -- ^ produce output for the new VM only (Text.CTPL0n) + +-- | A parsed CTPL procedure. +data Procedure = Procedure { + procName :: String, -- ^ Name of the procedure + procInstr :: Instruction, -- ^ Instructions + procAddr :: Int -- ^ Address (if already known) + } + +-- | Compiler state record +data CTPLState = CTPLState { + definedProcs :: [Procedure] -- ^ Procedure already encountered + } + +-- | Monad displaying success or failure. +data Exec a = Succ a -- ^ Compilation succeeded :) + | NoSuchProc String -- ^ Nope. Encountered a call to a procedure I can`t find. + | SyntaxFault -- ^ Nope. Syntax fault. I have no idea what you`re trying to tell me. + deriving Show + +-- | The compiler's execution monad. Behaves like a 'StateT CTPLState' wrapped around a 'ReaderT CCConfig' wrapped around a 'WriterT String' wrapped around the 'Exec' monad. +data CTPL a = CTPL { runCTPL :: CTPLState -> CCConfig -> Exec (a, CTPLState, String -> String) } instance Monad Exec where return a = Succ a @@ -18,37 +46,61 @@ instance Monad Exec where (NoSuchProc s) >>= f = NoSuchProc s SyntaxFault >>= f = SyntaxFault +instance Applicative Exec where + pure = return + (<*>) = ap + +instance Functor Exec where + fmap = liftM + instance Monad CTPL where - return a = CTPL $ \s -> return (a, s, id) - m >>= f = CTPL $ \s -> do - (a', s', f') <- runCTPL m s - (a'', s'', f'') <- runCTPL (f a') s' + return a = CTPL $ \s cfg -> return (a, s, id) + m >>= f = CTPL $ \s cfg -> do + (a', s', f') <- runCTPL m s cfg + (a'', s'', f'') <- runCTPL (f a') s' cfg return (a'', s'', f' . f'') +instance Applicative CTPL where + pure = return + (<*>) = ap + +instance Functor CTPL where + fmap = liftM + +-- | Predefined compiler configuration. Generated code is compatible to both VMs. +oldConfig :: CCConfig +oldConfig = CCConfig{ccTarget=OldVM} + +-- | Predefined compiler configuration. Generated code is compatible to the new VM only. +newConfig :: CCConfig +newConfig = CCConfig{ccTarget=NewVM} + +-- | Gets the carried 'CTPLState' and runs a function on it. getState :: (CTPLState -> a) -> CTPL a -getState f = CTPL $ \s -> return (f s, s, id) +getState f = CTPL $ \s cfg -> return (f s, s, id) +-- | RUns a function on the carried 'CTPLState'. modState :: (CTPLState -> CTPLState) -> CTPL () -modState f = CTPL $ \s -> return ((), f s, id) +modState f = CTPL $ \s cfg -> return ((), f s, id) emit :: String -> CTPL () -emit str = CTPL $ \s -> return ((), s, (str++)) +emit str = CTPL $ \s cfg -> return ((), s, (str++)) getProc :: String -> (Procedure -> a) -> CTPL a getProc nm f = do ps <- getState definedProcs case filter (\p -> procName p == nm) ps of - [] -> CTPL $ \_ -> NoSuchProc nm + [] -> CTPL $ \_ _ -> NoSuchProc nm [p] -> return (f p) catchEmission :: CTPL () -> CTPL String -catchEmission m = CTPL $ \s -> do - (_,s',f') <- runCTPL m s +catchEmission m = CTPL $ \s cfg -> do + (_,s',f') <- runCTPL m s cfg return (f' [], s', id) discardEmission :: CTPL a -> CTPL a -discardEmission m = CTPL $ \s -> do - (a,s',_) <- runCTPL m s +discardEmission m = CTPL $ \s cfg -> do + (a,s',_) <- runCTPL m s cfg return (a, s', id) data NumSource = AX Int | CK0 Int | Buf NumSource Int | Const Int | Len Int | CP Int deriving Show @@ -290,10 +342,10 @@ dumpCond cond jumper = case cond of -- Cd[ldbuf]Cmkj|q#!t EqCh d chs -> emit "Cd" >> dumpInstr (SetCK0 d) >> emit "Cmk" >> emit jumper >> emit (foldr q "!t" chs) >> return "" where q a b = "|q"++[a]++b -compile :: [Procedure] -> Instruction -> Exec String -compile ps main = do +compile :: [Procedure] -> Instruction -> CCConfig -> Exec String +compile ps main cfg = do let s0 = CTPLState (ps++[Procedure [] main 0]) - (_, _, out) <- flip runCTPL s0 $ do + (_, _, out) <- runCTPL (do ps <- getState definedProcs ps' <- allocProcs 7 ps modState $ \s -> s{definedProcs=ps'} @@ -301,7 +353,7 @@ compile ps main = do emit "+" dumpAddr amain emit "jt" - forM_ ps' $ \p -> dumpInstr $ procInstr p + forM_ ps' $ \p -> dumpInstr $ procInstr p) s0 cfg return $ out [] multiParse :: ChParser m => m ([Procedure], [Instruction]) @@ -549,15 +601,18 @@ parseCond = parseNot ??? parseIsLower ??? parseEq ??? parseEqCh ??? parseLt ??? return $ EqCh ns chs parse :: String -> [] ([Procedure], [Instruction]) -parse s = runCarrierT s multiParse +parse s = runCarrierT s $ do + p <- multiParse + many white + return p -compileCTPL :: String -> Exec String -compileCTPL s = case parse s of +compileCTPL :: String -> CCConfig -> Exec String +compileCTPL s cfg = case parse s of [] -> SyntaxFault - (ps, is):_ -> compile ps (Compound is) + (ps, is):_ -> compile ps (Compound is) cfg evalCTPL :: String -> String -> Int -> Null.Exec String evalCTPL program buffer limit = - case compileCTPL program of + case compileCTPL program oldConfig of Succ bc -> Null.evalCTPL0 bc buffer limit _ -> Null.SynViol 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 diff --git a/Text/CTPL0n.hs b/Text/CTPL0n.hs new file mode 100644 index 0000000..8614b2a --- /dev/null +++ b/Text/CTPL0n.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE TupleSections, FlexibleInstances #-} + +-- | The new CTPL0 virtual machine. + +module Text.CTPL0n where + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.ST +import Data.Array.MArray as M +import Data.Array.ST +import Data.Array.Unboxed +import Data.Char +import Data.List +import Data.STRef + +-- | The VM`s state record. +data CTPL0State s = CTPL0State { + bufferContent :: !(Buffer s), -- ^ Tape buffer + programContent :: UArray Int Char, -- ^ Program buffer + bufferPointer :: !Int, -- ^ Tape pointer + programPointer :: !Int, -- ^ Program pointer + 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'') + ax :: !Int, -- ^ Accumulator register (AX) + mk :: [Buffer s], -- ^ Tape stack (MK) + rk :: [Int], -- ^ Return address stack (RK) + ck :: [Int] -- ^ Number stack (CK). The top element may be used like a register. + } + +-- | The VM`s configuration. Immutable during execution. +data VMConfig = VMConfig { + maxTime :: !Int, -- ^ Initial time limit. + maxConditRecurs :: !Int, -- ^ Maximum recursion depth for `x' condition (FUTURE) + maxBufferMeasure :: !Int, -- ^ Maximum buffer size (FUTURE) + initBufferMeasure :: !Int, -- ^ Initial buffer size. + vmFeatures :: [VMFeature] -- ^ Enabled feature instructions. + } + +-- | Optional feature instructions. +data VMFeature = RandomF -- ^ enable `Xr' instruction for random number retrieval (FUTURE) + | FilterF -- ^ enable `Xfs', `Xfd', `Xff' instructions for setting predefined filters on the tape (FUTURE) + | CustomFilterF -- ^ enable `Xfc' instruction for setting custom filters on the tape (FUTURE; won't work without FilterF) + | InterruptsF -- ^ enable `Xi' instruction for setting and calling interrupts (FUTURE) + +-- | Predefined VM configuration, very restrictive. Allows 10000 cycles, no recursive conditions, no feature instructions, at maximum 3000 chars on tape. +safeVM :: VMConfig +safeVM = VMConfig{ maxTime=10000, maxConditRecurs=0, + maxBufferMeasure=3000, initBufferMeasure=0, + vmFeatures=[] } + +-- | Predefined VM configuration, very permissive. Allows 10 million cycles, 10 levels of recursion, all available feature instructions, at maximum 30000 chars on tape. +fullVM :: VMConfig +fullVM = VMConfig{ maxTime=10000000, maxConditRecurs=10, + maxBufferMeasure=30000, initBufferMeasure=0, + vmFeatures=[RandomF, FilterF, CustomFilterF, InterruptsF] } + +-- | Monad displaying success or failure. A close relative of the 'Either' monad. +data Exec a = Succ a -- ^ Execution succeeded :) + | Fail !Fail -- ^ Nope. See 'Fail' type. + +instance Monad Exec where + return = Succ + fail = Fail . Dead + (Succ a) >>= f = f a + (Fail e) >>= f = Fail e + +instance Applicative Exec where + pure = return + (<*>) = ap + +instance Functor Exec where + fmap = liftM + +-- | Possible errors. +data Fail = Expired -- ^ Time has expired. Program took too long to finish. You might want to increase time limit. + | ConfViol -- ^ Confidence violation. This may have several reasons, e.g. popping from an empty stack, jumping out of program bounds, ... + | SynViol -- ^ Syntax violation. I encountered an instruction (or condition) I do not understand. + | Dead String -- ^ Program requested abort (FUTURE) + +-- | The VM's execution monad. Behaves like a 'ReaderT' carrying a 'CTPL0State' reference and a 'VMConfig' wrapped around the 'ST' and the 'Exec' monad. Also responsible for time consumption and passing. +newtype CTPL0 s a = CTPL0 { runCTPL0 :: Int -> + STRef s (CTPL0State s) -> + VMConfig -> + ST s (Exec (a, Int)) } + +-- | A tape buffer, implemented by wrapping modifiers around a mutable array. +data Buffer s = Insertion { insPlace :: !Int, insLength :: !Int, insContent :: String, insNext :: Buffer s } -- ^ Character insertion + | Deletion { delPlace :: !Int, delLength :: !Int, delNext :: Buffer s } -- ^ Character deletion + | MBuffer { bufArray :: STUArray s Int Char } -- ^ The core: the mutable array + +instance Show Fail where + show Expired = "<Fatal: Time expired.>" + show ConfViol = "<Fatal: Confidence violation.>" + show SynViol = "<Fatal: Syntax violation.>" + show (Dead s) = "<Error: "++s++">" + +instance Show (Exec String) where + show (Succ a) = a + show (Fail f) = show f + +-- | Read a char from a tape buffer. +readBuffer :: Buffer s -> Int -> ST s Char +readBuffer (MBuffer a) i = readArray a i +readBuffer (Insertion p l c n) i + | i < p = readBuffer n i + | i >= p+l = readBuffer n (i-l) + | otherwise = return (c !! (i-p)) +readBuffer (Deletion p l n) i + | i < p = readBuffer n i + | otherwise = readBuffer n (i+l) + +-- | Write a char to the tape buffer. +writeBuffer :: Buffer s -> Int -> Char -> ST s (Buffer s) +writeBuffer (MBuffer a) i e = writeArray a i e >> return (MBuffer a) +writeBuffer (Insertion p l c n) i e + | i < p = Insertion p l c <$> writeBuffer n i e + | i >= p+l = Insertion p l c <$> writeBuffer n (i-l) e + | otherwise = return $ Insertion p l (take (i-p) c ++ [e] ++ drop (i-p+1) c) n +writeBuffer (Deletion p l n) i e + | i < p = Deletion p l <$> writeBuffer n i e + | otherwise = Deletion p l <$> writeBuffer n (i+l) e + +-- | Is the given position accessible in the tape buffer? +accBuffer :: Buffer s -> Int -> ST s Bool +accBuffer (MBuffer a) i = do + b <- M.getBounds a + return (snd b >= i) +accBuffer (Insertion p l c n) i + | i < p = accBuffer n i + | i >= p+l = accBuffer n (i-l) + | otherwise = return True +accBuffer (Deletion p l n) i + | i < p = accBuffer n i + | otherwise = accBuffer n (i+l) + +-- | Join the tape buffer to a string. +joinBuffer :: Buffer s -> ST s String +joinBuffer (MBuffer a) = M.getElems a +joinBuffer (Insertion p l c n) = do + nb <- joinBuffer n + let (a,b) = splitAt p nb + return (a ++ c ++ b) +joinBuffer (Deletion p l n) = do + nb <- joinBuffer n + let (a,b) = splitAt p nb + return (a ++ drop l b) + +-- | Insert a string into the tape buffer. +insBuffer :: Buffer s -> Int -> String -> ST s (Buffer s) +insBuffer (MBuffer a) i e = return $ Insertion i (length e) e (MBuffer a) +insBuffer (Insertion p l c n) i e + | i < p = Insertion (p+length e) l c <$> insBuffer n i e + | i >= p+l = Insertion p l c <$> insBuffer n (i-l) e + | i >= p && (i+length e) <= p+l = + return $ Insertion p (l+length e) (a++e++b) n + | otherwise = return $ Insertion i (length e) e $ Insertion p l c n + where (a,b) = splitAt (i-p) c +insBuffer (Deletion p l n) i e + | i < p = Deletion (p+length e) l <$> insBuffer n i e + | i > p = Deletion p l <$> insBuffer n (i+l) e + | otherwise = return $ Insertion i (length e) e $ Deletion p l n + +-- | Delete a char from the tape buffer. +delBuffer :: Buffer s -> Int -> ST s (Buffer s) +delBuffer (MBuffer a) i = return $ Deletion i 1 $ MBuffer a +delBuffer (Insertion p l c n) i + | i < p = Insertion (p-1) l c <$> delBuffer n i + | i >= p+l = Insertion p l c <$> delBuffer n (i-l) + | otherwise = return $ Insertion p (l-1) (a++b) n + where (a,_:b) = splitAt (i-p) c +delBuffer (Deletion p l n) i + | i < p = Deletion (p-1) l <$> delBuffer n i + | i > p = Deletion p l <$> delBuffer n (i+l) + | otherwise = return $ Deletion p (l+1) n + +-- | Get a list of ETX positions in the tape buffer. +etxBuffer :: Buffer s -> ST s [Int] +etxBuffer (MBuffer a) = do + es <- M.getElems a + return $ elemIndices '\3' es +etxBuffer (Insertion p l c n) = do + ne <- etxBuffer n + let ie = elemIndices '\3' c + return $ sort (map (+p) ie ++ map (\ne' -> if ne' < p then ne' else ne' + l) ne) +etxBuffer (Deletion p l n) = do + ne <- etxBuffer n + return $ map (\ne -> if ne < p then ne else ne-l) $ filter (/=p) ne + +-- | Clone the tape buffer (fixing all modifiers into the newly created mutable array) +cloneBuffer :: Buffer s -> ST s (Buffer s) +cloneBuffer b = do + s <- joinBuffer b + a <- M.newListArray (0, length s - 1) s + return $ MBuffer a + +-- | Get the tape buffer`s length. +measBuffer :: Buffer s -> ST s Int +measBuffer (MBuffer a) = snd <$> M.getBounds a +measBuffer (Insertion p l c n) = (+l) <$> measBuffer n +measBuffer (Deletion p l n) = subtract l <$> measBuffer n + +instance Monad (CTPL0 s) where + return a = CTPL0 $ \i ref cfg -> return $ Succ (a,i) + m >>= f = CTPL0 $ \i ref cfg -> do + r <- runCTPL0 m i ref cfg + case r of + Succ (a, i') -> runCTPL0 (f a) i' ref cfg + Fail f -> return $ Fail f + +instance Functor (CTPL0 s) where + fmap = liftM + +instance Applicative (CTPL0 s) where + pure = return + (<*>) = ap + +-- | Run an 'ST' action inside a compatible 'CTPL0' block +liftST :: ST s a -> CTPL0 s a +liftST m = CTPL0 $ \i ref cfg -> Succ <$> (,i) <$> m + +-- | A handy wrapper around 'procInstrs'. Arguments: program, tape, config. Results: tape, leftover time, AX, CK top. +evalCTPL0' :: String -> String -> VMConfig -> Exec (String, Int, Int, Int) +evalCTPL0' program buffer cfg = runST $ do + let limit = maxTime cfg + bufsize = max (initBufferMeasure cfg) (length buffer+1) + bc <- newListArray (0, bufsize-1) (buffer ++ '\3' : replicate (bufsize-length buffer-1) '\0') + let pc = listArray (0, length program - 1) program + st = CTPL0State (MBuffer bc) pc 0 0 False 0 [] [length program] [0] + ref <- newSTRef st + r <- runCTPL0 procInstrs limit ref cfg{initBufferMeasure=bufsize} + case r of + Succ (_, i') -> do + st <- readSTRef ref + buf <- joinBuffer (bufferContent st) + return $ Succ (takeWhile (/='\3') buf, i', ax st, if null (ck st) then 0 else head $ ck st) + Fail f -> return $ Fail f + +-- | Another handy wrapper around 'procInstrs'. Less clumsy than 'evalCTPL0'', but provides less information. Arguments: program, tape, config. Results: tape only. +evalCTPL0 :: String -> String -> VMConfig -> Exec String +evalCTPL0 program buffer cfg = + case evalCTPL0' program buffer cfg of + Succ (s,_,_,_) -> Succ s + Fail f -> Fail f + +-- | Gets the carried 'CTPL0State' and runs a function on it. +getState :: (CTPL0State s -> a) -> CTPL0 s a +getState f = + CTPL0 $ \i ref cfg -> do + st <- readSTRef ref + return $ Succ (f st, i) + +-- | Runs a function on the carried 'CTPL0State'. +modState :: (CTPL0State s -> CTPL0State s) -> CTPL0 s () +modState f = + CTPL0 $ \i ref cfg -> do + modifySTRef ref f + return $ Succ ((), i) + +-- | Consume virtual time. Raise 'Expired' if limit is reached. +consumeTime :: CTPL0 s () +consumeTime = CTPL0 $ \i ref cfg -> if i >= 1 then return (Succ ((), i-1)) else return (Fail Expired) + +-- | Raise a 'ConfViol'. +confViol :: CTPL0 s a +confViol = CTPL0 $ \_ _ _ -> return $ Fail ConfViol + +-- | Raise a 'SynViol'. +synViol :: CTPL0 s a +synViol = CTPL0 $ \_ _ _ -> return $ Fail SynViol + +-- | Raise a 'Dead'. +die :: String -> CTPL0 s a +die s = CTPL0 $ \_ _ _ -> return . Fail $ Dead s + +-- | Fetch the next instruction. +getInstr :: CTPL0 s Char +getInstr = do + (c,p) <- getState (programContent &&& programPointer) + modState (\st -> st{programPointer=programPointer st+1}) + return (c ! p) + +-- | Have we reached the end of the program tape? +endOfInstr :: CTPL0 s Bool +endOfInstr = do + (m,p) <- getState (snd . bounds . programContent &&& programPointer) + return (m < p) + +-- | Fetch numeric argument (as many digits as we can get) +instrNumArg :: CTPL0 s Int +instrNumArg = do + (c,p) <- getState (programContent &&& programPointer) + if snd (bounds c) <= p || not (isDigit (c!p)) then synViol else + let coll p | snd (bounds c) <= p = "" + coll p | not (isDigit (c!p)) = "" + coll p = (c!p) : coll (p+1) + str = coll p + in do + modState $ \st -> st{programPointer=programPointer st+length str} + return $ read str + +-- | Fetch string argument (delimited by '$') +instrDelimArg :: CTPL0 s String +instrDelimArg = do + (c,p) <- getState (programContent &&& programPointer) + if snd (bounds c) < p then synViol else + let coll p | snd (bounds c) < p = "" + coll p | (c!p) == '$' = "$" + coll p = (c!p) : coll (p+1) + str = coll p + in do + modState $ \st -> st{programPointer=programPointer st+length str} + unless (last str == '$') synViol + return $ init str + +-- | Run an action (first arg) iff the test (second arg) succeeds. Raise 'ConfViol' otherwise. +provided :: CTPL0 s a -> CTPL0 s Bool -> CTPL0 s a +provided act test = do + b <- test + if b + then act + else confViol + +-- | SX is AX by default, but CK top after 'C'. +sx :: CTPL0State s -> Int +sx r | cp r = head $ ck r +sx r = ax r + +-- | Set SX (AX or CK top) value. +setSX :: Int -> CTPL0State s -> CTPL0State s +setSX i r | cp r = if null (ck r) then r{ck=[i]} else r{ck=i:tail (ck r)} +setSX i r = r{ax=i} + +-- | Run the next instruction in program. +singleInstr :: CTPL0 s () +singleInstr = do + i <- getInstr + consumeTime + case i of + -- Walk left + '<' -> modState (\st -> st{bufferPointer=bufferPointer st-1}) + `provided` getState (\st -> bufferPointer st > 0) + -- Walk right + '>' -> modState (\st -> st{bufferPointer=bufferPointer st+1}) + `provided` do + (p,c) <- getState (bufferPointer &&& bufferContent) + liftST $ accBuffer c (p+1) + + -- Inc SX + '+' -> do + num <- instrNumArg + modState $ \st -> setSX (sx st + num) st + -- Dec SX + '-' -> do + num <- instrNumArg + modState $ \st -> setSX (sx st - num) st + -- Insert char, go after + 'i' -> do + ch <- getInstr `provided` liftM not endOfInstr + (p,c) <- getState (bufferPointer &&& bufferContent) + c' <- liftST $ insBuffer c p [ch] + modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st + 1} + -- Insert string, go after + 'I' -> do + str <- instrDelimArg + (p,c) <- getState (bufferPointer &&& bufferContent) + c' <- liftST $ insBuffer c p str + modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st + length str} + -- Replace char, stay + 'r' -> do + ch <- getInstr `provided` liftM not endOfInstr + (p,c) <- getState (bufferPointer &&& bufferContent) + c' <- liftST $ writeBuffer c p ch + modState $ \st -> st{bufferContent=c'} + -- Delete char + 'x' -> do + (p,c) <- getState (bufferPointer &&& bufferContent) + c' <- liftST $ delBuffer c p + modState $ \st -> st{bufferContent=c'} + -- Append char, don't walk + 'a' -> do + ch <- getInstr `provided` liftM not endOfInstr + (p,c) <- getState (bufferPointer &&& bufferContent) + etx <- liftST $ etxBuffer c + case etx of + [] -> confViol + etx:_ -> do + c' <- liftST $ writeBuffer c etx ch + c'' <- liftST $ writeBuffer c' (etx+1) '\3' + modState $ \st -> st{bufferContent=c''} + when (etx<p) $ modState $ \st -> st{bufferPointer=bufferPointer st + 1} + -- Append string, don't walk + 'A' -> do + str <- instrDelimArg + (p,c) <- getState (bufferPointer &&& bufferContent) + etx <- liftST $ etxBuffer c + case etx of + [] -> confViol + etx:_ -> do + (c',etx') <- foldl (\l r -> do (c,etx) <- l; c' <- liftST $ writeBuffer c etx r; return (c,etx+1)) (return (c,etx)) str + c'' <- liftST $ writeBuffer c' etx' '\3' + modState $ \st -> st{bufferContent=c''} + when (etx<p) $ modState $ \st -> st{bufferPointer=bufferPointer st + 1} + -- Set SX=0 + '0' -> do + modState $ setSX 0 + -- Set SX=CP + 'Q' -> do + modState $ \st -> setSX (bufferPointer st) st + -- Set CP=SX + 'm' -> do + modState (\st -> st{bufferPointer=sx st}) `provided` do + (c,s) <- getState (bufferContent &&& sx) + liftST $ accBuffer c s + -- Choose CK(0) for SX + 'C' -> modState (\st -> st{cp=True}) `provided` getState (not . null . ck) + -- Load [CP] into SX + 'l' -> do + (p,c) <- getState (bufferPointer &&& bufferContent) + s <- liftST $ readBuffer c p + modState $ \st -> setSX (ord s) st + -- Save SX into [CP] + 's' -> do + (p,(c,s)) <- getState (bufferPointer &&& bufferContent &&& sx) + c' <- liftST $ writeBuffer c p (chr s) + modState $ \st -> st{bufferContent=c'} + -- Push SX onto CK + 'd' -> modState $ \st -> st{ck=sx st : ck st} + -- Pop AX from CK + 'D' -> modState (\st -> st{ax=head $ ck st, ck=tail $ ck st}) + `provided` getState (not . null . ck) + -- Pop CK, discard + 'k' -> modState (\st -> st{ck=tail $ ck st}) + `provided` getState (not . null . ck) + -- Set SX=LEN + 'L' -> do + c <- getState bufferContent + etx <- liftST $ etxBuffer c + case etx of + [] -> confViol + etx':_ -> modState $ setSX etx' + -- Swap tape and MK(0) + 'H' -> + modState (\st -> st{mk=bufferContent st : tail (mk st), bufferContent=head (mk st)}) + `provided` getState (not . null . mk) + -- Push entire tape to MK + 't' -> do + c <- getState bufferContent + c' <- liftST $ cloneBuffer c + modState $ \st -> st{mk=c' : mk st} + -- Push [CP] to MK + 'y' -> do + (c,p) <- getState (bufferContent &&& bufferPointer) + (ch,len,a) <- liftST $ do + ch <- readBuffer c p + len <- measBuffer c + a <- newListArray (0,len) (ch : '\3' : replicate (len-1) '\0') + return (ch,len,a) + modState $ \st -> st{mk=MBuffer a : mk st} + -- Pop MK, discard content + 'p' -> modState (\st -> st{mk=tail $ mk st}) + `provided` getState (not . null . mk) + -- Append [CP] to MK(0) + 'Y' -> (do + (c,(p,a)) <- getState (bufferContent &&& bufferPointer &&& head . mk) + ch <- liftST $ readBuffer c p + etx <- liftST $ etxBuffer a + case etx of + [] -> confViol + etx':_ -> do + a' <- liftST $ writeBuffer a etx' ch + a'' <- liftST $ writeBuffer a' (etx'+1) '\3' + modState (\st -> st{mk=a'':tail (mk st)})) + `provided` getState (not . null . mk) + -- Peek MK, insert, go after + 'P' -> (do + (c,(p,a)) <- getState (bufferContent &&& bufferPointer &&& head . mk) + js <- liftST $ joinBuffer a + let s = takeWhile (/='\3') js + c' <- liftST $ insBuffer c p s + modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st+length s}) + `provided` getState (not . null . mk) + -- Absolute jump to SX + 'j' -> do + a <- getState sx + b <- singleCond + when b $ modState $ \st -> st{programPointer=a} + -- Relative jump by SX + 'J' -> do + a <- getState sx + b <- singleCond + when b $ modState $ \st -> st{programPointer=a+programPointer st} + -- Call procedure at SX, push IP to RK + 'c' -> do + a <- getState sx + b <- singleCond + when b $ modState $ \st -> st{rk=(programPointer st):rk st, programPointer=a} + -- Return to RK(0), pop RK + 'f' -> (modState $ \st -> st{programPointer=head (rk st), rk=tail (rk st)}) + `provided` getState (not . null . rk) + -- Swap MK(0) and MK(1) + 'h' -> + modState (\st -> st{mk=(mk st !! 1):(mk st !! 0):(drop 2 $ mk st)}) + `provided` getState ((>=2) . length . mk) + -- Catch others + o -> synViol + {-do + ip <- getState programPointer + die ("SynViol in singleInstr: " ++ [o] ++ " (pos "++ show ip++")")-} + unless (i=='C') $ modState $ \st -> st{cp=False} + + +-- | Evaluate a condition. +singleCond :: CTPL0 s Bool +singleCond = do + i <- getInstr `provided` liftM not endOfInstr + case i of + -- Is uppercase? + 'U' -> do + (c, p) <- getState (bufferContent &&& bufferPointer) + isUpper <$> liftST (readBuffer c p) + -- Is lowercase? + 'L' -> do + (c, p) <- getState (bufferContent &&& bufferPointer) + isLower <$> liftST (readBuffer c p) + -- SX = 0? + 'z' -> getState ((==0) . sx) + -- Always true + 't' -> return True + -- Is digit? + 'N' -> do + (c, p) <- getState (bufferContent &&& bufferPointer) + isDigit <$> liftST (readBuffer c p) + -- End of buffer? + 'e' -> do + (c, p) <- getState (bufferContent &&& bufferPointer) + realEnd <- not <$> liftST (accBuffer c (p+1)) + etxEnd <- if realEnd then return '\3' else liftST (readBuffer c p) + return (etxEnd == '\3') + -- Negation + '!' -> not <$> singleCond + -- Disjunction + '|' -> (||) <$> singleCond <*> singleCond + -- Conjunction + '&' -> (&&) <$> singleCond <*> singleCond + -- match char? + 'q' -> do + ch <- getInstr `provided` liftM not endOfInstr + (c, p) <- getState (bufferContent &&& bufferPointer) + a <- liftST $ readBuffer c p + return (a == ch) + -- CP < SX ? + 'l' -> uncurry (<) <$> getState (bufferPointer &&& sx) + -- CP > SX ? + 'g' -> uncurry (>) <$> getState (bufferPointer &&& sx) + -- CP == SX ? + 'E' -> uncurry (==) <$> getState (bufferPointer &&& sx) + -- toggle SX + 'C' -> modState (\st -> st{cp=not $ cp st}) >> singleCond + `provided` getState (not . null . ck) + -- AX == CK(0) ? + '=' -> uncurry (==) <$> getState (ax &&& head . ck) + `provided` getState (not . null . ck) + -- AX < CK(0) ? + '<' -> uncurry (<) <$> getState (ax &&& head . ck) + `provided` getState (not . null . ck) + -- AX > CK(0) ? + '>' -> uncurry (>) <$> getState (ax &&& head . ck) + `provided` getState (not . null . ck) + -- pop CK, discard, continue + 'k' -> (modState (\st -> st{ck=tail $ ck st}) >> singleCond) + `provided` getState (not . null . ck) + -- Catch others + o -> synViol + +-- | Run the entire program. +procInstrs :: CTPL0 s () +procInstrs = singleInstr `asLongAs` (not <$> endOfInstr) + where asLongAs act test = do + b <- test + when b $ act >> act `asLongAs` test |