Difference between revisions of "Haskell Quiz/Bytecode Compiler/Solution Michael Sloan"
Jump to navigation
Jump to search
Line 1: | Line 1: | ||
− | <haskell>import |
+ | <haskell>import Char(digitToInt) |
− | import qualified Data.Map as Map |
||
− | import Data.List (intersect) |
||
− | import Maybe |
||
− | import Char(digitToInt) |
||
− | data |
+ | data Tok = C Char | N Int | Op Char | App Tok Tok Tok | G {members :: [Tok]} |
− | deriving (Show, Eq) |
||
+ | --Debugging porpoises |
||
− | instance |
+ | instance Show Tok where |
− | x <= y = precedence x <= precedence y |
||
+ | show (C ch) = ch : "" |
||
+ | show (N i) = show i |
||
+ | show (Op ch) = ch : "" |
||
+ | show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")" |
||
+ | show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]" |
||
+ | g (x:xs) | null xs = x |
||
− | precedence (Psh _) = 5 |
||
+ | g xs = G xs |
||
− | precedence Add = 1 |
||
− | precedence Sub = 1 |
||
− | precedence Mul = 2 |
||
− | precedence Mod = 2 |
||
− | precedence Div = 3 |
||
− | precedence Pow = 3 |
||
− | precedence LPar = 4 |
||
− | precedence RPar = 4 |
||
− | opFromChar '+' = Add |
||
− | opFromChar '-' = Sub |
||
− | opFromChar '*' = Mul |
||
− | opFromChar '/' = Div |
||
− | opFromChar '^' = Pow |
||
− | opFromChar '%' = Mod |
||
− | opFromChar '(' = LPar |
||
− | opFromChar ')' = RPar |
||
+ | parse xs = prec '+' $ prec '-' $ prec '*' $ prec '/' $ prec '^' $ fst $ parseG $ parseNOp $ map (\ch -> C ch) xs |
||
− | leftAssoc Pow = False |
||
− | leftAssoc RPar = False |
||
− | leftAssoc _ = True |
||
− | + | parseNOp [] = [] |
|
+ | parseNOp ((N num):(C ch):inp) | ch `elem` "0123456789" = parseNOp (N (num * 10 + digitToInt ch) : inp) |
||
− | infixParse o s [] = if (length $ intersect [LPar, RPar] o) > 0 then error "Mismatched parenthesis" else reverse s ++ o |
||
+ | parseNOp ((C ch):inp) | ch `elem` "0123456789" = parseNOp (N (digitToInt ch) : inp) |
||
− | infixParse (RPar:LPar:o) s xs = infixParse o s xs |
||
+ | parseNOp ((C ch):inp) | ch `elem` "+-*/^%" = parseNOp (Op ch : inp) |
||
− | infixParse o s (x:xs) |
||
+ | parseNOp ((C ch):inp) | ch `elem` " \t\r\n" = parseNOp inp |
||
− | | x `elem` "+-*/^%)" = if not (null o) && (if leftAssoc op then (<=) else (<)) op (o !! 0) then infixParse (tail o) ((o !! 0):s) (x:xs) else infixParse (op:o) s xs |
||
+ | parseNOp (a:inp) = a : (parseNOp inp) |
||
− | | x `elem` "0123456789" = case (if null s then Add else s !! 0) of |
||
− | (Psh cur) -> infixParse ((Psh $ cur * 10 + digitToInt x) : (tail o)) s xs |
||
− | _ -> infixParse ((Psh $ digitToInt x):o) s xs |
||
− | | x == '(' = infixParse (LPar:o) s xs |
||
− | | x `elem` " \t\r\n" = infixParse o s xs |
||
− | where op = opFromChar x |
||
+ | pToks = fst . parseG |
||
⚫ | |||
+ | pRem = snd . parseG |
||
− | toByteArray x n = map (\i -> getByte x i) [(n-1),(n-2)..0] |
||
− | + | parseG [] = ([], []) |
|
+ | parseG [(G ts)] = (ts, []) |
||
− | bytecode (op:xs) = (case op of Add -> [10]; Mul -> [11]; Pow -> [12]; Div -> [14]; Mod -> [15]; (Psh x) -> if (abs x < 2^15) then (1 : toByteArray x 2) else (2 : toByteArray x 4)) ++ bytecode xs</haskell> |
||
+ | parseG ((C '(') : inp) = (g (pToks inp) : (pToks $ pRem inp), []) |
||
+ | parseG ((C ')') : inp) = ([], inp) |
||
+ | parseG (i:inp) = (i : (pToks inp), pRem inp) |
||
+ | |||
+ | prec mo [] = [] |
||
+ | prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp) |
||
+ | prec mo (a:(Op o):b:inp) | o == mo = prec mo ((App (g $ prec mo [a]) (Op o) (g $ prec mo [b])) : inp) |
||
+ | prec mo ((App a o b):inp) = (App (g $ prec mo [a]) o (g $ prec mo [b])) : (prec mo inp) |
||
+ | prec mo (x:inp) = x : (prec mo inp) |
||
+ | |||
+ | stripG (App a o b) = App (stripG a) o (stripG b) |
||
+ | stripG (G (x:xs)) | null xs = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here" |
||
+ | stripG (G (x:xs)) = stripG x |
||
+ | stripG x = x |
||
+ | |||
⚫ | |||
+ | |||
+ | bytes (C x) = error ("Invalid character: " ++ [x]) |
||
+ | bytes (N n) = if abs n < 2^15 then 1 : toByteArray n 2 else 2 : toByteArray n 4 |
||
+ | bytes (Op ch) = case ch of '+' -> [10]; '*' -> [11]; '^' -> [12]; '/' -> [14]; '%' -> [15] |
||
+ | bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o) |
||
+ | bytes x = error ("Error, invalid: " ++ show x)</haskell> |
Revision as of 05:16, 6 November 2006
import Char(digitToInt)
data Tok = C Char | N Int | Op Char | App Tok Tok Tok | G {members :: [Tok]}
--Debugging porpoises
instance Show Tok where
show (C ch) = ch : ""
show (N i) = show i
show (Op ch) = ch : ""
show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")"
show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]"
g (x:xs) | null xs = x
g xs = G xs
parse xs = prec '+' $ prec '-' $ prec '*' $ prec '/' $ prec '^' $ fst $ parseG $ parseNOp $ map (\ch -> C ch) xs
parseNOp [] = []
parseNOp ((N num):(C ch):inp) | ch `elem` "0123456789" = parseNOp (N (num * 10 + digitToInt ch) : inp)
parseNOp ((C ch):inp) | ch `elem` "0123456789" = parseNOp (N (digitToInt ch) : inp)
parseNOp ((C ch):inp) | ch `elem` "+-*/^%" = parseNOp (Op ch : inp)
parseNOp ((C ch):inp) | ch `elem` " \t\r\n" = parseNOp inp
parseNOp (a:inp) = a : (parseNOp inp)
pToks = fst . parseG
pRem = snd . parseG
parseG [] = ([], [])
parseG [(G ts)] = (ts, [])
parseG ((C '(') : inp) = (g (pToks inp) : (pToks $ pRem inp), [])
parseG ((C ')') : inp) = ([], inp)
parseG (i:inp) = (i : (pToks inp), pRem inp)
prec mo [] = []
prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp)
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((App (g $ prec mo [a]) (Op o) (g $ prec mo [b])) : inp)
prec mo ((App a o b):inp) = (App (g $ prec mo [a]) o (g $ prec mo [b])) : (prec mo inp)
prec mo (x:inp) = x : (prec mo inp)
stripG (App a o b) = App (stripG a) o (stripG b)
stripG (G (x:xs)) | null xs = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here"
stripG (G (x:xs)) = stripG x
stripG x = x
toByteArray x n = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]
bytes (C x) = error ("Invalid character: " ++ [x])
bytes (N n) = if abs n < 2^15 then 1 : toByteArray n 2 else 2 : toByteArray n 4
bytes (Op ch) = case ch of '+' -> [10]; '*' -> [11]; '^' -> [12]; '/' -> [14]; '%' -> [15]
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o)
bytes x = error ("Error, invalid: " ++ show x)