brainforth#1

module D071PO where


import Control.Monad.Trans.Reader
import Control.Monad.State
import Data.Maybe
import Data.List
import Data.List.Split
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Map (Map)
import qualified Data.Map as M
-- Created by Szegedi Gábor, VSZM

{- Useful:
    :set +t -- type info always on
-}

data Tape = T
    { tVec :: Vector Int
    , tIx  :: Int
    } deriving (Show, Eq)

newTape :: Int -> Tape
newTape n = T { tVec = V.replicate n 0,tIx = 0}


class BFMem m where
    incVal    :: m -> m
    decVal    :: m -> m
    isNull    :: m -> Bool
    getVal    :: m -> Int
    putVal    :: m -> Int -> m
    memLeft   :: m -> m
    memRight  :: m -> m


instance BFMem Tape where
    incVal T {tVec = vec, tIx = idx}        = T {tVec = vec V.// [(idx, vec V.! idx + 1)], tIx = idx}
    decVal T {tVec = vec, tIx = idx}        = T {tVec = vec V.// [(idx, vec V.! idx - 1)], tIx = idx}
    isNull T {tVec = vec, tIx = idx}        = vec V.! idx == 0
    getVal T {tVec = vec, tIx = idx}        = vec V.! idx
    putVal T {tVec = vec, tIx = idx} val    = T {tVec = vec V.// [(idx, val)], tIx = idx}
    memLeft T {tVec = vec, tIx = idx}       = T {tVec = vec, tIx = if idx == (V.length vec) - 1
                                                    then 0
                                                    else idx + 1}
    memRight T {tVec = vec, tIx = idx}      = T {tVec = vec, tIx = if idx == 0
                                                    then (V.length vec) - 1
                                                    else idx - 1}


 {-
class YesNo a where
    yesno :: a -> Bool

instance YesNo Int where
    yesno 0 = False
    yesno _ = True
 -}

test_BFMem_Tape =
    [ incVal   t                  ==  t { tVec = V.fromList [ 1, 1, 2, 3] }
    , decVal   t                  ==  t { tVec = V.fromList [-1, 1, 2, 3] }
    , isNull   t                  ==  True
    , isNull   t { tIx = 1 }      ==  False
    , getVal   t                  ==  0
    , getVal   t { tIx = 3 }      ==  3
    , putVal   t             451  ==  t { tVec = V.fromList [451, 1, 2, 3] }
    , putVal   t { tIx = 3 } 451  ==  T { tVec = V.fromList [0, 1, 2, 451], tIx = 3 }
    , memLeft  t                  ==  t { tIx = 1 }
    , memLeft  t { tIx = 3 }      ==  t { tIx = 0 }
    , memRight t { tIx = 3 }      ==  t { tIx = 2 }
    , memRight t                  ==  t { tIx = 3 }
    ]
    where t = T { tVec = V.fromList [0, 1, 2, 3], tIx = 0 }

data BFSymbol
    = Inc | Dec | MemLeft | MemRight | BrktOpen | BrktClose | In | Out
    | StartSeq | EndSeq | SeqId Char
    deriving (Show, Eq)

type BFSequence = Vector BFSymbol


type BFEnv = Map Char BFSequence

sq0 :: Char
sq0 = '*'

parseProgram :: String -> BFEnv
parseProgram str = M.fromList $ map parseSequence $ splitOn ";" str

parseSequence :: String -> (Char, BFSequence)
parseSequence str | Just seq <- stripPrefix ":" str = (seq!!0, V.fromList $ map charToBFSymbol $ tail seq)
parseSequence baseseq = (sq0, V.fromList $ map charToBFSymbol baseseq)

charToBFSymbol :: Char -> BFSymbol
charToBFSymbol '+' = Inc
charToBFSymbol '-' = Dec
charToBFSymbol '>' = MemRight
charToBFSymbol '<' = MemLeft
charToBFSymbol '[' = BrktOpen
charToBFSymbol ']' = BrktClose
charToBFSymbol ',' = In
charToBFSymbol '.' = Out
charToBFSymbol x   = SeqId x


test_parseProgram =
    [ parseProgram "+-<>[],."    == M.fromList [(sq0, V.fromList [Inc, Dec, MemLeft, MemRight, BrktOpen, BrktClose, In, Out])]
    , parseProgram ":A-;A+"      == M.fromList [(sq0, V.fromList [SeqId 'A', Inc]), ('A', V.fromList [Dec])]
    , parseProgram ":A-;:B+;AB+" == M.fromList [(sq0, V.fromList [SeqId 'A', SeqId 'B', Inc]), ('A', V.fromList [Dec]), ('B', V.fromList [Inc])]
    ]

inc :: Int -> Int
inc i = i + 1

dec :: Int -> Int
dec i = i - 1

matchingBracket :: BFSequence -> Int -> Int
matchingBracket seq idx | seq V.! idx == BrktOpen  = matchBrackets seq (idx+1) [BrktOpen] inc
matchingBracket seq idx | seq V.! idx == BrktClose = matchBrackets seq (idx-1) [BrktClose] dec


test_matchingBracket = testBrkt sq1 pairs1 ++ testBrkt sq2 pairs2
  where
    testBrkt sq pairs = map (\(s, e) -> matchingBracket (mkSq sq) s == e) pairs
    mkSq   = V.fromList . map (\c -> case c of '(' -> BrktOpen; ')' -> BrktClose; _ -> Inc)
    sq1    = "(a)(b)"
    pairs1 = [(0, 2), (3, 5)]
    sq2    = "((())()())"
    pairs2 = zip [0..9] [9, 4, 3, 2, 1, 6, 5, 8, 7, 0]

matchBrackets :: BFSequence -> Int -> [BFSymbol] -> (Int -> Int) -> Int
matchBrackets seq idx brkts f
    | null brkts && isInc f = idx - 1
    | null brkts && isDec f = idx + 1
    | oppositeOfLast brkts (seq V.! idx) = matchBrackets seq (f idx) (init brkts) f-- Remove bracket because of matching pair
    | isBracket (seq V.! idx) = matchBrackets seq (f idx) (brkts ++ [seq V.! idx]) f-- Unmatched bracket, depth increases
    | otherwise = matchBrackets seq (f idx) brkts f-- is not a bracket, ignore
    where
        oppositeOfLast brkts symbol
            | symbol == BrktOpen && (last brkts) == BrktClose = True
            | symbol == BrktClose && (last brkts) == BrktOpen = True
            | otherwise = False
        isBracket brkt
            | brkt == BrktOpen  = True
            | brkt == BrktClose = True
            | otherwise = False
        isInc f = (f 0) == 1
        isDec f = (f 0) == -1

data BFState = S
    { sCallStk :: [(Int, Char)]
    , sMem     :: Tape
    , sIn      :: [Int]
    , sOut     :: [Int]
    } deriving (Show, Eq)

stret  = S {sCallStk = [], sMem = newTape 1, sIn = [42], sOut = []}


-- Like greeter http://adit.io/posts/2013-06-10-three-useful-monads.html
step :: ReaderT BFEnv (State BFState) ()
step = do
    bfstate <- get -- gets BFState from State monad
    bfenv <- ask   -- gets BFEnv from Reader monad
    put $ stepImpl bfstate bfenv -- setsBFState to State monad
    return ()

stepImpl :: BFState -> BFEnv -> BFState
stepImpl bfstate bfenv
    | (instructionPointer bfstate) == V.length (currentSeq bfstate bfenv) = bfstate{sCallStk = tail $ sCallStk bfstate} -- reached end of the currentSeq
    | (instruction bfstate bfenv) == Inc        = moveIP bfstate{sMem = incVal $ sMem bfstate} bfenv
    | (instruction bfstate bfenv) == Dec        = moveIP bfstate{sMem = decVal $ sMem bfstate} bfenv
    | (instruction bfstate bfenv) == MemLeft    = moveIP bfstate{sMem = memLeft $ sMem bfstate} bfenv
    | (instruction bfstate bfenv) == MemRight   = moveIP bfstate{sMem = memRight $ sMem bfstate} bfenv
    | (instruction bfstate bfenv) == (SeqId x)  = bfstate{sCallStk = [(0, x)] ++ (sCallStk $ moveIP bfstate bfenv)}
    | otherwise = bfstate
    where
        instruction bfstate bfenv   = (currentSeq bfstate bfenv) V.! (instructionPointer bfstate)
        currentSeq bfstate bfenv    = bfenv M.! (currentSeqName bfstate)
        currentSeqName bfstate      = snd $ sCallStk bfstate !! 0
        instructionPointer bfstate  = fst $ sCallStk bfstate !! 0
        moveIP bfstate bfenv
            | null $ sCallStk bfstate = bfstate
           -- | (instructionPointer bfstate) == V.length (currentSeq bfstate bfenv) - 1 = moveIP bfstate{sCallStk = tail $ sCallStk bfstate} bfenv currentSeq ended, move back on the stack
            | otherwise = bfstate{sCallStk = [(1 + instructionPointer bfstate, currentSeqName bfstate)] ++ (tail $ sCallStk bfstate)} -- we move forward in currentSeq

test_step =
  [ exec env1 st1{sCallStk = [(0, sq0)]} == st1{sCallStk = [(1, sq0)], sMem = incVal $ newTape 32}
  , exec env1 st1{sCallStk = [(1, sq0)]} == st1{sCallStk = [(2, sq0)], sMem = memRight $ newTape 32}
  , exec env1 st1{sCallStk = [(2, sq0)]} == st1{sCallStk = [(5, sq0)]}
  , exec env1 st1{sCallStk = [(2, sq0)], sMem = incVal $ newTape 32} == st1{sCallStk = [(3, sq0)], sMem = incVal $ newTape 32}
  , exec env1 st1{sCallStk = [(4, sq0)]} == st1{sCallStk = [(2, sq0)]}
  , exec env1 st1{sCallStk = [(5, sq0)]} == st1{sCallStk = [(6, sq0)], sMem = putVal (newTape 32) 43, sIn = []}
  , exec env1 st1{sCallStk = [(6, sq0)]} == st1{sCallStk = [(7, sq0)], sOut = [0]}

  , exec env2 st2{sCallStk = [(1, sq0)]} == st2{sCallStk = [(0, 'A'), (2, sq0)]}
  , exec env2 st2{sCallStk = [(0, 'A'), (2, sq0)]} == st2{sCallStk = [(1, 'A'), (2, sq0)], sMem = incVal $ newTape 32}
  , exec env2 st2{sCallStk = [(1, 'A'), (2, sq0)]} == st2{sCallStk = [(2, sq0)]}
  ]
  where
    exec env st = execState (runReaderT step env) st

    env1 = M.fromList [(sq0, V.fromList [Inc, MemRight, BrktOpen, Inc, BrktClose, In, Out])]
    st1  = S {sCallStk = [], sMem = newTape 32, sIn = [43], sOut = []}

    env2 = M.fromList [(sq0, V.fromList [Dec, SeqId 'A']), ('A', V.fromList [Inc])]
    st2  = S {sCallStk = [], sMem = newTape 32, sIn = [], sOut = []}