summaryrefslogtreecommitdiff
path: root/Text/CTPL0.hs
blob: fe575836f0fc9cbca9a70f3ade7445915b821d3d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
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, i-1) 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 (-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)

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 points to AX by default, but to CK(0) after 'C'
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
    -- Walk left
    '<' -> modBufferState (walkBuffer (-1))
           `provided` getState (not . null . leftBehind . bufferState)
    -- Walk right
    '>' -> modBufferState (walkBuffer 1)
           `provided` getState (not . null . rightPending . bufferState)
    -- Inc AX (CK(0))
    '+' -> do
      num <- liftM fromIntegral instrNumArg
      modRegisterState $ \s -> setSX (sx s + num) s
    -- Dec AX (CK(0))
    '-' -> do
      num <- liftM fromIntegral instrNumArg
      modRegisterState $ \s -> setSX (sx s - num) s
    -- Insert char, go after
    'i' -> do
      ch <- getInstr `provided` liftM not endOfInstr
      modBufferState $ \s -> s{leftBehind=ch : leftBehind s}
    -- Replace char
    'r' -> do
      ch <- getInstr `provided` liftM not endOfInstr
      modBufferState $ \s -> s{thisChar=ch}
    -- Delete char
    'x' -> modBufferState (\s -> s{thisChar=head $ rightPending s, rightPending=tail $ rightPending s})
           `provided` getState (not . null . rightPending . bufferState)
    -- Insert chars delimited by $, go after
    'I' -> do
      cs <- instrDelimArg
      modBufferState $ \s -> s{leftBehind = reverse cs ++ leftBehind s}
    -- Append char at the end, don't walk
    'a' -> do
      ch <- getInstr `provided` liftM not endOfInstr
      modBufferState $ \s -> s{rightPending=appendBeforeETX (rightPending s) [ch]}
    -- Append chars delimited by $, don't walk
    'A' -> do
      cs <- instrDelimArg
      modBufferState $ \s -> s{rightPending=appendBeforeETX (rightPending s) cs}
    -- Push [CP] to MK
    'y' -> do
      ch <- getState $ thisChar . bufferState
      modRegisterState $ \s -> s{mk=[ch]:mk s}
    -- Append [CP] to MK(0)
    'Y' -> do
      ch <- getState $ thisChar . bufferState
      modRegisterState (\s -> s{mk=(appendBeforeETX (head $ mk s) [ch]):tail (mk s)})
       `provided` getState (not . null . mk . registerState)
    -- Pop MK(0), discard
    'p' -> modRegisterState (\s -> s{mk=tail $ mk s})
           `provided` getState (not . null . mk . registerState)
    -- Peek MK(0), insert, go after
    'P' -> do
      cs <- getState (head . mk . registerState)
            `provided` getState (not . null . mk . registerState)
      modBufferState $ \s -> s{leftBehind = reverse (unetx cs) ++ leftBehind s}
    -- Set IP = AX (CK(0))
    'j' -> do
      ax <- getState $ sx . registerState
      b <- singleCond
      when b $ do
        ip <- getIP
        let rel = fromIntegral ax - ip
        modProgramState (walkBuffer rel) `provided` canRelJump rel
    -- Set IP += AX (CK(0))
    'J' -> do
      ax <- getState $ sx . registerState
      b <- singleCond
      when b $ do
        let rel = fromIntegral ax
        modProgramState (walkBuffer rel) `provided` canRelJump rel
    -- Set IP = AX (CK(0)), push IP onto RK
    '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}
    -- Return to RK(0), pop RK
    '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}
    -- Set AX (CK(0)) = 0
    '0' -> modRegisterState $ setSX 0
    -- Set AX (CK(0)) = CP
    'Q' -> do
      cp <- getCP
      modRegisterState $ setSX $ fromIntegral cp
    -- Set CP = AX (CK(0))
    'm' -> do
      ax <- getState $ fromIntegral . sx . registerState
      cp <- getCP
      let rel = ax - cp
      modBufferState (walkBuffer rel) `provided` canRelWalk rel
    -- Select CK(0) instead of AX for next operation
    'C' -> modRegisterState (\s -> s{cp=True})
           `provided` getState (not . null . ck . registerState)
    -- Load ord[CP] into AX (CK(0))
    'l' -> do
      ch <- getState $ ord . thisChar . bufferState
      modRegisterState $ setSX $ fromIntegral ch
    -- Save ascii(AX) (CK(0)) to [CP]
    's' -> do
      ax <- getState $ fromIntegral . sx . registerState
      modBufferState $ \s -> s{thisChar=chr ax}
    -- Push AX onto CK (or duplicate CK0, if SX->CK0)
    'd' -> do
      ax <- getState $ fromIntegral . sx . registerState
      modRegisterState $ \s -> s{ck=ax:ck s}
    -- Pop AX from CK
    'D' -> do
      ax' <- getState (fromIntegral . head . ck . registerState)
             `provided` getState (not . null . ck . registerState)
      modRegisterState $ \s -> s{ax=ax',ck=tail (ck s)}
    -- Pop CK, discard
    'k' -> modRegisterState (\s -> s{ck=tail (ck s)})
           `provided` getState (not . null . ck . registerState)
    -- Catch others
    o -> synViol
  unless (i=='C') $ modRegisterState $ \s -> s{cp=False}

singleCond :: CTPL0 Bool
singleCond = do
  i <- getInstr `provided` liftM not endOfInstr
  case i of
    -- Is Uppercase?
    'U' -> getState $ isUpper . thisChar . bufferState
    -- Is Lowercase?
    'L' -> getState $ isLower . thisChar . bufferState
    -- AX (CK(0)) = 0 ?
    'z' -> getState $ (==0) . sx . registerState
    -- Always true
    't' -> return True
    -- Is Digit?
    'N' -> getState $ isDigit . thisChar . bufferState
    -- Is End of Buffer?
    'e' -> getState $ null . rightPending . bufferState
    -- Negation
    '!' -> liftM not singleCond
    -- Disjunction
    '|' -> liftM2 (||) singleCond singleCond
    -- Conjunction
    '&' -> liftM2 (&&) singleCond singleCond
    -- Given char equals [CP]
    'q' -> do
      ch <- getInstr `provided` liftM not endOfInstr
      getState $ (==ch) . thisChar . bufferState
    -- CP < AX (CK(0))
    'l' -> do
      cp <- getCP
      getState $ (cp <) . fromIntegral . sx . registerState
    -- CP > AX (CK(0))
    'g' -> do
      cp <- getCP
      getState $ (cp >) . fromIntegral . sx . registerState
    -- CP = AX (CK(0))
    'E' -> do
      cp <- getCP
      getState $ (cp ==) . fromIntegral . sx . registerState
    -- If SX->AX then make SX->CK(0), otherwise make SX->AX
    '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
    -- AX = CK(0)?
    '=' -> liftM2 (==)
           (getState $ ax . registerState)
           (getState $ fromIntegral . head . ck . registerState)
           `provided` getState (not . null . ck . registerState)
    -- AX < CK(0)?
    '<' -> liftM2 (<)
           (getState $ ax . registerState)
           (getState $ fromIntegral . head . ck . registerState)
           `provided` getState (not . null . ck . registerState)
    -- AX > CK(0)?
    '>' -> liftM2 (>)
           (getState $ ax . registerState)
           (getState $ fromIntegral . head . ck . registerState)
           `provided` getState (not . null . ck . registerState)
    -- Pop CK, discard, then continue evaluation
    'k' -> do
      modRegisterState (\s -> s{ck=tail $ ck s})
       `provided` getState (not . null . ck . registerState)
      singleCond
    -- Catch others
    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