Write Yourself a Scheme in 48 Ho
2015-09-26 本文已影响171人
阿能是一只猫
原文。
https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Answers
Chapter 1
Exercise 1
main :: IO ()
main = do args <- getArgs
putStrLn ("Hello, " ++ args!!0 ++ " " ++ args!!1)
Exercise 2
main :: IO ()
main = do args <- getArgs
print ((read $ args!!0) + (read $ args!!1))
$操作符减少了这里需要的括号。同样你这里也可以写作read (args!!0)。
Exercise 3
main :: IO ()
main = do putStrLn "What do they call thee at home?"
name <- getLine
putStrLn ("Ey up " ++ name)
Chapter 2
Section 3
Exercise 1
Part 1
parseNumber :: Parser LispVal
parseNumber = do x <- many1 digit
(return . Number . read) x
Part 2
为了回答这个问题，你需要做一点调查的工作！了解以下do表示法是有帮助的，有了这些信息，我们可以简单的将上面的答案转化成这样子：
parseNumber = many1 digit >>= \x -> (return . Number . read) x
可以简写成以下形式：
parseNumber = many1 digit >>= return . Number . read
Exercise 2
我们需要创建一个新的解析操作来处理斜杠后面紧跟着另一个斜杠或者双引号的情况，这个操作需要将解析得到的第二个字符返回。
escapedChars :: Parser Char
escapedChars = do char '\\' -- a backslash
x <- oneOf "\\\"" -- either backslash or doublequote
return x -- return the escaped character
完成之后我们还需要修改下我们的parserString函数：
parseString :: Parser LispVal
parseString = do char '"'
x <- many $ escapedChars <|> noneOf "\"\\"
char '"'
return $ String x
Exercise 3
escapedChars :: Parser Char
escapedChars = do char '\\'
x <- oneOf "\\\"nrt"
return $ case x of
'\\' -> x
'"' -> x
'n' -> '\n'
'r' -> '\r'
't' -> '\t'
Exercise 4
首先我们需要修改symbol函数的定义：
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"
这意味着atom类型不再能够以#符号开始了。这让我们需要换一种方法解析#t和#f。
parseBool :: Parser LispVal
parseBool = do
char '#'
(char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))
这又要求我们继续修改parseExpr函数：
parseExpr :: Parser LispVal
parseExpr = parseAtom
<|> parseString
<|> parseNumber
<|> parseBool
同样parseNumber函数需要如下修改：
parseNumber :: Parser LispVal
parseNumber = parseDigital1 <|> parseDigital2 <|> parseHex <|> parseOct <|> parseBin
然后再添加几个需要的函数：
parseDigital1 :: Parser LispVal
parseDigital1 = many1 digit >>= (return . Number . read)
parseDigital2 :: Parser LispVal
parseDigital2 = do try $ string "#d"
x <- many1 digit
(return . Number . read) x
parseHex :: Parser LispVal
parseHex = do try $ string "#x"
x <- many1 hexDigit
return $ Number (hex2dig x)
parseOct :: Parser LispVal
parseOct = do try $ string "#o"
x <- many1 octDigit
return $ Number (oct2dig x)
parseBin :: Parser LispVal
parseBin = do try $ string "#b"
x <- many1 (oneOf "10")
return $ Number (bin2dig x)
oct2dig x = fst $ readOct x !! 0
hex2dig x = fst $ readHex x !! 0
bin2dig = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in
bin2dig' old xs
导入Numeric模块来使用readOct和readHex函数。
Exercise 5
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Character Char
parseCharacter :: Parser LispVal
parseCharacter = do
try $ string "#\\"
value <- try (string "newline" <|> string "space")
<|> do { x <- anyChar; notFollowedBy alphaNum ; return [x] }
return $ Character $ case value of
"space" -> ' '
"newline" -> '\n'
otherwise -> (value !! 0)
anyChar和notFollowedBy的组合保证了每次只有一个字符被读入。
注意这里其实并没有完全遵从标准：这里space和newline字符串都需要时小写的，而标准里则强调它们其实是大小写不敏感的。
parseExpr :: Parser LispVal
parseExpr = parseAtom
<|> parseString
<|> try parseNumber -- we need the 'try' because
<|> try parseBool -- these can all start with the hash char
<|> try parseCharacter
Exercise 6
一种浮点数的解决方案：
parseFloat :: Parser LispVal
parseFloat = do x <- many1 digit
char '.'
y <- many1 digit
return $ Float (fst.head$readFloat (x++"."++y))
然后在parseExpr的parseNumber行之前添加：
try parseFloat
并且添加对应的数据类型到LispVal得定义。
| Float Double
Exercise 7
分数，使用Haskell内置的分数类型：
parseRatio :: Parser LispVal
parseRatio = do x <- many1 digit
char '/'
y <- many1 digit
return $ Ratio ((read x) % (read y))
需要额外导入Data.Ratio模块，然后在parseExpr函数的parseNumber前添加以下内容：
try parseRatio
同样在LispVal中添加：
| Ratio Rational
实数在练习6中已经定义过了。除非我搞错了。
复数部分会用到Haskell的复数类型：
toDouble :: LispVal -> Double
toDouble(Float f) = realToFrac f
toDouble(Number n) = fromIntegral n
parseComplex :: Parser LispVal
parseComplex = do x <- (try parseFloat <|> parseDecimal)
char '+'
y <- (try parseFloat <|> parseDecimal)
char 'i'
return $ Complex (toDouble x :+ toDouble y)
你需要预先导入Data.Complex模块，然后再parseExpr的parseNumber和parseFloat之前添加：
try parseComplex
并在LispVal的定义中添加：
| Complex (Complex Double)
Section 4
Exercise 1
这两部分都和parseQuoted类似：
parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
char '`'
x <- parseExpr
return $ List [Atom "quasiquote", x]
parseUnQuote :: Parser LispVal
parseUnQuote = do
char ','
x <- parseExpr
return $ List [Atom "unquote", x]
然后在parseExpr中添加：
<|> parseQuasiQuoted
<|> parseUnQuote
Exercise 2
我选择使用Data.Array模块中的数组，并使用列表到数组的转换器来作为数组的构造器：
parseVector :: Parser LispVal
parseVector = do arrayValues <- sepBy parseExpr spaces
return $ Vector (listArray (0,(length arrayValues - 1)) arrayValues)
导入Data.Array然后在LispVal类型中添加：
| Vector (Array Int LispVal)
在parseExpr中List和DottedList之前添加以下内容：
<|> try (do string "#("
x <- parseVector
char ')'
return x)
Exercise 3
这里我们需要花点心思来操纵sepBy和endBy之类的函数。我首先尝试通过(. degenerate)来对DottedList进行匹配根据匹配的结果进行判断。而且这段代码并不会受首尾出现的空格所影响。
parseAnyList :: Parser LispVal
parseAnyList = do
P.char '('
optionalSpaces
head <- P.sepEndBy parseExpr spaces
tail <- (P.char '.' >> spaces >> parseExpr) <|> return (Nil ())
optionalSpaces
P.char ')'
return $ case tail of
(Nil ()) -> List head
otherwise -> DottedList head tail
另一种使用Nil构造器的解决方法用来更多Parsec库的高级特性。这里spaces函数就是我们教程中定义的那个。
data LispVal = Nil
| Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseList :: Parser LispVal
parseList = between beg end parseList1
where beg = (char '(' >> skipMany space)
end = (skipMany space >> char ')')
parseList1 :: Parser LispVal
parseList1 = do list <- sepEndBy parseExpr spaces
datum <- option Nil (char '.' >> spaces >> parseExpr)
return $ case datum of
Nil -> List list
val -> DottedList list val
另一种没有使用Nil的解决方案。spaces函数是Parsec库自带的，spaces1则是教程中定义的spaces函数。
parseList :: Parser LispVal
parseList = do char '(' >> spaces
head <- parseExpr `sepEndBy` spaces1
do char '.' >> spaces1
tail <- parseExpr
spaces >> char ')'
return $ DottedList head tail
<|> (spaces >> char ')' >> (return $ List head))
Chapter 3
Exercise 1
这里是其中的一部分：
primitives :: [(String , [LispVal] -> LispVal)]
primitives = [("+" , numericBinop (+)) ,
("-" , numericBinop (-)) ,
("*" , numericBinop (*)) ,
("/" , numericBinop div) ,
("mod" , numericBinop mod) ,
("quotient" , numericBinop quot) ,
("remainder" , numericBinop rem) ,
("symbol?" , unaryOp symbolp) ,
("string?" , unaryOp stringp) ,
("number?" , unaryOp numberp) ,
("bool?", unaryOp boolp) ,
("list?" , unaryOp listp)]
unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal
unaryOp f [v] = f v
symbolp, numberp, stringp, boolp, listp :: LispVal -> LispVal
symbolp (Atom _) = Bool True
symbolp _ = Bool False
numberp (Number _) = Bool True
numberp _ = Bool False
stringp (String _) = Bool True
stringp _ = Bool False
boolp (Bool _) = Bool True
boolp _ = Bool False
listp (List _) = Bool True
listp (DottedList _ _) = Bool True
listp _ = Bool False
Exercise 2
unpackNum :: LispVal -> Integer
unpackNum (Number n) = n
unpackNum _ = 0
Exercise 3
在primitives列表中添加symbol到字符串和字符串到symbol的转换函数：
symbol2string, string2symbol :: LispVal -> LispVal
symbol2string (Atom s) = String s
symbol2string _ = String ""
string2symbol (String s) = Atom s
string2symbol _ = Atom ""
这里我们的错误处理会有点问题，不过别担心，之后我们会修复这些问题。
Chapter 5
Exercise 1
eval env (List [Atom "if", pred, conseq, alt]) = do
result <- eval env pred
case result of
Bool False -> eval env alt
Bool True -> eval env conseq
_ -> throwError $ TypeMismatch "bool" pred
Exercise 2
定义一个将equal或者eqv函数作为参数的辅助函数：
eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(all eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqvFunc [x1, x2] of
Left err -> False
Right (Bool val) -> val
调整eqv中的部分：
eqv [l1@(List arg1), l2@(List arg2)] = eqvList eqv [l1, l2]
然后再equal函数中添加List和DottedList对应的部分：
equal :: [LispVal] -> ThrowsError LispVal
equal [l1@(List arg1), l2@(List arg2)] = eqvList equal [l1, l2]
equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]
equal [arg1, arg2] = do
primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
eqvEquals <- eqv [arg1, arg2]
return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
Exercise 3
cond
这里还有很多改善空间！
eval (List ((Atom "cond"):cs)) = do
b <- (liftM (take 1 . dropWhile f) $ mapM condClause cs) >>= cdr
car [b] >>= eval
where condClause (List [p,b]) = do q <- eval p
case q of
Bool _ -> return $ List [q,b]
_ -> throwError $ TypeMismatch "bool" q
condClause v = throwError $ TypeMismatch "(pred body)" v
f = \(List [p,b]) -> case p of
(Bool False) -> True
_ -> False
另一种方法：
eval env (List (Atom "cond" : expr : rest)) = do
eval' expr rest
where eval' (List [cond, value]) (x : xs) = do
result <- eval env cond
case result of
Bool False -> eval' x xs
Bool True -> eval env value
otherwise -> throwError $ TypeMismatch "boolean" cond
eval' (List [Atom "else", value]) [] = do
eval env value
eval' (List [cond, value]) [] = do
result <- eval env cond
case result of
Bool True -> eval env value
otherwise -> throwError $ TypeMismatch "boolean" cond
Yet another approach, piggy-backing off of the already-implemented if:
eval form@(List (Atom "cond" : clauses)) =
if null clauses
then throwError $ BadSpecialForm "no true clause in cond expression: " form
else case head clauses of
List [Atom "else", expr] -> eval expr
List [test, expr] -> eval $ List [Atom "if",
test,
expr,
List (Atom "cond" : tail clauses)]
_ -> throwError $ BadSpecialForm "ill-formed cond expression: " form
case
为了使用elem函数，我们需要在LispVal的定义中添加这么一句deriving (Eq)。
eval form@(List (Atom "case" : key : clauses)) =
if null clauses
then throwError $ BadSpecialForm "no true clause in case expression: " form
else case head clauses of
List (Atom "else" : exprs) -> mapM eval exprs >>= return . last
List ((List datums) : exprs) -> do
result <- eval key
equality <- mapM (\x -> eqv [result, x]) datums
if Boolean True `elem` equality
then mapM eval exprs >>= return . last
else eval $ List (Atom "case" : key : tail clauses)
_ -> throwError $ BadSpecialForm "ill-formed case expression: " form
Exercise 4
期待你的答案！
