Code から Instruction への変換 (5)

module Toy where

import Data.Char
import Data.Maybe
import Numeric

type SourceCode  = String
type Interactive = [Input] -> [Output]
type Input  = String
type Output = String

drive :: Interactive -> (String -> String)
drive f = unlines . f . lines

toy :: SourceCode -> Interactive
toy prog = mapMaybe output . eval . initState (load prog)

output :: ToyState -> Maybe Output
output (_,_,_,_,out) = out

load :: SourceCode -> Memory
load prog = (size, mem)
    where
        size = length proglines
        mem = cycle $ map trans proglines
        proglines = lines prog 

trans :: String -> (Label, Content)
trans s = case break isSpace s' of
    ([], [])       -> error "empty line"
    (lab, content) -> (lab, read content)
    where
        s' = toUpper <$> s

initState :: Memory -> [Input] -> ToyState
initState mem inputs = (False, mem, 0, inputs, Nothing)

type Memory = (Int, [(Label, Content)])
type Label  = String

data Content
    = Code Code
    | Data Int
    deriving Show

instance Read Content where
    readsPrec _ content = case words content of
        [cnt] -> case readSigned readDec cnt of
            [(num,"")] -> [(Data num, "")]
            _          -> [(Code (read cnt, None), "")]
        [op, arg]
              -> [(Code (read op, read arg), "")]

type Code = (Operator, Operand)

data Operator
    = STOP
    | GET
    | PRINT
    | LOAD
    | STORE
    | ADD
    | SUB
    | GOTO
    | IFZERO
    | IFPOS
    deriving (Show, Read)

data Operand
    = None
    | Num Int
    | Lab Label
    deriving Show

instance Read Operand where
    readsPrec _ s = case words s of
        [oprd] -> case readSigned readDec oprd of
            [(num,"")] -> [(Num num, "")]
            _          -> [(Lab oprd, "")]
        _      -> []

type ToyState = (Final, Memory, Acc, [Input], Maybe Output)
type Final = Bool
type Acc   = Int

eval :: ToyState -> [ToyState]
eval state = state : rests
    where
        rests | isFinal state = []
              | otherwise     = eval (step state)

isFinal :: ToyState -> Bool
isFinal (flg,_,_,_,_) = flg

type Instruction = ToyState -> ToyState

step :: ToyState -> ToyState
step state = execute (decode (fetch state)) state

-- 

fetch :: ToyState -> Code
fetch state = case state of
    (_,(_,top:_),_,_,_) -> case top of
        (_,Code code)       -> code
        _                   -> error "not a code"
    _                   -> error "empty memory"

-- 

decode :: Code -> Instruction
decode (op,oprd) = case op of
    { STOP   -> iStop
    ; GET    -> iGet
    ; PRINT  -> iPrint
    ; LOAD   -> iLoad
    ; STORE  -> iStore
    ; ADD    -> iAdd
    ; SUB    -> iSub
    ; GOTO   -> iGoto
    ; IFZERO -> iIfzero
    ; IFPOS  -> iIfpos
    } $ oprd

iStop :: Operand -> Instruction
iStop _ state = case state of
    (_,mem,acc,ins,_) -> (True,mem,acc,ins, Just "stopped")

iGet, iPrint :: Operand -> Instruction
iGet   _ state = case state of
    (flg,mem,_,ins,_) -> (flg, next mem, read (head ins), tail ins, Nothing)

iPrint _ state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc, ins, Just $ show acc)

next :: Memory -> Memory
next (sz,mem) = (sz, tail mem)

iLoad :: Operand -> Instruction
iLoad oprd state = case state of
    (flg,mem,_,ins,_) -> (flg, next mem, value oprd mem, ins, Nothing)

value :: Operand -> Memory -> Int
value oprd (sz, mem) = case oprd of
    Num num -> num
    Lab lab -> case lookup lab (take sz mem) of
        Just (Data num) -> num
        _               -> error $ "no data labeled " ++ show lab
    None -> error "invalid operand"

iStore :: Operand -> Instruction
iStore oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem' , acc, ins, Nothing)
        where
            mem' = update oprd acc mem

update :: Operand -> Int -> Memory -> Memory
update oprd num (sz, mem) = case oprd of
    Lab lab -> case break ((lab ==) . fst) (take sz mem) of
        (xs,(_,Data _):ys) -> (sz, cycle $ xs ++ (lab, Data num) : ys)
        _                  -> error $ "no data labeled " ++ show lab
    _       -> error "not a label"

iAdd :: Operand -> Instruction
iAdd oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc + value oprd mem, ins, Nothing)

iSub :: Operand -> Instruction
iSub oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc - value oprd mem, ins, Nothing)

iGoto :: Operand -> Instruction
iGoto oprd state = case state of
    (flg,(sz,mem),acc,ins,_) -> case oprd of
        Lab lab -> case break ((lab ==) . fst) (take sz mem) of
            (_,[])  -> error $ "no instruction labeled " ++ show lab
            (xs,ys) -> (flg, (sz, cycle $ ys ++ xs), acc, ins, Nothing)
        _       -> error "iGoto: not a label"

iIfzero :: Operand -> Instruction
iIfzero = condJump (0 ==)

iIfpos :: Operand -> Instruction
iIfpos  = condJump (0 <=)

condJump :: (Acc -> Bool) -> Operand -> Instruction
condJump p oprd state = case state of
    (flg,mem,acc,ins,_)
        | p acc     -> iGoto oprd state
        | otherwise -> (flg, next mem, acc, ins, Nothing)

--

execute :: Instruction -> Instruction
execute = id

--

{- |
>>> test prog00 ["3"]
3
stopped
-}
test :: SourceCode -> [Input] -> IO ()
test prog = putStr . drive (toy prog) . unlines

prog00 :: SourceCode
prog00 = unlines
    [ " get"
    , " print"
    , " stop"
    ]

{- |
2つの入力値の和と差
>>> test prog01 ["4","7"]
11
-3
0
stopped
-}
prog01 :: SourceCode
prog01 = unlines
    [ "  get"
    , "  store x"
    , "  get"
    , "  store y"
    , "  add x"
    , "  print"
    , "  load x"
    , "  sub y"
    , "  print"
    , "  add 3"
    , "  print"
    , "  stop"
    , "x 0"
    , "y 0"
    ]

{- | 
0 が入力されるまで、入力された数値を加算する
>>> test prog02 ["1","2","3","4","0"]
10
stopped
-}
prog02 :: String
prog02 = unlines
    [ "top get"
    , "    ifzero bot"
    , "    add sum"
    , "    store sum"
    , "    goto top"
    , "bot load sum"
    , "    print"
    , "    stop"
    , "sum 0"
    ]