Advertisement
VSZM

brainforth#1

Mar 15th, 2016
169
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module D071PO where
  2.  
  3.  
  4. import Control.Monad.Trans.Reader
  5. import Control.Monad.State
  6. import Data.Maybe
  7. import Data.List
  8. import Data.List.Split
  9. import Data.Vector (Vector)
  10. import qualified Data.Vector as V
  11. import Data.Map (Map)
  12. import qualified Data.Map as M
  13. -- Created by Szegedi Gábor, VSZM
  14.  
  15. {- Useful:
  16.     :set +t -- type info always on
  17. -}
  18.  
  19. data Tape = T
  20.     { tVec :: Vector Int
  21.     , tIx  :: Int
  22.     } deriving (Show, Eq)
  23.  
  24. newTape :: Int -> Tape
  25. newTape n = T { tVec = V.replicate n 0,tIx = 0}
  26.  
  27.  
  28. class BFMem m where
  29.     incVal    :: m -> m
  30.     decVal    :: m -> m
  31.     isNull    :: m -> Bool
  32.     getVal    :: m -> Int
  33.     putVal    :: m -> Int -> m
  34.     memLeft   :: m -> m
  35.     memRight  :: m -> m
  36.  
  37.  
  38. instance BFMem Tape where
  39.     incVal T {tVec = vec, tIx = idx}        = T {tVec = vec V.// [(idx, vec V.! idx + 1)], tIx = idx}
  40.     decVal T {tVec = vec, tIx = idx}        = T {tVec = vec V.// [(idx, vec V.! idx - 1)], tIx = idx}
  41.     isNull T {tVec = vec, tIx = idx}        = vec V.! idx == 0
  42.     getVal T {tVec = vec, tIx = idx}        = vec V.! idx
  43.     putVal T {tVec = vec, tIx = idx} val    = T {tVec = vec V.// [(idx, val)], tIx = idx}
  44.     memLeft T {tVec = vec, tIx = idx}       = T {tVec = vec, tIx = if idx == (V.length vec) - 1
  45.                                                     then 0
  46.                                                     else idx + 1}
  47.     memRight T {tVec = vec, tIx = idx}      = T {tVec = vec, tIx = if idx == 0
  48.                                                     then (V.length vec) - 1
  49.                                                     else idx - 1}                        
  50.    
  51.    
  52.  {-
  53. class YesNo a where  
  54.     yesno :: a -> Bool  
  55.    
  56. instance YesNo Int where  
  57.     yesno 0 = False  
  58.     yesno _ = True  
  59.  -}
  60.  
  61. test_BFMem_Tape =
  62.     [ incVal   t                  ==  t { tVec = V.fromList [ 1, 1, 2, 3] }
  63.     , decVal   t                  ==  t { tVec = V.fromList [-1, 1, 2, 3] }
  64.     , isNull   t                  ==  True
  65.     , isNull   t { tIx = 1 }      ==  False
  66.     , getVal   t                  ==  0
  67.     , getVal   t { tIx = 3 }      ==  3
  68.     , putVal   t             451  ==  t { tVec = V.fromList [451, 1, 2, 3] }
  69.     , putVal   t { tIx = 3 } 451  ==  T { tVec = V.fromList [0, 1, 2, 451], tIx = 3 }
  70.     , memLeft  t                  ==  t { tIx = 1 }
  71.     , memLeft  t { tIx = 3 }      ==  t { tIx = 0 }
  72.     , memRight t { tIx = 3 }      ==  t { tIx = 2 }
  73.     , memRight t                  ==  t { tIx = 3 }
  74.     ]
  75.     where t = T { tVec = V.fromList [0, 1, 2, 3], tIx = 0 }
  76.  
  77. data BFSymbol
  78.     = Inc | Dec | MemLeft | MemRight | BrktOpen | BrktClose | In | Out
  79.     | StartSeq | EndSeq | SeqId Char
  80.     deriving (Show, Eq)
  81.    
  82. type BFSequence = Vector BFSymbol
  83.  
  84.  
  85. type BFEnv = Map Char BFSequence
  86.  
  87. sq0 :: Char
  88. sq0 = '*'
  89.  
  90. parseProgram :: String -> BFEnv
  91. parseProgram str = M.fromList $ map parseSequence $ splitOn ";" str
  92.  
  93. parseSequence :: String -> (Char, BFSequence)
  94. parseSequence str | Just seq <- stripPrefix ":" str = (seq!!0, V.fromList $ map charToBFSymbol $ tail seq)
  95. parseSequence baseseq = (sq0, V.fromList $ map charToBFSymbol baseseq)
  96.  
  97. charToBFSymbol :: Char -> BFSymbol
  98. charToBFSymbol '+' = Inc
  99. charToBFSymbol '-' = Dec
  100. charToBFSymbol '>' = MemRight
  101. charToBFSymbol '<' = MemLeft
  102. charToBFSymbol '[' = BrktOpen
  103. charToBFSymbol ']' = BrktClose
  104. charToBFSymbol ',' = In
  105. charToBFSymbol '.' = Out
  106. charToBFSymbol x   = SeqId x
  107.  
  108.  
  109. test_parseProgram =
  110.     [ parseProgram "+-<>[],."    == M.fromList [(sq0, V.fromList [Inc, Dec, MemLeft, MemRight, BrktOpen, BrktClose, In, Out])]
  111.     , parseProgram ":A-;A+"      == M.fromList [(sq0, V.fromList [SeqId 'A', Inc]), ('A', V.fromList [Dec])]
  112.     , parseProgram ":A-;:B+;AB+" == M.fromList [(sq0, V.fromList [SeqId 'A', SeqId 'B', Inc]), ('A', V.fromList [Dec]), ('B', V.fromList [Inc])]
  113.     ]
  114.  
  115. inc :: Int -> Int
  116. inc i = i + 1
  117.  
  118. dec :: Int -> Int
  119. dec i = i - 1
  120.    
  121. matchingBracket :: BFSequence -> Int -> Int
  122. matchingBracket seq idx | seq V.! idx == BrktOpen  = matchBrackets seq (idx+1) [BrktOpen] inc
  123. matchingBracket seq idx | seq V.! idx == BrktClose = matchBrackets seq (idx-1) [BrktClose] dec
  124.  
  125.  
  126. test_matchingBracket = testBrkt sq1 pairs1 ++ testBrkt sq2 pairs2
  127.   where
  128.     testBrkt sq pairs = map (\(s, e) -> matchingBracket (mkSq sq) s == e) pairs
  129.     mkSq   = V.fromList . map (\c -> case c of '(' -> BrktOpen; ')' -> BrktClose; _ -> Inc)
  130.     sq1    = "(a)(b)"
  131.     pairs1 = [(0, 2), (3, 5)]
  132.     sq2    = "((())()())"
  133.     pairs2 = zip [0..9] [9, 4, 3, 2, 1, 6, 5, 8, 7, 0]
  134.    
  135. matchBrackets :: BFSequence -> Int -> [BFSymbol] -> (Int -> Int) -> Int
  136. matchBrackets seq idx brkts f
  137.     | null brkts && isInc f = idx - 1
  138.     | null brkts && isDec f = idx + 1
  139.     | oppositeOfLast brkts (seq V.! idx) = matchBrackets seq (f idx) (init brkts) f-- Remove bracket because of matching pair
  140.     | isBracket (seq V.! idx) = matchBrackets seq (f idx) (brkts ++ [seq V.! idx]) f-- Unmatched bracket, depth increases
  141.     | otherwise = matchBrackets seq (f idx) brkts f-- is not a bracket, ignore
  142.     where
  143.         oppositeOfLast brkts symbol
  144.             | symbol == BrktOpen && (last brkts) == BrktClose = True
  145.             | symbol == BrktClose && (last brkts) == BrktOpen = True
  146.             | otherwise = False
  147.         isBracket brkt
  148.             | brkt == BrktOpen  = True
  149.             | brkt == BrktClose = True
  150.             | otherwise = False
  151.         isInc f = (f 0) == 1
  152.         isDec f = (f 0) == -1
  153.        
  154. data BFState = S
  155.     { sCallStk :: [(Int, Char)]
  156.     , sMem     :: Tape
  157.     , sIn      :: [Int]
  158.     , sOut     :: [Int]
  159.     } deriving (Show, Eq)
  160.    
  161. stret  = S {sCallStk = [], sMem = newTape 1, sIn = [42], sOut = []}
  162.  
  163.    
  164. -- Like greeter http://adit.io/posts/2013-06-10-three-useful-monads.html    
  165. step :: ReaderT BFEnv (State BFState) ()
  166. step = do
  167.     bfstate <- get -- gets BFState from State monad
  168.     bfenv <- ask   -- gets BFEnv from Reader monad
  169.     put $ stepImpl bfstate bfenv -- setsBFState to State monad
  170.     return ()
  171.  
  172. stepImpl :: BFState -> BFEnv -> BFState    
  173. stepImpl bfstate bfenv
  174.     | (instructionPointer bfstate) == V.length (currentSeq bfstate bfenv) = bfstate{sCallStk = tail $ sCallStk bfstate} -- reached end of the currentSeq
  175.     | (instruction bfstate bfenv) == Inc        = moveIP bfstate{sMem = incVal $ sMem bfstate} bfenv
  176.     | (instruction bfstate bfenv) == Dec        = moveIP bfstate{sMem = decVal $ sMem bfstate} bfenv
  177.     | (instruction bfstate bfenv) == MemLeft    = moveIP bfstate{sMem = memLeft $ sMem bfstate} bfenv
  178.     | (instruction bfstate bfenv) == MemRight   = moveIP bfstate{sMem = memRight $ sMem bfstate} bfenv
  179.     | (instruction bfstate bfenv) == (SeqId x)  = bfstate{sCallStk = [(0, x)] ++ (sCallStk $ moveIP bfstate bfenv)}
  180.     | otherwise = bfstate
  181.     where
  182.         instruction bfstate bfenv   = (currentSeq bfstate bfenv) V.! (instructionPointer bfstate)
  183.         currentSeq bfstate bfenv    = bfenv M.! (currentSeqName bfstate)
  184.         currentSeqName bfstate      = snd $ sCallStk bfstate !! 0
  185.         instructionPointer bfstate  = fst $ sCallStk bfstate !! 0
  186.         moveIP bfstate bfenv
  187.             | null $ sCallStk bfstate = bfstate
  188.            -- | (instructionPointer bfstate) == V.length (currentSeq bfstate bfenv) - 1 = moveIP bfstate{sCallStk = tail $ sCallStk bfstate} bfenv currentSeq ended, move back on the stack
  189.             | otherwise = bfstate{sCallStk = [(1 + instructionPointer bfstate, currentSeqName bfstate)] ++ (tail $ sCallStk bfstate)} -- we move forward in currentSeq
  190.    
  191. test_step =
  192.   [ exec env1 st1{sCallStk = [(0, sq0)]} == st1{sCallStk = [(1, sq0)], sMem = incVal $ newTape 32}
  193.   , exec env1 st1{sCallStk = [(1, sq0)]} == st1{sCallStk = [(2, sq0)], sMem = memRight $ newTape 32}
  194.   , exec env1 st1{sCallStk = [(2, sq0)]} == st1{sCallStk = [(5, sq0)]}
  195.   , exec env1 st1{sCallStk = [(2, sq0)], sMem = incVal $ newTape 32} == st1{sCallStk = [(3, sq0)], sMem = incVal $ newTape 32}
  196.   , exec env1 st1{sCallStk = [(4, sq0)]} == st1{sCallStk = [(2, sq0)]}
  197.   , exec env1 st1{sCallStk = [(5, sq0)]} == st1{sCallStk = [(6, sq0)], sMem = putVal (newTape 32) 43, sIn = []}
  198.   , exec env1 st1{sCallStk = [(6, sq0)]} == st1{sCallStk = [(7, sq0)], sOut = [0]}
  199.  
  200.   , exec env2 st2{sCallStk = [(1, sq0)]} == st2{sCallStk = [(0, 'A'), (2, sq0)]}
  201.   , exec env2 st2{sCallStk = [(0, 'A'), (2, sq0)]} == st2{sCallStk = [(1, 'A'), (2, sq0)], sMem = incVal $ newTape 32}
  202.   , exec env2 st2{sCallStk = [(1, 'A'), (2, sq0)]} == st2{sCallStk = [(2, sq0)]}
  203.   ]
  204.   where
  205.     exec env st = execState (runReaderT step env) st
  206.  
  207.     env1 = M.fromList [(sq0, V.fromList [Inc, MemRight, BrktOpen, Inc, BrktClose, In, Out])]
  208.     st1  = S {sCallStk = [], sMem = newTape 32, sIn = [43], sOut = []}
  209.  
  210.     env2 = M.fromList [(sq0, V.fromList [Dec, SeqId 'A']), ('A', V.fromList [Inc])]
  211.     st2  = S {sCallStk = [], sMem = newTape 32, sIn = [], sOut = []}
Advertisement
RAW Paste Data Copied
Advertisement