続・Grass のインタプリタを書いてみたよ
という訳で、書き直しました。
Haskell による Grass のインタプリタです。Grass コードのファイル名を与えて実行します。
必要な仕様は、全て満たしているはず。全角文字(UTF-8、Shift_JIS)も受け付けます。
バグ報告は随時お願いします。
Grass 人口が少しでも増えることを願って。
import Data.Char import System.Environment import Text.ParserCombinators.Parsec data Instruction = App (Int,Int) | Abs (Int,[Instruction]) deriving Show data Code = C [Instruction] | Out | Succ | Char Char | In deriving Show data Function = F (Code,Environment) deriving Show type Environment = [Function] type Dump = Environment e0 :: Environment e0 = [F (Out,[]), F (Succ,[]), F (Char 'w',[]), F (In,[])] d0 :: Dump d0 = [F (C [App (1,1)], []), F (C [], [])] eval :: (Code, Environment, Dump) -> IO () eval (C (App (m,n) : c), e, d) = eval (cm, F (cn,en) : em, F (C c,e) : d) where F (cm,em) = e !! (m-1) F (cn,en) = e !! (n-1) eval (C (Abs (1,c') : c), e, d) = eval (C c, F (C c',e) : e, d) eval (C (Abs (n,c') : c), e, d) = eval (C c, F (C [Abs (n-1,c')], e) : e, d) eval (C [], f : e, F (c',e') : d) = eval (c', f : e', d) eval (Out, f @ (F (Char c,_)) : e, d) = putChar c >> eval (C [], f : f : e, d) eval (Out, F (c',f) : _, _) = error $ "Not a character: " ++ show c' eval (In, e, d) = do {c <- getChar; eval (C [], F (Char c,[]) : e, d)} `catch` const (eval (C [], e, d)) eval (Succ, f @ (F (Char c,_)) : e, d) = eval (C [], F (Char $ chr $ mod (ord c + 1) 256,[]) : f : e, d) eval (Succ, F (c',f) : _, _) = error $ "Not a character: " ++ show c' eval (Char c0, f @ (F (Char c1,_)) : e, d) = eval (if c0 == c1 then C [Abs (1,[]), Abs (2,[App (3,2)])] else C [Abs (2,[])], f : e, d) eval (Char _, e, d) = eval (C [Abs (2,[])], e, d) eval (C [], _, []) = return () run :: Code -> IO () run c0 = eval (c0, e0, d0) chars :: Char -> Parser Int chars c = return . length =<< many1 (char c) app :: Parser Instruction app = do u <- chars 'W' l <- chars 'w' return $ App (u,l) abst :: Parser Instruction abst = do l <- chars 'w' a <- many app return $ Abs (l,a) body :: Parser [Instruction] body = try (char 'v' >> abst >>= return . (: [])) <|> (char 'v' >> many app >>= return) prog :: Parser [Instruction] prog = do a <- abst bs <- many body eof return $ a : concat bs filter' :: String -> String filter' [] = [] filter' ('W':s) = 'W' : filter' s filter' ('v':s) = 'v' : filter' s filter' ('w':s) = 'w' : filter' s filter' ('\xef':'\xbc':'\xb7':s) = 'W' : filter' s filter' ('\xef':'\xbd':'\x96':s) = 'v' : filter' s filter' ('\xef':'\xbd':'\x97':s) = 'w' : filter' s filter' ('\x82':'\x76':s) = 'W' : filter' s filter' ('\x82':'\x96':s) = 'v' : filter' s filter' ('\x82':'\x97':s) = 'w' : filter' s filter' (_:s) = filter' s parseProg :: String -> Code parseProg s = case parse prog "" $ dropWhile (/= 'w') $ filter' s of Right i -> C i Left err -> error $ show err main :: IO () main = run . parseProg =<< readFile . head =<< getArgs