Difference between revisions of "Haskell Quiz/Bytecode Compiler/Solution Michael Sloan"
Jump to navigation
Jump to search
(sharpen cat) |
|||
(7 intermediate revisions by one other user not shown) | |||
Line 1: | Line 1: | ||
+ | [[Category:Haskell Quiz solutions|Bytecode Compiler]] |
||
+ | |||
+ | This implementation's only deficiancy is no handling of the negation operator. Proper handling isn't implemented in the ruby quiz tests/solns, however at least basic negative numbers should be included. |
||
+ | |||
<haskell>import Char(digitToInt) |
<haskell>import Char(digitToInt) |
||
+ | import Debug.Trace(trace) |
||
− | data Tok = C |
+ | data Tok = C Char |
+ | | N Int |
||
− | |||
+ | | Op Char |
||
+ | | App Tok Tok Tok |
||
+ | | G {members :: [Tok]} |
||
+ | |||
--Debugging porpoises |
--Debugging porpoises |
||
instance Show Tok where |
instance Show Tok where |
||
Line 10: | Line 19: | ||
show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")" |
show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")" |
||
show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]" |
show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]" |
||
+ | |||
− | |||
+ | compile = bytes . parse |
||
+ | |||
+ | parse = stripG . G . foldr ((.) . prec) id "+-*/%^" . pToks . parseNOp . map C |
||
+ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
+ | parseNOp ((C ch):inp) | ch `elem` "()" = (C ch) : (parseNOp inp) |
||
+ | parseNOp ((C ch):inp) = trace ("Skipped char '"++[ch]) (parseNOp inp) |
||
+ | parseNOp (x:inp) = x : (parseNOp inp) |
||
+ | |||
+ | --Groups an array of tokens if it needs to be |
||
g (x:xs) | null xs = x |
g (x:xs) | null xs = x |
||
g xs = G xs |
g xs = G xs |
||
+ | |||
− | |||
+ | --Returns parsed tokens/stream remainder |
||
− | parse xs = prec '+' $ prec '-' $ prec '*' $ prec '/' $ prec '^' $ fst $ parseG $ parseNOp $ map (\ch -> C ch) xs |
||
− | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
− | |||
pToks = fst . parseG |
pToks = fst . parseG |
||
− | pRem = snd . parseG |
+ | pRem = snd . parseG |
+ | |||
− | |||
parseG [] = ([], []) |
parseG [] = ([], []) |
||
parseG [(G ts)] = (ts, []) |
parseG [(G ts)] = (ts, []) |
||
Line 31: | Line 47: | ||
parseG ((C ')') : inp) = ([], inp) |
parseG ((C ')') : inp) = ([], inp) |
||
parseG (i:inp) = (i : (pToks inp), pRem inp) |
parseG (i:inp) = (i : (pToks inp), pRem inp) |
||
+ | |||
− | |||
+ | aPrec mo a (Op o) b = App (g $ prec mo [a]) (Op o) (g $ prec mo [b]) |
||
+ | |||
+ | --Traverses groups, applies operators to their immediate arguments |
||
prec mo [] = [] |
prec mo [] = [] |
||
− | prec mo (( |
+ | prec mo (a:(Op o):b:inp) | o == mo = prec mo ((aPrec mo a (Op o) b) : inp) |
− | prec mo ( |
+ | prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp) |
− | prec mo ((App a o b):inp) = ( |
+ | prec mo ((App a o b):inp) = (aPrec mo a o b) : (prec mo inp) |
prec mo (x:inp) = x : (prec mo inp) |
prec mo (x:inp) = x : (prec mo inp) |
||
+ | |||
− | |||
+ | --Removes any vestigial grouping |
||
stripG (App a o b) = App (stripG a) o (stripG b) |
stripG (App a o b) = App (stripG a) o (stripG b) |
||
− | stripG (G (x:xs)) | null xs = |
+ | stripG (G (x:xs)) | null xs = stripG x |
− | stripG (G (x:xs)) = |
+ | stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here" |
stripG x = x |
stripG x = x |
||
+ | |||
− | |||
+ | --Converts to a byte format |
||
⚫ | |||
− | |||
bytes (C x) = error ("Invalid character: " ++ [x]) |
bytes (C x) = error ("Invalid character: " ++ [x]) |
||
− | bytes (N n) = if abs n < 2^15 then 1 : |
+ | bytes (N n) = if abs n < 2^15 then 1 : toBytes 2 n else 2 : toBytes 4 n |
− | bytes (Op ch) = case ch of '+' -> [10]; ' |
+ | bytes (Op ch) = case ch of '+' -> [10]; '-' -> [11]; '*' -> [12]; '^' -> [13]; '/' -> [14]; '%' -> [15] |
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o) |
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o) |
||
− | bytes x = error ("Error, invalid: " ++ show x) |
+ | bytes x = error ("Error, invalid: " ++ show x) |
+ | |||
⚫ |
Latest revision as of 10:43, 13 January 2007
This implementation's only deficiancy is no handling of the negation operator. Proper handling isn't implemented in the ruby quiz tests/solns, however at least basic negative numbers should be included.
import Char(digitToInt)
import Debug.Trace(trace)
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) ++ "]"
compile = bytes . parse
parse = stripG . G . foldr ((.) . prec) id "+-*/%^" . pToks . parseNOp . map C
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 ((C ch):inp) | ch `elem` "()" = (C ch) : (parseNOp inp)
parseNOp ((C ch):inp) = trace ("Skipped char '"++[ch]) (parseNOp inp)
parseNOp (x:inp) = x : (parseNOp inp)
--Groups an array of tokens if it needs to be
g (x:xs) | null xs = x
g xs = G xs
--Returns parsed tokens/stream remainder
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)
aPrec mo a (Op o) b = App (g $ prec mo [a]) (Op o) (g $ prec mo [b])
--Traverses groups, applies operators to their immediate arguments
prec mo [] = []
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((aPrec mo a (Op o) b) : inp)
prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp)
prec mo ((App a o b):inp) = (aPrec mo a o b) : (prec mo inp)
prec mo (x:inp) = x : (prec mo inp)
--Removes any vestigial grouping
stripG (App a o b) = App (stripG a) o (stripG b)
stripG (G (x:xs)) | null xs = stripG x
stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here"
stripG x = x
--Converts to a byte format
bytes (C x) = error ("Invalid character: " ++ [x])
bytes (N n) = if abs n < 2^15 then 1 : toBytes 2 n else 2 : toBytes 4 n
bytes (Op ch) = case ch of '+' -> [10]; '-' -> [11]; '*' -> [12]; '^' -> [13]; '/' -> [14]; '%' -> [15]
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o)
bytes x = error ("Error, invalid: " ++ show x)
toBytes n x = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]