aheui.hs (r2: refactoring WIP)

aheui.hs

import System.Exit


{-
    Data Structures
-}

data Dir = SetDir Int Int | FlipX | FlipY | FlipXY | KeepDir
data Op = DivOp | AddOp | MulOp | ModOp | DupOp | SwitchOp Int | MoveOp Int
        | CmpOp | BranchOp | SubOp | SwapOp | ExitOp | PrintNumOp
        | PrintCharOp | PopOp | InputNumOp | InputCharOp | PushOp Int | NoOp

data Cell = Cell Op Dir

emptyCell :: Cell
emptyCell = Cell NoOp KeepDir

type CodeSpace = [[Cell]]

width :: CodeSpace -> Int
width space = maximum $ map length space

height :: CodeSpace -> Int
height space = length space

fillBlanks :: CodeSpace -> Int -> CodeSpace
fillBlanks space w = [take w (line ++ repeat emptyCell) | line <- space]

cellAt :: (Int, Int) -> CodeSpace -> Cell
cellAt (x, y) space = space !! y !! x


{-
    Parser
-}

parse :: String -> CodeSpace
parse code = fillBlanks space (width space)
    where space = map parseLine (lines code)

parseLine :: String -> [Cell]
parseLine line = map parseChar line

parseChar :: Char -> Cell
parseChar ch
    | isHangul ch = let (first, middle, last) = decomposeHangul ch
                    in Cell (parseOp first last) (parseDir middle)
    | otherwise = emptyCell

parseOp :: Int -> Int -> Op
parseOp op value =
    case (op, value) of
        (2, _) -> DivOp -- ㄴ
        (3, _) -> AddOp -- ㄷ
        (4, _) -> MulOp -- ㄸ
        (5, _) -> ModOp -- ㄹ
        (8, _) -> DupOp -- ㅃ
        (9, x) -> SwitchOp x -- ㅅ
        (10, x) -> MoveOp x -- ㅆ
        (12, _) -> CmpOp -- ㅈ
        (14, _) -> BranchOp -- ㅊ
        (16, _) -> SubOp -- ㅌ
        (17, _) -> SwapOp -- ㅍ
        (18, _) -> ExitOp -- ㅎ
        (6, 21) -> PrintNumOp -- ㅁ/ㅇ
        (6, 27) -> PrintCharOp -- ㅁ/ㅎ
        (6, _) -> PopOp -- ㅁ
        (7, 21) -> InputNumOp -- ㅂ/ㅇ
        (7, 27) -> InputCharOp -- ㅂ/ㅎ
        (7, x) -> PushOp (valueTable !! x) -- ㅂ
        otherwise -> NoOp

parseDir :: Int -> Dir
parseDir x =
    case x of
        0 -> SetDir 1 0 -- ㅏ
        2 -> SetDir 2 0 -- ㅑ
        4 -> SetDir (-1) 0 -- ㅓ
        6 -> SetDir (-2) 0 -- ㅕ
        8 -> SetDir 0 (-1) -- ㅗ
        12 -> SetDir 0 (-2) -- ㅛ
        13 -> SetDir 0 1 -- ㅜ
        17 -> SetDir 0 2 -- ㅠ
        18 -> FlipX -- ㅣ
        19 -> FlipXY -- ㅢ
        20 -> FlipY -- ㅡ
        otherwise -> KeepDir

isHangul :: Char -> Bool
isHangul ch = '가' <= ch && ch <= '힣'

decomposeHangul :: Char -> (Int, Int, Int)
decomposeHangul ch = (c `div` 28 `div` 21,
                      c `div` 28 `mod` 21,
                      c `mod` 28)
                   where c = (fromEnum ch) - (fromEnum '가')

valueTable = [0, 2, 4, 4, 2, 5, 5, 3, 5, 7, 9, 9, 7, 9,
              9, 8, 4, 4, 6, 2, 4, 1, 3, 4, 3, 4, 4, 3]


{-
    Memory
-}

data Storage = Stack [Int] | Queue [Int]
data Memory = Memory Int [Storage]

update i d s = a ++ [s] ++ tail b
               where (a, b) = splitAt i d
modify f i d = update i d (f (d !! i))

currentStorage (Memory i _) = i
switchStorage (Memory i d) i' = Memory i' d
modifyStorage i' f (Memory i d) = Memory i (modify f i' d)
modifyCurrentStorage f (Memory i d) = modifyStorage i f (Memory i d)
storageSize (Memory i d) = length $ unwrap (d !! i)

unwrap (Stack xs) = xs
unwrap (Queue xs) = xs

peekStorage :: Storage -> Int
peekStorage (Stack (x:xs)) = x
peekStorage (Queue (x:xs)) = x

popStorage :: Storage -> Storage
popStorage (Stack (x:xs)) = Stack xs
popStorage (Queue xs) = Queue (tail xs)

pushStorage :: Int -> Storage -> Storage
pushStorage x (Stack xs) = Stack (x:xs)
pushStorage x (Queue xs) = Queue (xs ++ [x])

swapStorage :: Storage -> Storage
swapStorage (Stack (x:y:ys)) = Stack (y:x:ys)
swapStorage (Queue (x:y:ys)) = Queue (y:x:ys)

dupStorage :: Storage -> Storage
dupStorage (Stack (x:xs)) = Stack (x:x:xs)
dupStorage (Queue (x:xs)) = Queue (x:x:xs)

peek (Memory i d) = peekStorage (d !! i)
pop mem = (modifyCurrentStorage popStorage mem, peek mem)
push val mem = pushTo (currentStorage mem) val mem
pushTo i val = modifyStorage i (pushStorage val)
swap = modifyCurrentStorage swapStorage
dup = modifyCurrentStorage dupStorage

newStorage 21 = Queue []
newStorage _ = Stack []
initMem = Memory 0 (map newStorage [0..27])


{-
    VM
-}

type Delta = (Int, Int)
type Pos = (Int, Int)
data Ptr = Ptr CodeSpace Pos Delta

execute :: CodeSpace -> IO ()
execute space = runLoop (Ptr space (0, 0) (1, 0)) initMem

runLoop :: Ptr -> Memory -> IO ()
runLoop ptr mem =
    do
        mem' <- executeOp (if underflow then NoOp else op) mem
        runLoop ptr' mem'
    where Cell op _ = currentCell ptr
          branch = shouldBranch op mem
          underflow = willUnderflow op mem
          delta = nextDelta ptr branch underflow
          ptr' = advancePtr ptr delta

currentCell :: Ptr -> Cell
currentCell (Ptr space pos _) = cellAt pos space

{- Flow Control -}

flipIf pred x = if pred then flipDir x else x

nextDelta :: Ptr -> Bool -> Bool -> Delta
nextDelta ptr@(Ptr _ _ delta) branch underflow =
    flipIf branch (flipIf underflow (applyDir delta dir))
    where Cell _ dir = currentCell ptr
          delta' = applyDir delta dir

advancePtr :: Ptr -> Delta -> Ptr
advancePtr (Ptr space (x, y) _) (dx, dy) =
    Ptr space (x', y') (dx, dy)
    where x' = wrap (x + dx) (width space)
          y' = wrap (y + dy) (height space)

flipDir (x, y) = (-x, -y)

applyDir :: Delta -> Dir -> Delta
applyDir _ (SetDir dx dy) = (dx, dy)
applyDir (dx, dy) FlipX = (-dx, dy)
applyDir (dx, dy) FlipY = (dx, -dy)
applyDir (dx, dy) FlipXY = flipDir (dx, dy)
applyDir dir KeepDir = dir

wrap pos size
    | pos < 0 = size - 1
    | pos >= size = 0
    | otherwise = pos

shouldBranch BranchOp mem = peek mem == 0
shouldBranch _ mem = False

willUnderflow op mem = storageSize mem < requiredElems op

requiredElems op =
    case op of
        DivOp -> 2
        AddOp -> 2
        MulOp -> 2
        ModOp -> 2
        DupOp -> 1
        MoveOp _ -> 1
        CmpOp -> 2
        BranchOp -> 1
        SubOp -> 2
        SwapOp -> 2
        PrintNumOp -> 1
        PrintCharOp -> 1
        PopOp -> 1
        _ -> 0

{- Execution -}

executeOp :: Op -> Memory -> IO Memory
executeOp PrintNumOp mem =
    do
        putStr (show val)
        return mem'
    where (mem', val) = pop mem
executeOp PrintCharOp mem =
    do
        putChar (toEnum val)
        return mem'
    where (mem', val) = pop mem
executeOp InputNumOp mem =
    do
        n <- getLine
        return (push (read n) mem)
executeOp InputCharOp mem =
    do
        ch <- getChar
        return (push (fromEnum ch) mem)
executeOp ExitOp mem = exitSuccess
executeOp op mem = return (executeSimpleOp op mem)

-- "simple" operations: ops without IO
stack2 f mem = push (f y x) mem''
    where (mem', x) = pop mem
          (mem'', y) = pop mem'

executeSimpleOp :: Op -> Memory -> Memory
executeSimpleOp DivOp mem = stack2 div mem
executeSimpleOp AddOp mem = stack2 (+) mem
executeSimpleOp MulOp mem = stack2 (*) mem
executeSimpleOp ModOp mem = stack2 mod mem
executeSimpleOp DupOp mem = dup mem
executeSimpleOp (SwitchOp i) mem = switchStorage mem i
executeSimpleOp (MoveOp i) mem = pushTo i val mem'
    where (mem', val) = pop mem
executeSimpleOp CmpOp mem = stack2 (\y x -> if y >= x then 1 else 0) mem
executeSimpleOp SubOp mem = stack2 (-) mem
executeSimpleOp SwapOp mem = swap mem
executeSimpleOp PopOp mem = mem'
    where (mem', _) = pop mem
executeSimpleOp (PushOp val) mem = push val mem
executeSimpleOp BranchOp mem = executeSimpleOp PopOp mem -- same with pop
executeSimpleOp NoOp mem = mem


{-
    Entry Point
-}

main = do
    code <- getContents
    execute (parse code)