这份教程是本很有趣的书，它并不算长－－48学时能有多久呢？Perl有本很有名的24小时教程，可以翻倍类比一下－－但是内容比较丰富。在前言中，作者提出了一些需要注意的地方：
这本书为两种人准备：一是已经学会Lisp和Scheme，准备学Haskell的；一种是不会这些编程语言，但是有比较强的专业背景和知识的。原文是说 “familiar with computer”，不过相信我，这肯定不是电脑城招装高手的那个“熟悉计算机”。
所以，这不是一本入门手册，这是为有一定基础的读者准备的。考虑到Haskell目前是一门如此小众的语言，这样的设定倒也合情合理。
这个邪恶的家伙特别提到，如果你有过程化编程或面向对象的基础，比如学过C、JAVA、Python之类的，这里最好把它们都忘了，因为Haskell中的类型、函数、甚至return，跟你之前习惯的东西完全不是一码事。
哈哈！这正是我兴奋的地方，如果再学一个语言，还是跟以前的差不多，也就没有什么意思了。
差异启迪思想，我不是语言收集狂，我学新东西是想让自己变聪明一些。
这份教材使用的是ghc编译器。我有很久都以为ghc是GNU Haskell Compiler，但它其实是 Glasgow Haskell Compiler。ghc 是目前最受欢迎的Haskell编译器，据作者说 Hugs 可能也能跑这个教程的例子，但是他没有试过……
我的学习笔记不一定就按 48 学时，只是个坑而已，看情况啦。
2008年11月30日星期日
2008年11月28日星期五
钢笔的诱惑
周四早上要出门的时候，想起以后要参加早上的例会。得要做笔记了。于是翻出一个本子，再去找笔。结果发现桌上的一大袋笔只有一只圆珠笔，一只红色的细马克笔，两只粗白板笔，其它都是铅笔。心想家里总要留一只的吧（其实后来想起家里某处好像有一排没开封的圆珠笔）。于是关门下楼，直奔小超市。
小地方，店面不大，文具架只有可怜的一窄条。几只笔筒里插着各种各样的笔。
最里面的地方，我看到几支黑色的钢笔，静静的斜在那里。
伸手摸了过去。
不行，太贵了，三天不写几个字，不值得，放下。
又伸手过去拿起来，拔下笔帽，抚摸笔尖的感觉。沉重的黑色金属笔身，很舒适的手感，英雄，喜欢用这个牌子。
不行，快上班了，拿支一元的水笔吧。
走了两步，又转回头，看货架上的墨水。只有黑的，纯蓝的，问过售货员，没有蓝黑墨水。
死心了，以我这种写字量，用碳素墨水肯定会堵笔尖的。
拿了支长得很像钢笔的圆珠笔。也是金属外壳，沉重的手感。
我如此深爱那种粗重的笔杆，流暢的手感。尽管我的字迹如此糟糕，现在一天也只有几次写字的机会。
丢过很多笔，包括最喜欢的一支。
用坏过很多笔，我曾经总是忍不住要毁坏文具，大概那时候心理上有某种强迫症。
曾经被大人细心教导，如何握笔写字，却从未有学会过正确的姿势。
曾经被教育，要端端正正的写字，堂堂正正的作人，但是一直没有学会漂亮的笔迹。
曾经被教育，一定要用钢笔，才能练出漂亮的字。我一直喜欢钢笔，字迹还是那么糟。
曾经，我们期待和被期待着的成长，在时间中慢慢变成不可能的幻想。
只有一些痕迹留下来。
小地方，店面不大，文具架只有可怜的一窄条。几只笔筒里插着各种各样的笔。
最里面的地方，我看到几支黑色的钢笔，静静的斜在那里。
伸手摸了过去。
不行，太贵了，三天不写几个字，不值得，放下。
又伸手过去拿起来，拔下笔帽，抚摸笔尖的感觉。沉重的黑色金属笔身，很舒适的手感，英雄，喜欢用这个牌子。
不行，快上班了，拿支一元的水笔吧。
走了两步，又转回头，看货架上的墨水。只有黑的，纯蓝的，问过售货员，没有蓝黑墨水。
死心了，以我这种写字量，用碳素墨水肯定会堵笔尖的。
拿了支长得很像钢笔的圆珠笔。也是金属外壳，沉重的手感。
我如此深爱那种粗重的笔杆，流暢的手感。尽管我的字迹如此糟糕，现在一天也只有几次写字的机会。
丢过很多笔，包括最喜欢的一支。
用坏过很多笔，我曾经总是忍不住要毁坏文具，大概那时候心理上有某种强迫症。
曾经被大人细心教导，如何握笔写字，却从未有学会过正确的姿势。
曾经被教育，要端端正正的写字，堂堂正正的作人，但是一直没有学会漂亮的笔迹。
曾经被教育，一定要用钢笔，才能练出漂亮的字。我一直喜欢钢笔，字迹还是那么糟。
曾经，我们期待和被期待着的成长，在时间中慢慢变成不可能的幻想。
只有一些痕迹留下来。
读了一遍《Write Yourself a Scheme in 48 Hours》
很惭愧，Lee同学几年前就向我推荐《Write Yourself a Scheme in 48 Hours》，而我到最近才把它真正过了一遍。
收获很大，谢谢Lee。
这本书以step by step的方式，教给读者如何在48学时编写出一个Scheme解释器。
这本书可以说是经典的“第二本”读物。通过快速原型，逐步迭代的方式，引入haskell语法的方方面面，特别是各种monad的运用。如果你和我一样读入门教材时被卡在monad进退不能，这本书会帮你解脱。
书中没有使用haskell系统库之外的程序资源，仅仅以414行代码完成一个实用的scheme解释器，充分展示了haskell的强大。
在粗读过后，我准备逐章重新精读这篇教程，把内容彻底消化。
最后，要感谢太太的支持。感谢发芽网提供了一个很好的服务，让我可以轻松的记录学习进度。我的代码记录在这里。
书中使用的Scheme标准库源码stdlib.scm:
收获很大，谢谢Lee。
这本书以step by step的方式，教给读者如何在48学时编写出一个Scheme解释器。
这本书可以说是经典的“第二本”读物。通过快速原型，逐步迭代的方式，引入haskell语法的方方面面，特别是各种monad的运用。如果你和我一样读入门教材时被卡在monad进退不能，这本书会帮你解脱。
书中没有使用haskell系统库之外的程序资源，仅仅以414行代码完成一个实用的scheme解释器，充分展示了haskell的强大。
在粗读过后，我准备逐章重新精读这篇教程，把内容彻底消化。
最后，要感谢太太的支持。感谢发芽网提供了一个很好的服务，让我可以轻松的记录学习进度。我的代码记录在这里。
Haskell语言: 48 小时编写sheme解释器的学习笔记－SimpleParser.hs
001 module Main where
002 import Monad
003 import Control.Monad.Error
004 import System.Environment
005 import IO hiding (try)
006 import Data.IORef
007 import Text.ParserCombinators.Parsec hiding (spaces)
008
009 symbol :: Parser Char
010 symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
011
012 data LispVal = Atom String
013 | List [LispVal]
014 | DottedList [LispVal] LispVal
015 | Number Integer
016 | String String
017 | Bool Bool
018 | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
019 | Func {params :: [String], vararg :: (Maybe String),
020 body :: [LispVal], closure :: Env}
021 | IOFunc ([LispVal] -> IOThrowsError LispVal)
022 | Port Handle
023
024 data LispError = NumArgs Integer [LispVal]
025 | TypeMismatch String LispVal
026 | Parser ParseError
027 | BadSpecialForm String LispVal
028 | NotFunction String String
029 | UnboundVar String String
030 | Default String
031
032 spaces :: Parser ()
033 spaces = skipMany1 space
034
035 parseString :: Parser LispVal
036 parseString = do char '"'
037 x <- many (noneOf "\"")
038 char '"'
039 return $ String x
040
041 parseAtom :: Parser LispVal
042 parseAtom = do first <- letter <|> symbol
043 rest <- many (letter <|> digit <|> symbol)
044 let atom = first:rest
045 return $ case atom of
046 "#t" -> Bool True
047 "#f" -> Bool False
048 otherwise -> Atom atom
049
050 parseNumber :: Parser LispVal
051 parseNumber = liftM (Number . read) $ many1 digit
052
053 parseExpr :: Parser LispVal
054 parseExpr = parseAtom
055 <|> parseString
056 <|> parseNumber
057 <|> parseQuoted
058 <|> do char '('
059 x <- (try parseList) <|> parseDottedList
060 char ')'
061 return x
062
063 parseList :: Parser LispVal
064 parseList = liftM List $ sepBy parseExpr spaces
065
066 parseDottedList :: Parser LispVal
067 parseDottedList = do
068 head <- endBy parseExpr spaces
069 tail <- char '.' >> spaces >> parseExpr
070 return $ DottedList head tail
071
072 parseQuoted :: Parser LispVal
073 parseQuoted = do
074 char '\''
075 x <- parseExpr
076 return $ List [Atom "quote", x]
077
078 eval :: Env -> LispVal -> IOThrowsError LispVal
079 eval env val@(String _) = return val
080 eval env val@(Number _) = return val
081 eval env val@(Bool _) = return val
082 eval env (Atom id) = getVar env id
083 eval env (List [Atom "quote", val]) = return val
084 eval env (List [Atom "if", pred, conseq, alt]) =
085 do result <- eval env pred
086 case result of
087 Bool False -> eval env alt
088 otherwise -> eval env conseq
089 eval env (List [Atom "set!", Atom var, form]) =
090 eval env form >>= setVar env var
091 eval env (List [Atom "load", String filename]) =
092 load filename >>= liftM last . mapM (eval env)
093 eval env (List [Atom "define", Atom var, form]) =
094 eval env form >>= defineVar env var
095 eval env (List (Atom "define" : List (Atom var : params) : body)) =
096 makeNormalFunc env params body >>= defineVar env var
097 eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
098 makeVarargs varargs env params body >>= defineVar env var
099 eval env (List (Atom "lambda" : List params : body)) =
100 makeNormalFunc env params body
101 eval env (List (Atom "lambda" : DottedList params varargs : body)) =
102 makeVarargs varargs env [] body
103 eval env (List (function : args)) = do
104 func <- eval env function
105 argVals <- mapM (eval env) args
106 apply func argVals
107 eval env badForm = throwError $ BadSpecialForm "Unrecongnized special form" badForm
108
109 car :: [LispVal] -> ThrowsError LispVal
110 car [List (x : xs)] = return x
111 car [DottedList (x : xs) _] = return x
112 car [badArg] = throwError $ TypeMismatch "pair" badArg
113 car badArgList = throwError $ NumArgs 1 badArgList
114
115 cdr :: [LispVal] -> ThrowsError LispVal
116 cdr [List (x : xs)] = return $ List xs
117 cdr [DottedList [xs] x] = return x
118 cdr [DottedList (_ : xs) x] = return $ DottedList xs x
119 cdr [badArg] = throwError $ TypeMismatch "pair" badArg
120 cdr badArgList = throwError $ NumArgs 1 badArgList
121
122
123 cons :: [LispVal] -> ThrowsError LispVal
124 cons [x1, List []] = return $ List [x1]
125 cons [x, List xs] = return $ List $ [x] ++ xs
126 cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
127 cons [x1, x2] = return $ DottedList [x1] x2
128 cons badArgList = throwError $ NumArgs 2 badArgList
129
130 eqv :: [LispVal] -> ThrowsError LispVal
131 eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
132 eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
133 eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
134 eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
135 eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && (and $ map eqvPair $ zip arg1 arg2)
136 where eqvPair (x1, x2) = case eqv [x1, x2] of
137 Left err -> False
138 Right (Bool val) -> val
139 eqv [_, _] = return $ Bool False
140 eqv badArgList = throwError $ NumArgs 2 badArgList
141
142 data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
143
144 unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
145 unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1
146 unpacked2 <- unpacker arg2
147 return $ unpacked1 == unpacked2
148 `catchError` (const $ return False)
149
150 equal :: [LispVal] -> ThrowsError LispVal
151 equal [arg1, arg2] = do
152 primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
153 [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
154 eqvEquals <- eqv [arg1, arg2]
155 return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
156 equal badArgList = throwError $ NumArgs 2 badArgList
157
158 apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
159 apply (PrimitiveFunc func) args = liftThrows $ func args
160 apply (Func params varargs body closure) args =
161 if num params /= num args && varargs == Nothing
162 then throwError $ NumArgs (num params) args
163 else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
164 where remainingArgs = drop (length params) args
165 num = toInteger . length
166 evalBody env = liftM last $ mapM (eval env) body
167 bindVarArgs arg env = case arg of
168 Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
169 Nothing -> return env
170 apply (IOFunc func) args = func args
171
172 applyProc :: [LispVal] -> IOThrowsError LispVal
173 applyProc [func, List args] = apply func args
174 applyProc (func : args) = apply func args
175
176 makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
177 makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
178
179 closePort :: [LispVal] -> IOThrowsError LispVal
180 closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
181 closePort _ = return $ Bool False
182
183 readProc :: [LispVal] -> IOThrowsError LispVal
184 readProc [] = readProc [Port stdin]
185 readProc [Port port] = (liftIO $ hGetLine stdin) >>= liftThrows . readExpr
186
187 writeProc :: [LispVal] -> IOThrowsError LispVal
188 writeProc [obj] = writeProc [obj, Port stdout]
189 writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
190
191 readContents :: [LispVal] -> IOThrowsError LispVal
192 readContents [String filename] = liftM String $ liftIO $ readFile filename
193
194 load :: String -> IOThrowsError [LispVal]
195 load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
196
197 readAll :: [LispVal] -> IOThrowsError LispVal
198 readAll [String filename] = liftM List $ load filename
199
200 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
201 primitives = [("+", numericBinop (+)),
202 ("-", numericBinop (-)),
203 ("*", numericBinop (*)),
204 ("/", numericBinop (div)),
205 ("mod", numericBinop mod),
206 ("quotient", numericBinop quot),
207 ("remainder", numericBinop rem),
208 ("=", numBoolBinop (==)),
209 ("<", numBoolBinop (<)),
210 (">", numBoolBinop (>)),
211 ("/=", numBoolBinop (/=)),
212 (">=", numBoolBinop (>=)),
213 ("<=", numBoolBinop (<=)),
214 ("&&", boolBoolBinop (&&)),
215 ("||", boolBoolBinop (||)),
216 ("string=?", strBoolBinop (==)),
217 ("string<?", strBoolBinop (<)),
218 ("string>?", strBoolBinop (>)),
219 ("string<=?", strBoolBinop (<=)),
220 ("string>=?", strBoolBinop (>=)),
221 ("car", car),
222 ("cdr", cdr),
223 ("cons", cons),
224 ("eq?", eqv),
225 ("eqv?", eqv),
226 ("equal?", equal)]
227
228 ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
229 ioPrimitives = [("apply", applyProc),
230 ("open-input-file", makePort ReadMode),
231 ("open-output-file", makePort WriteMode),
232 ("close-input-port", closePort),
233 ("close-output-port", closePort),
234 ("read", readProc),
235 ("write", writeProc),
236 ("read-contents", readContents),
237 ("read-all", readAll)]
238
239 primitiveBindings :: IO Env
240 primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
241 ++ map (makeFunc PrimitiveFunc) primitives)
242 where makeFunc constructor (var, func) = (var, constructor func)
243
244 numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
245 numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
246 numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
247
248 boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
249 boolBinop unpacker op args = if length args /= 2
250 then throwError $ NumArgs 2 args
251 else do left <- unpacker $ args !! 0
252 right <- unpacker $ args !! 1
253 return $ Bool $ left `op` right
254
255 numBoolBinop = boolBinop unpackNum
256 strBoolBinop = boolBinop unpackStr
257 boolBoolBinop = boolBinop unpackBool
258
259 unpackNum :: LispVal -> ThrowsError Integer
260 unpackNum (Number n) = return n
261 unpackNum (String n) = let parsed = reads n in
262 if null parsed
263 then throwError $ TypeMismatch "number" $ String n
264 else return $ fst $ parsed !! 0
265 unpackNum (List [n]) = unpackNum n
266 unpackNum notNum = throwError $ TypeMismatch "number" notNum
267
268 unpackStr :: LispVal -> ThrowsError String
269 unpackStr (String s) = return s
270 unpackStr (Number s) = return $ show s
271 unpackStr (Bool s) = return $ show s
272 unpackStr notString = throwError $ TypeMismatch "string" notString
273
274 unpackBool :: LispVal -> ThrowsError Bool
275 unpackBool (Bool b) = return b
276 unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
277
278 readOrThrow :: Parser a -> String -> ThrowsError a
279 readOrThrow parser input = case parse parser "lisp" input of
280 Left err -> throwError $ Parser err
281 Right val -> return val
282
283 readExpr :: String -> ThrowsError LispVal
284 readExpr = readOrThrow parseExpr
285 readExprList = readOrThrow (endBy parseExpr spaces)
286
287 showVal :: LispVal -> String
288 showVal (String contents) = "\"" ++ contents ++ "\""
289 showVal (Atom name) = name
290 showVal (Number contents) = show contents
291 showVal (Bool True) = "#t"
292 showVal (Bool False) = "#f"
293 showVal (List contents) = "(" ++ unwordsList contents ++ ")"
294 showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
295 showVal (PrimitiveFunc _) = "<primitive>"
296 showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
297 "(lambda (" ++ unwords (map show args) ++
298 (case varargs of
299 Nothing -> ""
300 Just arg -> " . " ++ arg) ++ ") ...)"
301 showVal (Port _) = "<IO port>"
302 showVal (IOFunc _) = "<IO primitive>"
303
304 showError :: LispError -> String
305 showError (UnboundVar message varname) = message ++ ": " ++ varname
306 showError (BadSpecialForm message form) = message ++ ": " ++ show form
307 showError (NotFunction message func) = message ++ ": " ++ show func
308 showError (NumArgs expected found) = "Expected " ++ show expected
309 ++ " args; found values " ++ unwordsList found
310 showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
311 showError (Parser parseErr) = "Parse error at " ++ show parseErr
312
313 instance Show LispError where show = showError
314
315 instance Error LispError where
316 noMsg = Default "An error has occurred"
317 strMsg = Default
318
319 type ThrowsError = Either LispError
320
321 trapError action = catchError action (return . show)
322
323 extractValue :: ThrowsError a -> a
324 extractValue (Right val) = val
325
326 unwordsList :: [LispVal] -> String
327 unwordsList = unwords . map showVal
328
329 instance Show LispVal where show = showVal
330
331 type Env = IORef [(String, IORef LispVal)]
332
333 nullEnv :: IO Env
334 nullEnv = newIORef []
335
336 type IOThrowsError = ErrorT LispError IO
337 liftThrows :: ThrowsError a -> IOThrowsError a
338 liftThrows (Left err) = throwError err
339 liftThrows (Right val) = return val
340
341 runIOThrows :: IOThrowsError String -> IO String
342 runIOThrows action = runErrorT (trapError action) >>= return . extractValue
343
344 isBound :: Env -> String -> IO Bool
345 isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
346
347 getVar :: Env -> String -> IOThrowsError LispVal
348 getVar envRef var = do env <- liftIO $ readIORef envRef
349 maybe (throwError $ UnboundVar "Getting an unbound variable" var)
350 (liftIO . readIORef)
351 (lookup var env)
352
353 setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
354 setVar envRef var value = do env <- liftIO $ readIORef envRef
355 maybe (throwError $ UnboundVar "Setting an unbound variable" var)
356 (liftIO . (flip writeIORef value))
357 (lookup var env)
358 return value
359
360 defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
361 defineVar envRef var value = do
362 alreadyDefined <- liftIO $ isBound envRef var
363 if alreadyDefined
364 then setVar envRef var value >> return value
365 else liftIO $ do
366 valueRef <- newIORef value
367 env <- readIORef envRef
368 writeIORef envRef ((var, valueRef) : env)
369 return value
370
371 makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
372
373 makeNormalFunc = makeFunc Nothing
374
375 makeVarargs = makeFunc . Just . showVal
376
377 bindVars :: Env -> [(String, LispVal)] -> IO Env
378 bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
379 where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
380 addBinding (var, value) = do ref <- newIORef value
381 return (var, ref)
382
383 flushStr :: String -> IO()
384 flushStr str = putStr str >> hFlush stdout
385
386 readPrompt :: String -> IO String
387 readPrompt prompt = flushStr prompt >> getLine
388
389 evalString :: Env -> String -> IO String
390 evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
391
392 evalAndPrint :: Env -> String -> IO ()
393 evalAndPrint env expr = evalString env expr >>= putStrLn
394
395
396
397 until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
398 until_ pred prompt action = do
399 result <- prompt
400 if pred result
401 then return ()
402 else action result >> until_ pred prompt action
403
404 runOne :: [String] -> IO ()
405 runOne args = do
406 env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
407 (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
408 >>= hPutStrLn stderr
409
410 runRepl :: IO ()
411 runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
412
413 main :: IO()
414 main = do args <- getArgs
415 if null args then runRepl else runOne $ args
002 import Monad
003 import Control.Monad.Error
004 import System.Environment
005 import IO hiding (try)
006 import Data.IORef
007 import Text.ParserCombinators.Parsec hiding (spaces)
008
009 symbol :: Parser Char
010 symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
011
012 data LispVal = Atom String
013 | List [LispVal]
014 | DottedList [LispVal] LispVal
015 | Number Integer
016 | String String
017 | Bool Bool
018 | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
019 | Func {params :: [String], vararg :: (Maybe String),
020 body :: [LispVal], closure :: Env}
021 | IOFunc ([LispVal] -> IOThrowsError LispVal)
022 | Port Handle
023
024 data LispError = NumArgs Integer [LispVal]
025 | TypeMismatch String LispVal
026 | Parser ParseError
027 | BadSpecialForm String LispVal
028 | NotFunction String String
029 | UnboundVar String String
030 | Default String
031
032 spaces :: Parser ()
033 spaces = skipMany1 space
034
035 parseString :: Parser LispVal
036 parseString = do char '"'
037 x <- many (noneOf "\"")
038 char '"'
039 return $ String x
040
041 parseAtom :: Parser LispVal
042 parseAtom = do first <- letter <|> symbol
043 rest <- many (letter <|> digit <|> symbol)
044 let atom = first:rest
045 return $ case atom of
046 "#t" -> Bool True
047 "#f" -> Bool False
048 otherwise -> Atom atom
049
050 parseNumber :: Parser LispVal
051 parseNumber = liftM (Number . read) $ many1 digit
052
053 parseExpr :: Parser LispVal
054 parseExpr = parseAtom
055 <|> parseString
056 <|> parseNumber
057 <|> parseQuoted
058 <|> do char '('
059 x <- (try parseList) <|> parseDottedList
060 char ')'
061 return x
062
063 parseList :: Parser LispVal
064 parseList = liftM List $ sepBy parseExpr spaces
065
066 parseDottedList :: Parser LispVal
067 parseDottedList = do
068 head <- endBy parseExpr spaces
069 tail <- char '.' >> spaces >> parseExpr
070 return $ DottedList head tail
071
072 parseQuoted :: Parser LispVal
073 parseQuoted = do
074 char '\''
075 x <- parseExpr
076 return $ List [Atom "quote", x]
077
078 eval :: Env -> LispVal -> IOThrowsError LispVal
079 eval env val@(String _) = return val
080 eval env val@(Number _) = return val
081 eval env val@(Bool _) = return val
082 eval env (Atom id) = getVar env id
083 eval env (List [Atom "quote", val]) = return val
084 eval env (List [Atom "if", pred, conseq, alt]) =
085 do result <- eval env pred
086 case result of
087 Bool False -> eval env alt
088 otherwise -> eval env conseq
089 eval env (List [Atom "set!", Atom var, form]) =
090 eval env form >>= setVar env var
091 eval env (List [Atom "load", String filename]) =
092 load filename >>= liftM last . mapM (eval env)
093 eval env (List [Atom "define", Atom var, form]) =
094 eval env form >>= defineVar env var
095 eval env (List (Atom "define" : List (Atom var : params) : body)) =
096 makeNormalFunc env params body >>= defineVar env var
097 eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
098 makeVarargs varargs env params body >>= defineVar env var
099 eval env (List (Atom "lambda" : List params : body)) =
100 makeNormalFunc env params body
101 eval env (List (Atom "lambda" : DottedList params varargs : body)) =
102 makeVarargs varargs env [] body
103 eval env (List (function : args)) = do
104 func <- eval env function
105 argVals <- mapM (eval env) args
106 apply func argVals
107 eval env badForm = throwError $ BadSpecialForm "Unrecongnized special form" badForm
108
109 car :: [LispVal] -> ThrowsError LispVal
110 car [List (x : xs)] = return x
111 car [DottedList (x : xs) _] = return x
112 car [badArg] = throwError $ TypeMismatch "pair" badArg
113 car badArgList = throwError $ NumArgs 1 badArgList
114
115 cdr :: [LispVal] -> ThrowsError LispVal
116 cdr [List (x : xs)] = return $ List xs
117 cdr [DottedList [xs] x] = return x
118 cdr [DottedList (_ : xs) x] = return $ DottedList xs x
119 cdr [badArg] = throwError $ TypeMismatch "pair" badArg
120 cdr badArgList = throwError $ NumArgs 1 badArgList
121
122
123 cons :: [LispVal] -> ThrowsError LispVal
124 cons [x1, List []] = return $ List [x1]
125 cons [x, List xs] = return $ List $ [x] ++ xs
126 cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
127 cons [x1, x2] = return $ DottedList [x1] x2
128 cons badArgList = throwError $ NumArgs 2 badArgList
129
130 eqv :: [LispVal] -> ThrowsError LispVal
131 eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
132 eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
133 eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
134 eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
135 eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && (and $ map eqvPair $ zip arg1 arg2)
136 where eqvPair (x1, x2) = case eqv [x1, x2] of
137 Left err -> False
138 Right (Bool val) -> val
139 eqv [_, _] = return $ Bool False
140 eqv badArgList = throwError $ NumArgs 2 badArgList
141
142 data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
143
144 unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
145 unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1
146 unpacked2 <- unpacker arg2
147 return $ unpacked1 == unpacked2
148 `catchError` (const $ return False)
149
150 equal :: [LispVal] -> ThrowsError LispVal
151 equal [arg1, arg2] = do
152 primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
153 [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
154 eqvEquals <- eqv [arg1, arg2]
155 return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
156 equal badArgList = throwError $ NumArgs 2 badArgList
157
158 apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
159 apply (PrimitiveFunc func) args = liftThrows $ func args
160 apply (Func params varargs body closure) args =
161 if num params /= num args && varargs == Nothing
162 then throwError $ NumArgs (num params) args
163 else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
164 where remainingArgs = drop (length params) args
165 num = toInteger . length
166 evalBody env = liftM last $ mapM (eval env) body
167 bindVarArgs arg env = case arg of
168 Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
169 Nothing -> return env
170 apply (IOFunc func) args = func args
171
172 applyProc :: [LispVal] -> IOThrowsError LispVal
173 applyProc [func, List args] = apply func args
174 applyProc (func : args) = apply func args
175
176 makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
177 makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
178
179 closePort :: [LispVal] -> IOThrowsError LispVal
180 closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
181 closePort _ = return $ Bool False
182
183 readProc :: [LispVal] -> IOThrowsError LispVal
184 readProc [] = readProc [Port stdin]
185 readProc [Port port] = (liftIO $ hGetLine stdin) >>= liftThrows . readExpr
186
187 writeProc :: [LispVal] -> IOThrowsError LispVal
188 writeProc [obj] = writeProc [obj, Port stdout]
189 writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
190
191 readContents :: [LispVal] -> IOThrowsError LispVal
192 readContents [String filename] = liftM String $ liftIO $ readFile filename
193
194 load :: String -> IOThrowsError [LispVal]
195 load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
196
197 readAll :: [LispVal] -> IOThrowsError LispVal
198 readAll [String filename] = liftM List $ load filename
199
200 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
201 primitives = [("+", numericBinop (+)),
202 ("-", numericBinop (-)),
203 ("*", numericBinop (*)),
204 ("/", numericBinop (div)),
205 ("mod", numericBinop mod),
206 ("quotient", numericBinop quot),
207 ("remainder", numericBinop rem),
208 ("=", numBoolBinop (==)),
209 ("<", numBoolBinop (<)),
210 (">", numBoolBinop (>)),
211 ("/=", numBoolBinop (/=)),
212 (">=", numBoolBinop (>=)),
213 ("<=", numBoolBinop (<=)),
214 ("&&", boolBoolBinop (&&)),
215 ("||", boolBoolBinop (||)),
216 ("string=?", strBoolBinop (==)),
217 ("string<?", strBoolBinop (<)),
218 ("string>?", strBoolBinop (>)),
219 ("string<=?", strBoolBinop (<=)),
220 ("string>=?", strBoolBinop (>=)),
221 ("car", car),
222 ("cdr", cdr),
223 ("cons", cons),
224 ("eq?", eqv),
225 ("eqv?", eqv),
226 ("equal?", equal)]
227
228 ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
229 ioPrimitives = [("apply", applyProc),
230 ("open-input-file", makePort ReadMode),
231 ("open-output-file", makePort WriteMode),
232 ("close-input-port", closePort),
233 ("close-output-port", closePort),
234 ("read", readProc),
235 ("write", writeProc),
236 ("read-contents", readContents),
237 ("read-all", readAll)]
238
239 primitiveBindings :: IO Env
240 primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
241 ++ map (makeFunc PrimitiveFunc) primitives)
242 where makeFunc constructor (var, func) = (var, constructor func)
243
244 numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
245 numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
246 numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
247
248 boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
249 boolBinop unpacker op args = if length args /= 2
250 then throwError $ NumArgs 2 args
251 else do left <- unpacker $ args !! 0
252 right <- unpacker $ args !! 1
253 return $ Bool $ left `op` right
254
255 numBoolBinop = boolBinop unpackNum
256 strBoolBinop = boolBinop unpackStr
257 boolBoolBinop = boolBinop unpackBool
258
259 unpackNum :: LispVal -> ThrowsError Integer
260 unpackNum (Number n) = return n
261 unpackNum (String n) = let parsed = reads n in
262 if null parsed
263 then throwError $ TypeMismatch "number" $ String n
264 else return $ fst $ parsed !! 0
265 unpackNum (List [n]) = unpackNum n
266 unpackNum notNum = throwError $ TypeMismatch "number" notNum
267
268 unpackStr :: LispVal -> ThrowsError String
269 unpackStr (String s) = return s
270 unpackStr (Number s) = return $ show s
271 unpackStr (Bool s) = return $ show s
272 unpackStr notString = throwError $ TypeMismatch "string" notString
273
274 unpackBool :: LispVal -> ThrowsError Bool
275 unpackBool (Bool b) = return b
276 unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
277
278 readOrThrow :: Parser a -> String -> ThrowsError a
279 readOrThrow parser input = case parse parser "lisp" input of
280 Left err -> throwError $ Parser err
281 Right val -> return val
282
283 readExpr :: String -> ThrowsError LispVal
284 readExpr = readOrThrow parseExpr
285 readExprList = readOrThrow (endBy parseExpr spaces)
286
287 showVal :: LispVal -> String
288 showVal (String contents) = "\"" ++ contents ++ "\""
289 showVal (Atom name) = name
290 showVal (Number contents) = show contents
291 showVal (Bool True) = "#t"
292 showVal (Bool False) = "#f"
293 showVal (List contents) = "(" ++ unwordsList contents ++ ")"
294 showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
295 showVal (PrimitiveFunc _) = "<primitive>"
296 showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
297 "(lambda (" ++ unwords (map show args) ++
298 (case varargs of
299 Nothing -> ""
300 Just arg -> " . " ++ arg) ++ ") ...)"
301 showVal (Port _) = "<IO port>"
302 showVal (IOFunc _) = "<IO primitive>"
303
304 showError :: LispError -> String
305 showError (UnboundVar message varname) = message ++ ": " ++ varname
306 showError (BadSpecialForm message form) = message ++ ": " ++ show form
307 showError (NotFunction message func) = message ++ ": " ++ show func
308 showError (NumArgs expected found) = "Expected " ++ show expected
309 ++ " args; found values " ++ unwordsList found
310 showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
311 showError (Parser parseErr) = "Parse error at " ++ show parseErr
312
313 instance Show LispError where show = showError
314
315 instance Error LispError where
316 noMsg = Default "An error has occurred"
317 strMsg = Default
318
319 type ThrowsError = Either LispError
320
321 trapError action = catchError action (return . show)
322
323 extractValue :: ThrowsError a -> a
324 extractValue (Right val) = val
325
326 unwordsList :: [LispVal] -> String
327 unwordsList = unwords . map showVal
328
329 instance Show LispVal where show = showVal
330
331 type Env = IORef [(String, IORef LispVal)]
332
333 nullEnv :: IO Env
334 nullEnv = newIORef []
335
336 type IOThrowsError = ErrorT LispError IO
337 liftThrows :: ThrowsError a -> IOThrowsError a
338 liftThrows (Left err) = throwError err
339 liftThrows (Right val) = return val
340
341 runIOThrows :: IOThrowsError String -> IO String
342 runIOThrows action = runErrorT (trapError action) >>= return . extractValue
343
344 isBound :: Env -> String -> IO Bool
345 isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
346
347 getVar :: Env -> String -> IOThrowsError LispVal
348 getVar envRef var = do env <- liftIO $ readIORef envRef
349 maybe (throwError $ UnboundVar "Getting an unbound variable" var)
350 (liftIO . readIORef)
351 (lookup var env)
352
353 setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
354 setVar envRef var value = do env <- liftIO $ readIORef envRef
355 maybe (throwError $ UnboundVar "Setting an unbound variable" var)
356 (liftIO . (flip writeIORef value))
357 (lookup var env)
358 return value
359
360 defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
361 defineVar envRef var value = do
362 alreadyDefined <- liftIO $ isBound envRef var
363 if alreadyDefined
364 then setVar envRef var value >> return value
365 else liftIO $ do
366 valueRef <- newIORef value
367 env <- readIORef envRef
368 writeIORef envRef ((var, valueRef) : env)
369 return value
370
371 makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
372
373 makeNormalFunc = makeFunc Nothing
374
375 makeVarargs = makeFunc . Just . showVal
376
377 bindVars :: Env -> [(String, LispVal)] -> IO Env
378 bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
379 where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
380 addBinding (var, value) = do ref <- newIORef value
381 return (var, ref)
382
383 flushStr :: String -> IO()
384 flushStr str = putStr str >> hFlush stdout
385
386 readPrompt :: String -> IO String
387 readPrompt prompt = flushStr prompt >> getLine
388
389 evalString :: Env -> String -> IO String
390 evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
391
392 evalAndPrint :: Env -> String -> IO ()
393 evalAndPrint env expr = evalString env expr >>= putStrLn
394
395
396
397 until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
398 until_ pred prompt action = do
399 result <- prompt
400 if pred result
401 then return ()
402 else action result >> until_ pred prompt action
403
404 runOne :: [String] -> IO ()
405 runOne args = do
406 env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
407 (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
408 >>= hPutStrLn stderr
409
410 runRepl :: IO ()
411 runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
412
413 main :: IO()
414 main = do args <- getArgs
415 if null args then runRepl else runOne $ args
书中使用的Scheme标准库源码stdlib.scm:
Scheme语言: 48 小时编写sheme解释器的学习笔记－stdlib.scm
01 (define (caar pair) (car (car pair)))
02 (define (cadr pair) (car (cdr pair)))
03 (define (cdar pair) (cdr (car pair)))
04 (define (cddr pair) (cdr (cdr pair)))
05 (define (caaar pair) (car (car (car pair))))
06 (define (caadr pair) (car (car (cdr pair))))
07 (define (cadar pair) (car (cdr (car pair))))
08 (define (caddr pair) (car (cdr (cdr pair))))
09 (define (cdaar pair) (cdr (car (car pair))))
10 (define (cdadr pair) (cdr (car (cdr pair))))
11 (define (cddar pair) (cdr (cdr (car pair))))
12 (define (cdddr pair) (cdr (cdr (cdr pair))))
13 (define (caaaar pair) (car (car (car (car pair)))))
14 (define (caaadr pair) (car (car (car (cdr pair)))))
15 (define (caadar pair) (car (car (cdr (car pair)))))
16 (define (caaddr pair) (car (car (cdr (cdr pair)))))
17 (define (cadaar pair) (car (cdr (car (car pair)))))
18 (define (cadadr pair) (car (cdr (car (cdr pair)))))
19 (define (caddar pair) (car (cdr (cdr (car pair)))))
20 (define (cadddr pair) (car (cdr (cdr (cdr pair)))))
21 (define (cdaaar pair) (cdr (car (car (car pair)))))
22 (define (cdaadr pair) (cdr (car (car (cdr pair)))))
23 (define (cdadar pair) (cdr (car (cdr (car pair)))))
24 (define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
25 (define (cddaar pair) (cdr (cdr (car (car pair)))))
26 (define (cddadr pair) (cdr (cdr (car (cdr pair)))))
27 (define (cdddar pair) (cdr (cdr (cdr (car pair)))))
28 (define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))
29
30 (define (not x) (if x #f #t))
31 (define (null? obj) (if (eqv? obj '()) #t #f))
32 (define (id obj) obj)
33 (define (flip func) (lambda (arg1 arg2) (func arg2 arg1)))
34 (define (curry func arg1) (lambda (arg) (func arg1 arg)))
35 (define (compose f g) (lambda (arg) (f (g arg))))
36
37 (define (foldl func accum lst)
38 (if (null? lst)
39 accum
40 (foldl func (func accum (car lst)) (cdr lst))))
41
42 (define (foldr func accum lst)
43 (if (null? lst)
44 accum
45 (func (car lst) (foldr func accum (cdr lst)))))
46
47 (define (unfold func init pred)
48 (if (pred init)
49 (cons init '())
50 (cons init (unfold func (func init) pred))))
51
52 (define fold foldl)
53 (define reduce fold)
54
55 (define zero? (curry = 0))
56 (define positive? (curry < 0))
57 (define negative? (curry > 0))
58 (define (odd? num) (= (mod num 2) 1))
59 (define (even? num) (= (mod num 2) 0))
60 (define (max x . num-list) (fold (lambda (y z) (if (> y z) y z)) x num-list))
61 (define (min x . num-list) (fold (lambda (y z) (if (< y z) y z)) x num-list))
62 (define (list . objs) objs)
63 (define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst))
64 (define (append lst . lsts) (foldr (flip (curry foldr cons)) lst lsts))
65 (define (reverse lst) (fold (flip cons) '() lst))
66 (define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
67 (define (memq obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))
68 (define (memv obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))
69 (define (member obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))
70 (define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
71 (define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
72 (define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
73
74 (define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst))
75 (define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
76
77 (define (sum . lst) (fold + 0 lst))
78 (define (product . lst) (fold * 1 lst))
79 (define (and . lst) (fold && #t lst))
80 (define (or . lst) (fold || #f lst))
81 (define (any? pred . lst) (apply or (map pred lst)))
82 (define (every? pred . lst) (apply and (map pred lst)))
02 (define (cadr pair) (car (cdr pair)))
03 (define (cdar pair) (cdr (car pair)))
04 (define (cddr pair) (cdr (cdr pair)))
05 (define (caaar pair) (car (car (car pair))))
06 (define (caadr pair) (car (car (cdr pair))))
07 (define (cadar pair) (car (cdr (car pair))))
08 (define (caddr pair) (car (cdr (cdr pair))))
09 (define (cdaar pair) (cdr (car (car pair))))
10 (define (cdadr pair) (cdr (car (cdr pair))))
11 (define (cddar pair) (cdr (cdr (car pair))))
12 (define (cdddr pair) (cdr (cdr (cdr pair))))
13 (define (caaaar pair) (car (car (car (car pair)))))
14 (define (caaadr pair) (car (car (car (cdr pair)))))
15 (define (caadar pair) (car (car (cdr (car pair)))))
16 (define (caaddr pair) (car (car (cdr (cdr pair)))))
17 (define (cadaar pair) (car (cdr (car (car pair)))))
18 (define (cadadr pair) (car (cdr (car (cdr pair)))))
19 (define (caddar pair) (car (cdr (cdr (car pair)))))
20 (define (cadddr pair) (car (cdr (cdr (cdr pair)))))
21 (define (cdaaar pair) (cdr (car (car (car pair)))))
22 (define (cdaadr pair) (cdr (car (car (cdr pair)))))
23 (define (cdadar pair) (cdr (car (cdr (car pair)))))
24 (define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
25 (define (cddaar pair) (cdr (cdr (car (car pair)))))
26 (define (cddadr pair) (cdr (cdr (car (cdr pair)))))
27 (define (cdddar pair) (cdr (cdr (cdr (car pair)))))
28 (define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))
29
30 (define (not x) (if x #f #t))
31 (define (null? obj) (if (eqv? obj '()) #t #f))
32 (define (id obj) obj)
33 (define (flip func) (lambda (arg1 arg2) (func arg2 arg1)))
34 (define (curry func arg1) (lambda (arg) (func arg1 arg)))
35 (define (compose f g) (lambda (arg) (f (g arg))))
36
37 (define (foldl func accum lst)
38 (if (null? lst)
39 accum
40 (foldl func (func accum (car lst)) (cdr lst))))
41
42 (define (foldr func accum lst)
43 (if (null? lst)
44 accum
45 (func (car lst) (foldr func accum (cdr lst)))))
46
47 (define (unfold func init pred)
48 (if (pred init)
49 (cons init '())
50 (cons init (unfold func (func init) pred))))
51
52 (define fold foldl)
53 (define reduce fold)
54
55 (define zero? (curry = 0))
56 (define positive? (curry < 0))
57 (define negative? (curry > 0))
58 (define (odd? num) (= (mod num 2) 1))
59 (define (even? num) (= (mod num 2) 0))
60 (define (max x . num-list) (fold (lambda (y z) (if (> y z) y z)) x num-list))
61 (define (min x . num-list) (fold (lambda (y z) (if (< y z) y z)) x num-list))
62 (define (list . objs) objs)
63 (define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst))
64 (define (append lst . lsts) (foldr (flip (curry foldr cons)) lst lsts))
65 (define (reverse lst) (fold (flip cons) '() lst))
66 (define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
67 (define (memq obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))
68 (define (memv obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))
69 (define (member obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))
70 (define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
71 (define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
72 (define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
73
74 (define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst))
75 (define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
76
77 (define (sum . lst) (fold + 0 lst))
78 (define (product . lst) (fold * 1 lst))
79 (define (and . lst) (fold && #t lst))
80 (define (or . lst) (fold || #f lst))
81 (define (any? pred . lst) (apply or (map pred lst)))
82 (define (every? pred . lst) (apply and (map pred lst)))
订阅：
博文 (Atom)