Browse files

Initial commit, previous history in darcs repo\!

  • Loading branch information...
0 parents commit 7b39ccc46871263227b537a455d0ba7290f8aaa6 Sami Samhuri committed Sep 25, 2009
Showing with 1,306 additions and 0 deletions.
  1. +4 −0 README
  2. +40 −0 Rakefile
  3. +46 −0 TODO
  4. +990 −0 lisp.hs
  5. +226 −0 stdlib.scm
4 README
@@ -0,0 +1,4 @@
+This was never intended for public consumption. Build with `rake build` and then run ./elschemo, that's it!
+
+sjs
+sami.samhuri@gmail.com
40 Rakefile
@@ -0,0 +1,40 @@
+bin = "elschemo"
+names = %w[lisp]
+
+task :build do
+ sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}"
+end
+
+task :clean do
+ sh "rm -f #{bin} #{obj_files(names)}"
+end
+
+def obj_files names
+ "#{extensionize 'hi', names} #{extensionize 'o', names}"
+end
+
+def extensionize ext, names
+ names.join(".#{ext} ") + ".#{ext}"
+end
+
+
+
+# bin = "elschemo"
+# names = %w[main elschemo parser eval numeric primitives io]
+#
+# task :build do
+# sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}"
+# end
+#
+# task :clean do
+# sh "rm -f #{bin} #{obj_files(names)}"
+# end
+#
+# def obj_files names
+# "#{extensionize 'hi', names} #{extensionize 'o', names}"
+# end
+#
+# def extensionize ext, names
+# names.join(".#{ext} ") + ".#{ext}"
+# end
+#
46 TODO
@@ -0,0 +1,46 @@
+my own wishes for this little scheme
+------------------------------------
+
+* implement char=?, char<?, char>?, char<=?, and char>=?
+ (char<? #\a #\b) => #t
+
+* readline support (blah, use emacs it's good enough)
+
+* eval code in any given binding (and, hence, expose the binding somehow)
+
+
+tutorial exercises
+------------------
+
+* Add data types and parsers to support the full numeric tower of Scheme numeric types. Haskell has built-in
+ types to represent many of these; check the Prelude. For the others, you can define compound types that
+ represent eg. a Rational as a numerator and denominator, or a Complex as a real and imaginary part (each
+ itself a Real number).
+
+ http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.2.1
+
+
+* Add support for the backquote syntactic sugar: the Scheme standard details what it should expand into
+ (quasiquote/unquote).
+
+ http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-7.html#%_sec_4.2.6
+
+* Add support for vectors. The Haskell representation is up to you: GHC does have an Array data type, but it
+ can be difficult to use. Strictly speaking, a vector should have constant-time indexing and updating, but
+ destructive update in a purely functional language is difficult. You may have a better idea how to do this
+ after the section on set!, later in this tutorial.
+
+ http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.3.6
+ http://www.haskell.org/ghc/docs/latest/html/libraries/base/Data-Array.html
+
+* Instead of using the try combinator, left-factor the grammar so that the common subsequence is its own
+ parser. You should end up with a parser that matches a string of expressions, and one that matches either
+ nothing or a dot and a single expressions. Combining the return values of these into either a List or a
+ DottedList is left as a (somewhat tricky) exercise for the reader: you may want to break it out into another
+ helper function.
+
+
+* Implement <strike>cond</strike> and case expressions.
+
+* Add the rest of the string functions. You don't yet know enough to do string-set!; this is difficult to
+ implement in Haskell, but you'll have enough information after the next 2 sections
990 lisp.hs
@@ -0,0 +1,990 @@
+-- author: sjs
+-- last updated: july-10-2007
+--
+-- A small Scheme based on the tutorial by Jonathan Tang.
+-- http://halogen.note.amherst.edu/~jdtang/scheme_in_48/tutorial/overview.html
+--
+-- Where possible and convenient I try to support R5RS.
+-- http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-2.html
+
+module Main where
+import Char
+import Control.Monad.Error
+import Data.IORef
+import Data.List (isPrefixOf)
+import IO hiding (try)
+import Monad
+import Numeric
+import System.Environment
+import System.Random
+import Text.ParserCombinators.Parsec hiding (spaces)
+
+elSchemoVersion = "0.7"
+
+-- If no file is named on the command line run the REPL, otherwise run the
+-- file then start the REPL
+main :: IO ()
+main = do args <- getArgs
+ putStrLn ("ElSchemo v" ++ elSchemoVersion ++ " by sjs")
+ if null args
+ then runRepl
+ else runOneThenRepl args
+
+-- Some very basic syntax error messages
+readOrThrow :: Parser a -> String -> ThrowsError a
+readOrThrow parser input = case parse parser "lisp" input of
+ Left err -> throwError $ Parser err
+ Right val -> return val
+
+readExpr = readOrThrow parseExpr
+readExprList = readOrThrow (endBy parseExpr maybeSpaces)
+
+type Name = String
+type LispInt = Integer
+type LispFloat = Float
+
+-- numeric lisp data types
+data LispNum = Integer LispInt
+ | Float LispFloat
+ deriving (Eq, Ord, Show)
+
+-- lisp data types
+data LispVal = Atom Name
+ | List [LispVal]
+ | DottedList [LispVal] LispVal
+ | Number LispNum
+ | Char Char
+ | String String
+ | Bool Bool
+ | PrimitiveFunc Name ([LispVal] -> ThrowsError LispVal)
+ | Func {params :: [Name], vararg :: (Maybe String),
+ body :: [LispVal], closure :: Env}
+ | IOFunc Name ([LispVal] -> IOThrowsError LispVal)
+ | Port Handle
+ | Null Bool
+
+
+-- make the lisp data types instances of relevant classes
+
+lispNumPlus :: LispNum -> LispNum -> LispNum
+lispNumPlus (Integer x) (Integer y) = Integer $ x + y
+lispNumPlus (Integer x) (Float y) = Float $ (fromInteger x) + y
+lispNumPlus (Float x) (Float y) = Float $ x + y
+lispNumPlus (Float x) (Integer y) = Float $ x + (fromInteger y)
+
+lispNumMinus :: LispNum -> LispNum -> LispNum
+lispNumMinus (Integer x) (Integer y) = Integer $ x - y
+lispNumMinus (Integer x) (Float y) = Float $ (fromInteger x) - y
+lispNumMinus (Float x) (Float y) = Float $ x - y
+lispNumMinus (Float x) (Integer y) = Float $ x - (fromInteger y)
+
+lispNumMult :: LispNum -> LispNum -> LispNum
+lispNumMult (Integer x) (Integer y) = Integer $ x * y
+lispNumMult (Integer x) (Float y) = Float $ (fromInteger x) * y
+lispNumMult (Float x) (Float y) = Float $ x * y
+lispNumMult (Float x) (Integer y) = Float $ x * (fromInteger y)
+
+lispNumDiv :: LispNum -> LispNum -> LispNum
+lispNumDiv (Integer x) (Integer y) = Integer $ x `div` y
+lispNumDiv (Integer x) (Float y) = Float $ (fromInteger x) / y
+lispNumDiv (Float x) (Float y) = Float $ x / y
+lispNumDiv (Float x) (Integer y) = Float $ x / (fromInteger y)
+
+lispNumAbs :: LispNum -> LispNum
+lispNumAbs (Integer x) = Integer (abs x)
+lispNumAbs (Float x) = Float (abs x)
+
+lispNumSignum :: LispNum -> LispNum
+lispNumSignum (Integer x) = Integer (signum x)
+lispNumSignum (Float x) = Float (signum x)
+
+instance Num LispNum where
+ (+) = lispNumPlus
+ (-) = lispNumMinus
+ (*) = lispNumMult
+ abs = lispNumAbs
+ signum = lispNumSignum
+ fromInteger x = Integer x
+
+
+lispNumToRational :: LispNum -> Rational
+lispNumToRational (Integer x) = toRational x
+lispNumToRational (Float x) = toRational x
+
+instance Real LispNum where
+ toRational = lispNumToRational
+
+
+lispValEq :: LispVal -> LispVal -> Bool
+lispValEq (Bool arg1) (Bool arg2) = arg1 == arg2
+lispValEq (Number arg1) (Number arg2) = arg1 == arg2
+lispValEq (String arg1) (String arg2) = arg1 == arg2
+lispValEq (Atom arg1) (Atom arg2) = arg1 == arg2
+lispValEq (DottedList xs x) (DottedList ys y) = lispValEq (List $ xs ++ [x]) (List $ ys ++ [y])
+lispValEq (List arg1) (List arg2) = (length arg1 == length arg2) &&
+ (and $ map equalPair $ zip arg1 arg2)
+ where equalPair (x1, x2) = lispValEq x1 x2
+lispValEq _ _ = False
+
+instance Eq LispVal where (==) = lispValEq
+
+
+-- Empty values for each LispVal, these are used for letrec
+
+emptyValue :: LispVal -> LispVal
+emptyValue (Number (Integer _)) = Number (Integer 0)
+emptyValue (Number (Float _)) = Number (Float 0.0)
+emptyValue (Atom _) = Atom "_"
+emptyValue (List _) = List []
+emptyValue (DottedList l r) = DottedList [] (emptyValue r)
+emptyValue (Char _) = Char ' '
+emptyValue (String _) = String ""
+emptyValue (Bool _) = Bool False
+emptyValue (Func params vararg _ env) = Func params vararg [PrimitiveFunc "null" nullFunc] env
+
+nullFunc :: [LispVal] -> ThrowsError LispVal
+nullFunc _ = return $ Null False
+
+
+-- Parser
+
+whitespace :: Parser ()
+whitespace = skipMany1 space
+
+maybeSpaces :: Parser ()
+maybeSpaces = skipMany space
+
+symbol :: Parser Char
+symbol = oneOf "!$%&|*+-/:<=>?@^_~#" <?> "symbol"
+
+
+-- parse a binary digit, analagous to decDigit, octDigit, hexDigit
+binDigit :: Parser Char
+binDigit = oneOf "01" <?> "binary digit (0 or 1)"
+
+-- analogous to isDigit, isOctdigit, isHexDigit
+isBinDigit :: Char -> Bool
+isBinDigit c = (c == '0' || c == '1')
+
+-- analogous to readDec, readOct, readHex
+readBin :: (Integral a) => ReadS a
+readBin = readInt 2 isBinDigit digitToInt
+
+
+-- Integers, floats, characters and atoms can all start with a # so wrap those with try.
+-- (Maybe left factor the grammar in the future)
+parseExpr :: Parser LispVal
+parseExpr = (try parseFloat <?> "float")
+ <|> (try parseInteger <?> "int")
+ <|> (try parseChar <?> "char")
+ <|> (parseAtom <?> "atom")
+ <|> (parseString <?> "string")
+ <|> (parseQuoted <?> "quoted expression")
+ <|> do (char '(' <?> "expression") -- should use between?
+ x <- (try parseList) <|> parseDottedList
+ char ')'
+ return x
+ <|> (parseComment <?> "comment")
+
+
+parseComment :: Parser LispVal
+parseComment = do skipMany space
+ char ';'
+ skipMany $ noneOf "\n\r"
+ return $ Null False
+
+
+parseAtom :: Parser LispVal
+parseAtom = do first <- letter <|> symbol
+ rest <- many (letter <|> digit <|> symbol)
+ let atom = [first] ++ rest
+ return $ case atom of
+ "#t" -> Bool True
+ "#f" -> Bool False
+ otherwise -> Atom atom
+
+
+parseSign :: Parser Char
+parseSign = do try (char '-')
+ <|> do optional (char '+')
+ return '+'
+
+applySign :: Char -> LispNum -> LispNum
+applySign sign n = if sign == '-' then negate n else n
+
+-- Parse binary, octal, decimal, and hexadecimal integers according to R5RS (#b, #d, #o, #x),
+-- or parse a regular integer in decimal format.
+parseInteger :: Parser LispVal
+parseInteger = do base <- do { char '#'; oneOf "bdox" } <|> return 'd'
+ sign <- parseSign
+ int <- parseDigits base
+ return . Number $ applySign sign $ Integer . fst . head . (reader base) $ int
+ where reader base = case base of
+ 'b' -> readBin
+ 'd' -> readDec
+ 'o' -> readOct
+ 'x' -> readHex
+
+
+-- Parse a string of digits in the given base.
+parseDigits :: Char -> Parser String
+parseDigits base = many1 d >>= return
+ where d = case base of
+ 'b' -> binDigit
+ 'd' -> digit
+ 'o' -> octDigit
+ 'x' -> hexDigit
+
+
+-- Parse floating point numbers, but only in decimal.
+parseFloat :: Parser LispVal
+parseFloat = do optional (string "#d")
+ sign <- parseSign
+ whole <- many1 digit
+ char '.'
+ fract <- many1 digit
+ return . Number $ applySign sign (makeFloat whole fract)
+ where makeFloat whole fract = Float . fst . head . readFloat $ whole ++ "." ++ fract
+
+
+-- Parse a single character according to R5RS (#\a, #\A, #\(, ...).
+parseChar :: Parser LispVal
+parseChar = do char '#' >> char '\\'
+ c <- letter <|> digit <|> symbol <|> oneOf "()[]{} "
+ return $ Char c
+
+
+-- Parse an R5RS compliant string.
+parseString :: Parser LispVal
+parseString = do
+ char '"'
+ x <- many singleChar -- <?> "character"
+ char '"'
+ return $ String x
+
+
+escapedChars :: String
+escapedChars = "n\"\\"
+
+singleChar :: Parser Char
+singleChar = noneOf "\\\""
+ <|> try (do c <- char '\\' >> oneOf escapedChars
+ if c == 'n' then return '\n' else return c)
+ <|> char '\\'
+
+
+
+-- Parse lists
+parseList :: Parser LispVal
+parseList = liftM List $ sepBy parseExpr whitespace
+
+
+-- Parse lists of the form (head . tail)
+parseDottedList :: Parser LispVal
+parseDottedList = do
+ head <- endBy parseExpr whitespace
+ tail <- char '.' >> whitespace >> parseExpr
+ return $ DottedList head tail
+
+
+-- Parse a quoted expression, ie. '(+ 3 5)
+parseQuoted :: Parser LispVal
+parseQuoted = do
+ char '\''
+ x <- parseExpr
+ return $ List [Atom "quote", x]
+
+
+-- Convert LispVals to strings suitable for display
+showVal :: LispVal -> String
+showVal (Null False) = ""
+showVal (String contents) = "\"" ++ escape contents ++ "\""
+showVal (Char c) = "#\\" ++ [c]
+showVal (Atom name) = name
+showVal (List []) = "()"
+showVal (Number (Integer n)) = show n
+showVal (Number (Float n)) = show n
+showVal (Bool True) = "#t"
+showVal (Bool False) = "#f"
+showVal (List contents) = "(" ++ unwordsList contents ++ ")"
+showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
+showVal (PrimitiveFunc name _) = "#<primitive:" ++ name ++ ">"
+showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
+ "(lambda (" ++ unwords(map show args) ++
+ (case varargs of
+ Nothing -> ""
+ Just arg -> " . " ++ arg) ++ ") ...)"
+showVal (Port _) = "#<IO port>"
+showVal (IOFunc name _) = "#<IO primitive:" ++ name ++ ">"
+
+unwordsList :: [LispVal] -> String
+unwordsList = unwords . map showVal
+
+instance Show LispVal where show = showVal
+
+
+-- xs =~ s/from/to/g
+subst :: (Eq a) => [a] -> [a] -> [a] -> [a]
+subst _ _ [ ] = []
+subst from to xs@(a:as) =
+ if isPrefixOf from xs
+ then to ++ drop (length from) xs
+ else a : subst from to as
+
+-- escape a string for display
+escape :: String -> String
+escape s = subst "\n" "\\n" (subst "\"" "\\\"" (subst "\\" "\\\\" s))
+
+-- Evaluation
+eval :: Env -> LispVal -> IOThrowsError LispVal
+eval env (List [Atom "load", String filename]) = do
+ load filename >>= evalExprs env
+ return $ Atom ("Loaded " ++ filename ++ ".")
+eval env (Null _) = return $ Null False
+eval env val@(Char _) = return val
+eval env val@(String _) = return val
+eval env val@(Number _) = return val
+eval env val@(Bool _) = return val
+eval env (Atom id) = getVar env id
+eval env (List []) = return $ List []
+eval env (List [Atom "quote", val]) = return val
+eval env (List (Atom "and" : params)) = lispAnd env params
+eval env (List (Atom "or" : params)) = lispOr env params
+eval env (List (Atom "if" : params)) = lispIf env params
+eval env (List (Atom "cond" : params)) = lispCond env params
+eval env (List [Atom "set!", Atom var, form]) =
+ eval env form >>= setVar env var
+eval env (List [Atom "define", Atom var, form]) =
+ eval env form >>= defineVar env var
+eval env (List (Atom "define" : List (Atom var : params) : body)) =
+ makeNormalFunc env params body >>= defineVar env var
+eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
+ makeVarargs varargs env params body >>= defineVar env var
+eval env (List (Atom "lambda" : List params : body)) =
+ makeNormalFunc env params body
+eval env (List (Atom "lambda" : DottedList params varargs : body)) =
+ makeVarargs varargs env params body
+eval env (List (Atom "lambda" : varargs@(Atom _) : body)) =
+ makeVarargs varargs env [] body
+
+eval env (List (Atom "let" : List params : body)) = do
+ values <- evalArgs env params
+ (liftIO $ bindVars env $ zip names values) >>= evalBody
+ where evalBody env = liftM last $ evalExprs env body
+ names = argNames params
+
+eval env (List (Atom "let*" : List [List [Atom var, form]] : body)) = do
+ eval env form >>= defineVar env var
+ liftM last $ evalExprs env body
+eval env (List (Atom "let*" : List (List [Atom var, form] : rest) : body)) = do
+ eval env form >>= defineVar env var
+ eval env (List (Atom "let*" : List rest : body))
+
+eval env (List (Atom "letrec" : List params : body)) = do
+ -- bind the names of vars so they are visible to everything within the letrec
+ env <- liftIO $ bindVars env $ zip names emptyValues
+ -- now evaluate the args and set the proper values
+ values <- evalArgs env params
+ setVars env $ zip names values
+ -- ready to evaluate the body
+ liftM last $ evalExprs env body
+ where names = argNames params
+ emptyValues = [emptyValue x | x <- params]
+
+-- R6RS adds letrec*, with fairly obvious semantics
+
+eval env (List (function : args)) = do
+ func <- eval env function
+ argVals <- mapM (eval env) args
+ apply func argVals
+
+-- taken from Arc, (f . (1 2 3)) is the same as (apply f '(1 2 3))
+eval env (DottedList [function] (List args)) = do
+ func <- eval env function
+ argVals <- mapM (eval env) args
+ apply func argVals
+
+eval env badForm = throwError $ BadSpecialForm "Unrecongized special form" badForm
+
+
+evalExprs :: Env -> [LispVal] -> IOThrowsError [LispVal]
+evalExprs env exprs = mapM (eval env) exprs
+
+argNames :: [LispVal] -> [Name]
+argNames params = map (\(List [Atom x, y]) -> x) params
+
+args :: [LispVal] -> [LispVal]
+args params = map (\(List [x, y]) -> y) params
+
+evalArgs :: Env -> [LispVal] -> IOThrowsError [LispVal]
+evalArgs env params = evalExprs env (args params)
+
+
+-- Call primitive functions directly.
+-- Call user-defined functions after ensuring the correct number of arguments are present,
+-- and then evaluating those args in the proper context.
+apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
+apply (PrimitiveFunc _ func) args = liftThrows $ func args
+apply (IOFunc _ func) args = func args
+apply (Func params varargs body closure) args =
+ if num params /= num args && varargs == Nothing
+ then throwError $ NumArgs (num params) args
+ else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
+ where remainingArgs = drop (length params) args
+ num = toInteger . length
+ evalBody env = liftM last $ evalExprs env body
+ bindVarArgs arg env = case arg of
+ Just argName -> liftIO $ bindVars env [(argName, List remainingArgs)]
+ Nothing -> return env
+apply unFunc args = throwError $ NotFunction "Not a function" (show unFunc)
+
+
+-- special forms
+
+lispAnd :: Env -> [LispVal] -> IOThrowsError LispVal
+lispAnd env [pred] = eval env pred
+lispAnd env (pred:rest) = do
+ result <- eval env pred
+ case result of
+ Bool False -> return $ Bool False
+ _ -> lispAnd env rest
+
+lispOr :: Env -> [LispVal] -> IOThrowsError LispVal
+lispOr env [pred] = eval env pred
+lispOr env (pred:rest) = do
+ result <- eval env pred
+ case result of
+ Bool False -> lispOr env rest
+ val -> return val
+
+lispIf :: Env -> [LispVal] -> IOThrowsError LispVal
+lispIf env (pred:conseq:alt) = do
+ result <- eval env pred
+ case result of
+ Bool False -> eval env $ head alt
+ Bool True -> eval env conseq
+ badCond -> throwError $ TypeMismatch "boolean" badCond
+
+lispCond :: Env -> [LispVal] -> IOThrowsError LispVal
+lispCond env (List (Atom "else" : exprs) : []) = liftM last $ evalExprs env exprs
+lispCond env (List (pred:conseq) : rest) = do
+ result <- eval env pred
+ case result of
+ Bool False -> case rest of
+ [] -> return $ Null False
+ _ -> lispCond env rest
+ _ -> liftM last $ evalExprs env conseq
+
+
+primitives :: [(Name, [LispVal] -> ThrowsError LispVal)]
+primitives = [("+", numericBinop (+)),
+ ("-", subtractOp),
+ ("*", numericBinop (*)),
+ ("/", floatBinop (/)),
+ ("mod", integralBinop mod),
+ ("quotient", integralBinop quot),
+ ("remainder", integralBinop rem),
+ ("=", numBoolBinop (==)),
+ ("<", numBoolBinop (<)),
+ (">", numBoolBinop (>)),
+ ("/=", numBoolBinop (/=)),
+ (">=", numBoolBinop (>=)),
+ ("<=", numBoolBinop (<=)),
+ ("&&", boolBoolBinop (&&)),
+ ("||", boolBoolBinop (||)),
+ ("car", car),
+ ("cdr", cdr),
+ ("cons", cons),
+ ("null?", nullBoolUnop),
+ ("eq?", eqv),
+ ("eqv?", eqv),
+ ("equal?", equal),
+ ("string=?", strBoolBinop (==)),
+ ("string<", strBoolBinop (<)),
+ ("string>?", strBoolBinop (>)),
+ ("string<=?", strBoolBinop (<=)),
+ ("string>=?", strBoolBinop (>=)),
+ ("symbol?", symbolBoolUnop),
+ ("list?", listBoolUnop),
+ ("dotted-list?", dottedListBoolUnop),
+ ("number?", numBoolUnop),
+ ("integer?", intBoolUnop),
+ ("float?", floatBoolUnop),
+ ("char?", charBoolUnop),
+ ("string?", strBoolUnop),
+ ("bool?", boolBoolUnop),
+ ("symbol->string", convertSymbolToString),
+ ("string->symbol", convertStringToSymbol),
+ ("string->list", convertStringToList),
+ ("list->string", convertListToString),
+ ("char->integer", convertCharToInt),
+ ("integer->char", convertIntToChar),
+ ("char-upcase", convertCharUpcase),
+ ("char-downcase", convertCharDowncase),
+ ("char-at", charAt),
+ ("ceiling", floatingUnop ceiling),
+ ("floor", floatingUnop floor),
+ ("string-concatenate", stringConcatenate),
+ ("string-slice", stringSlice),
+ ("string-reverse", stringReverse)]
+
+primitiveBindings :: IO Env
+primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
+ ++ map (makeFunc PrimitiveFunc) primitives)
+ where makeFunc constructor (var, func) = (var, constructor var func)
+
+numericBinop :: (LispNum -> LispNum -> LispNum) -> [LispVal] -> ThrowsError LispVal
+numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
+
+integralBinop :: (LispInt -> LispInt -> LispInt) -> [LispVal] -> ThrowsError LispVal
+integralBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+integralBinop op params = mapM unpackInt params >>= return . Number . Integer . foldl1 op
+
+floatBinop :: (LispFloat -> LispFloat -> LispFloat) -> [LispVal] -> ThrowsError LispVal
+floatBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+floatBinop op params = mapM unpackFloat params >>= return . Number . Float . foldl1 op
+
+subtractOp :: [LispVal] -> ThrowsError LispVal
+subtractOp num@[_] = unpackNum (head num) >>= return . Number . negate
+subtractOp params = numericBinop (-) params
+
+boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
+boolBinop unpacker op singleVal@[_] = throwError $ NumArgs 2 singleVal
+boolBinop unpacker op args = do left <- unpacker $ head args
+ right <- unpacker $ args !! 1
+ return $ Bool $ left `op` right
+
+numBoolBinop :: (LispNum -> LispNum -> Bool) -> [LispVal] -> ThrowsError LispVal
+numBoolBinop op params = boolBinop unpackNum op params
+
+strBoolBinop = boolBinop unpackStr
+boolBoolBinop = boolBinop unpackBool
+
+unpackNum :: LispVal -> ThrowsError LispNum
+unpackNum (Number (Integer n)) = return $ Integer n
+unpackNum (Number (Float n)) = return $ Float n
+unpackNum notNum = throwError $ TypeMismatch "number" notNum
+
+unpackInt :: LispVal -> ThrowsError Integer
+unpackInt (Number (Integer n)) = return n
+unpackInt (String n) = let parsed = reads n in
+ if null parsed
+ then throwError $ TypeMismatch "integer" $ String n
+ else return . fst . head $ parsed
+unpackInt (List [n]) = unpackInt n
+unpackInt notInt = throwError $ TypeMismatch "integer" notInt
+
+unpackFloat :: LispVal -> ThrowsError Float
+unpackFloat (Number (Float f)) = return f
+unpackFloat (Number (Integer f)) = return $ fromInteger f
+unpackFloat (String f) = let parsed = reads f in
+ if null parsed
+ then throwError $ TypeMismatch "float" $ String f
+ else return . fst . head $ parsed
+unpackFloat (List [f]) = unpackFloat f
+unpackFloat notFloat = throwError $ TypeMismatch "float" notFloat
+
+unpackStr :: LispVal -> ThrowsError String
+unpackStr (String s) = return s
+unpackStr (Number (Integer s)) = return $ show s
+unpackStr (Number (Float s)) = return $ show s
+unpackStr (Bool s) = return $ show s
+unpackStr notString = throwError $ TypeMismatch "string" notString
+
+unpackBool :: LispVal -> ThrowsError Bool
+unpackBool (Bool b) = return b
+unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
+
+
+-- list processing (and strings now too)
+car :: [LispVal] -> ThrowsError LispVal
+car [List (x : xs)] = return x
+car [DottedList (x : xs) _] = return x
+car [String (c:xs)] = return . Char $ c
+car [badArg] = throwError $ TypeMismatch "pair" badArg
+car badArgs = throwError $ NumArgs 1 badArgs
+
+cdr :: [LispVal] -> ThrowsError LispVal
+cdr [List (x : xs)] = return $ List xs
+cdr [DottedList [xs] x] = return x
+cdr [DottedList (_ : xs) x] = return $ DottedList xs x
+cdr [String (_:rest)] = return $ String rest
+cdr [badArg] = throwError $ TypeMismatch "pair" badArg
+cdr badArgs = throwError $ NumArgs 1 badArgs
+
+cons :: [LispVal] -> ThrowsError LispVal
+cons [x1, List []] = return $ List [x1]
+cons [x, List xs] = return $ List ([x] ++ xs)
+cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
+cons [Char c, String s] = return $ String (c:s)
+cons [String a, String b] = return $ String (a ++ b)
+cons [x1, x2] = return $ DottedList [x1] x2
+cons badArgs = throwError $ NumArgs 2 badArgs
+
+
+-- equivalence testing
+eqv :: [LispVal] -> ThrowsError LispVal
+eqv [arg1, arg2] = return . Bool $ lispValEq arg1 arg2
+eqv badArgs = throwError $ NumArgs 2 badArgs
+
+-- For any type that is an instance of Eq, you can define an Unpacker that takes a function
+-- from LispVal to that type, and may throw an error.
+data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
+
+unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
+unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
+ do unpacked1 <- unpacker arg1
+ unpacked2 <- unpacker arg2
+ return $ unpacked1 == unpacked2
+ `catchError` (const $ return False)
+
+
+equal :: [LispVal] -> ThrowsError LispVal
+equal [List arg1, List arg2] = return . Bool $ (length arg1 == length arg2) &&
+ (and $ map equalPair $ zip arg1 arg2)
+ where equalPair (x1, x2) =let (Bool x) = extractValue $ equal [x1, x2] in x
+
+equal [arg1, arg2] = do
+ primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
+ [AnyUnpacker unpackNum, AnyUnpacker unpackFloat, AnyUnpacker unpackInt, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
+ return $ Bool $ (primitiveEquals || lispValEq arg1 arg2)
+equal badArgs = throwError $ NumArgs 2 badArgs
+
+
+boolUnop :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
+boolUnop op [val] = return . op $ val
+boolUnop op badArgs = throwError $ NumArgs 1 badArgs
+
+symbolBoolUnop = boolUnop isLispSymbol
+listBoolUnop = boolUnop isLispList
+dottedListBoolUnop = boolUnop isLispDottedList
+numBoolUnop = boolUnop isLispNumber
+intBoolUnop = boolUnop isLispInteger
+floatBoolUnop = boolUnop isLispFloat
+charBoolUnop = boolUnop isLispChar
+strBoolUnop = boolUnop isLispString
+boolBoolUnop = boolUnop isLispBool
+nullBoolUnop = boolUnop isNull
+
+floatingUnop :: (LispFloat -> LispInt) -> [LispVal] -> ThrowsError LispVal
+floatingUnop op [Number (Float val)] = return . Number . Integer . op $ val
+floatingUnop op [badArg] = throwError $ TypeMismatch "float" badArg
+floatingUnop op badArgs = throwError $ NumArgs 1 badArgs
+
+-- type identification primitives
+isLispSymbol :: LispVal -> LispVal
+isLispSymbol (Atom _) = Bool True
+isLispSymbol _ = Bool False
+
+isLispList :: LispVal -> LispVal
+isLispList (List _) = Bool True
+isLispList _ = Bool False
+
+isLispDottedList :: LispVal -> LispVal
+isLispDottedList (DottedList _ _) = Bool True
+isLispDottedList _ = Bool False
+
+isLispNumber :: LispVal -> LispVal
+isLispNumber (Number _) = Bool True
+isLispNumber _ = Bool False
+
+isLispInteger :: LispVal -> LispVal
+isLispInteger (Number (Integer _)) = Bool True
+isLispInteger _ = Bool False
+
+isLispFloat :: LispVal -> LispVal
+isLispFloat (Number (Float _)) = Bool True
+isLispFloat _ = Bool False
+
+isLispChar :: LispVal -> LispVal
+isLispChar (Char _) = Bool True
+isLispChar _ = Bool False
+
+isLispString :: LispVal -> LispVal
+isLispString (String _) = Bool True
+isLispString _ = Bool False
+
+isLispBool :: LispVal -> LispVal
+isLispBool (Bool _) = Bool True
+isLispBool _ = Bool False
+
+isNull :: LispVal -> LispVal
+isNull (List []) = Bool True
+isNull _ = Bool False
+
+-- conversions
+
+conversion :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
+conversion func [arg] = func arg
+conversion _ badArgs = throwError $ NumArgs 1 badArgs
+
+convertSymbolToString = conversion symbolToString
+convertStringToSymbol = conversion stringToSymbol
+convertStringToList = conversion stringToList
+convertListToString = conversion listToString
+convertCharUpcase = conversion charUpcase
+convertCharDowncase = conversion charDowncase
+convertCharToInt = conversion charToInt
+convertIntToChar = conversion intToChar
+
+symbolToString :: LispVal -> ThrowsError LispVal
+symbolToString (Atom a) = return $ String a
+symbolToString badArg = throwError $ TypeMismatch "atom" badArg
+
+stringToSymbol :: LispVal -> ThrowsError LispVal
+stringToSymbol (String s) = return $ Atom s
+stringToSymbol badArg = throwError $ TypeMismatch "string" badArg
+
+stringToList :: LispVal -> ThrowsError LispVal
+stringToList (String s) = return $ str2lst (String s)
+stringToList badArg = throwError $ TypeMismatch "atom" badArg
+
+listToString :: LispVal -> ThrowsError LispVal
+listToString (List l) = return $ lst2str (List l)
+listToString badArg = throwError $ TypeMismatch "list" badArg
+
+charUpcase :: LispVal -> ThrowsError LispVal
+charUpcase (Char c) = return $ Char $ toUpper c
+charUpcase badArg = throwError $ TypeMismatch "char" badArg
+
+charDowncase :: LispVal -> ThrowsError LispVal
+charDowncase (Char c) = return $ Char $ toLower c
+charDowncase badArg = throwError $ TypeMismatch "char" badArg
+
+charToInt :: LispVal -> ThrowsError LispVal
+charToInt (Char c) = return $ Number . Integer . toInteger $ ord c
+charToInt badArg = throwError $ TypeMismatch "char" badArg
+
+intToChar :: LispVal -> ThrowsError LispVal
+intToChar (Number (Integer n)) = return $ Char . chr $ fromInteger n
+intToChar badArg = throwError $ TypeMismatch "integer" badArg
+
+
+-- string functions
+
+lst2str :: LispVal -> LispVal
+lst2str (List l) = String [c | Char c <- l]
+
+str2lst :: LispVal -> LispVal
+str2lst (String s) = List [Char c | c <- s]
+
+charAt :: [LispVal] -> ThrowsError LispVal
+charAt [Number (Integer idx), String s] = return . Char $ s !! (fromInteger idx)
+charAt [badArg, String _] = throwError $ TypeMismatch "integer" badArg
+charAt [Number (Integer _), badArg] = throwError $ TypeMismatch "string" badArg
+charAt badArgs = throwError $ NumArgs 2 badArgs
+
+stringConcatenate :: [LispVal] -> ThrowsError LispVal
+stringConcatenate [List xs] = return . String $ foldl (++) "" strings
+ where strings = [s | String s <- xs]
+stringConcatenate [badArg] = throwError $ TypeMismatch "list" badArg
+stringConcatenate badArgs = throwError $ NumArgs 1 badArgs
+
+stringSlice :: [LispVal] -> ThrowsError LispVal
+stringSlice [String s, Number (Integer start), Number (Integer len)] =
+ return . String $ take (fromInteger len) $ drop (fromInteger start) s
+stringSlice badArgs@[_,_,_] = throwError $ TypeMismatch "string,integer,integer" (List badArgs)
+stringSlice badArgs = throwError $ NumArgs 3 badArgs
+
+stringReverse :: [LispVal] -> ThrowsError LispVal
+stringReverse [String s] = return . String $ reverse s
+stringReverse [badArg] = throwError $ TypeMismatch "string" badArg
+stringReverse badArgs = throwError $ NumArgs 1 badArgs
+
+
+-- error checking
+data LispError = NumArgs Integer [LispVal]
+ | TypeMismatch String LispVal
+ | Parser ParseError
+ | BadSpecialForm String LispVal
+ | NotFunction String String
+ | UnboundVar String String
+ | Default String
+ | FileNotFound String
+
+showError :: LispError -> String
+showError (UnboundVar message varname) = message ++ ": " ++ varname
+showError (BadSpecialForm message form) = message ++ ": " ++ show form
+showError (NotFunction message func) = message ++ ": " ++ func
+showError (NumArgs expected found) = "Expected " ++ show expected
+ ++ " args, found values (" ++ unwordsList found ++ ")"
+showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
+ ++ ", found " ++ show found
+showError (Parser parseErr) = "Parse error at " ++ show parseErr
+showError (FileNotFound filename) = "File not found: " ++ show filename
+
+instance Show LispError where show = showError
+
+instance Error LispError where
+ noMsg = Default "An error has occured"
+ strMsg = Default
+
+type ThrowsError = Either LispError
+
+--XXX what type does trapError have?
+trapError action = catchError action (return . show)
+
+extractValue :: ThrowsError a -> a
+extractValue (Right val) = val
+
+-- REPL (read-eval-print loop)
+
+flushStr :: String -> IO ()
+flushStr str = putStr str >> hFlush stdout
+
+readPrompt :: String -> IO String
+readPrompt prompt = flushStr prompt >> getLine
+
+evalString :: Env -> String -> IO String
+evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
+
+evalAndPrint :: Env -> String -> IO ()
+evalAndPrint env expr = do
+ result <- evalString env expr
+ if result == ""
+ then return ()
+ else putStrLn result
+
+until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
+until_ pred prompt action = do
+ result <- prompt
+ if pred result
+ then return ()
+ else action result >> until_ pred prompt action
+
+runOneThenRepl :: [String] -> IO ()
+runOneThenRepl args = do
+ env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
+ (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
+ >>= hPutStrLn stderr
+ runReplWithEnv $ return env
+
+runReplWithEnv :: IO Env -> IO ()
+runReplWithEnv env = do env >>= until_ (== "quit") (readPrompt "> ") . evalAndPrint
+
+runRepl :: IO ()
+runRepl = runReplWithEnv primitiveBindings
+--
+--runOneThenRepl :: [String] -> IO ()
+--runOneThenRepl args = do runOneWithEnv primitiveBindings args >>= runReplWithEnv
+
+
+-- saving state, the environment (a list of strings paired to mutable values)
+type Env = IORef [(String, IORef LispVal)]
+
+nullEnv :: IO Env
+nullEnv = newIORef []
+
+
+type IOThrowsError = ErrorT LispError IO
+
+liftThrows :: ThrowsError a -> IOThrowsError a
+liftThrows (Left err) = throwError err
+liftThrows (Right val) = return val
+
+runIOThrows :: IOThrowsError String -> IO String
+runIOThrows action = runErrorT (trapError action) >>= return . extractValue
+
+
+isBound :: Env -> String -> IO Bool
+isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
+
+getVar :: Env -> String -> IOThrowsError LispVal
+getVar envRef var = do env <- liftIO $ readIORef envRef
+ maybe (throwError $ UnboundVar "Getting an unbound variable" var)
+ (liftIO . readIORef)
+ (lookup var env)
+
+setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+setVar envRef var value = do env <- liftIO $ readIORef envRef
+ maybe (throwError $ UnboundVar "Setting an unbound variable" var)
+ (liftIO . (flip writeIORef value))
+ (lookup var env)
+ return value
+
+setVars :: Env -> [(String, LispVal)] -> IOThrowsError LispVal
+setVars envRef values = liftM last $ mapM set values
+ where set (var, value) = setVar envRef var value
+
+defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+defineVar envRef var value = do
+ alreadyDefined <- liftIO $ isBound envRef var
+ if alreadyDefined
+ then setVar envRef var value >> return value
+ else liftIO $ do
+ valueRef <- newIORef value
+ env <- readIORef envRef
+ writeIORef envRef ((var, valueRef) : env)
+ return value
+
+bindVars :: Env -> [(String, LispVal)] -> IO Env
+bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
+ where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
+ addBinding (var, value) = do ref <- newIORef value
+ return (var, ref)
+
+--- XXX types? same as makeFunc, no?
+makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
+makeNormalFunc = makeFunc Nothing
+makeVarargs = makeFunc . Just . showVal
+
+
+ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
+ioPrimitives = [("apply", applyProc),
+ ("open-input-file", makePort ReadMode),
+ ("open-output-file", makePort WriteMode),
+ ("close-input-file", closePort),
+ ("close-output-file", closePort),
+ ("read", readProc),
+ ("write", writeProc),
+ ("read-contents", readContents),
+ ("read-all", readAll),
+ ("display", display),
+ ("random", randomInt)]
+
+applyProc :: [LispVal] -> IOThrowsError LispVal
+applyProc [func, List args] = apply func args
+applyProc (func : args) = apply func args
+
+makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
+makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
+
+closePort :: [LispVal] -> IOThrowsError LispVal
+closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
+closePort _ = return $ Bool False
+
+readProc :: [LispVal] -> IOThrowsError LispVal
+readProc [] = readProc [Port stdin]
+readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
+
+writeProc :: [LispVal] -> IOThrowsError LispVal
+writeProc [obj] = writeProc [obj, Port stdout]
+writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
+
+readContents :: [LispVal] -> IOThrowsError LispVal
+readContents [String filename] = liftM String $ liftIO $ readFile filename
+
+load :: String -> IOThrowsError [LispVal]
+load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
+
+readAll :: [LispVal] -> IOThrowsError LispVal
+readAll [String filename] = liftM List $ load filename
+
+
+-- display values, fallback on showVal since only strings and chars need to be displayed differently
+displayVal :: LispVal -> String
+displayVal (String contents) = contents
+displayVal (Char c) = [c]
+displayVal x = showVal x
+
+
+display :: [LispVal] -> IOThrowsError LispVal
+display [] = return $ Null False
+display (x : xs) = do liftIO . putStr $ displayVal x; display xs
+
+randomInt :: [LispVal] -> IOThrowsError LispVal
+randomInt [Number (Integer high)] = liftM (Number . Integer) $ liftIO num
+ where num = getStdRandom (randomR (0,high-1))
+randomInt [badArg] = throwError $ TypeMismatch "integer" badArg
+randomInt args = throwError $ NumArgs 1 args
226 stdlib.scm
@@ -0,0 +1,226 @@
+;; the basics
+(define nil ())
+(define null nil)
+(define true #t)
+(define false #f)
+(define (pair? x) (and (list? x) (not (null? x))))
+(define (not x) (if (eq? #f x) #t #f))
+(define (newline) (display "\n"))
+
+(define (list . objs) objs)
+(define (id obj) obj)
+(define (flip func)
+ (lambda (arg1 arg2) (func arg2 arg1)))
+(define (curry func arg1)
+ (lambda (arg) (func arg1 arg)))
+(define (compose f g)
+ (lambda (arg) (f (apply g arg))))
+
+;; math
+(define zero? (curry = 0))
+(define negative? (curry (flip <) 0))
+(define positive? (curry (flip >) 0))
+(define inc (curry + 1))
+(define dec (curry (flip -) 1))
+
+(define (divides? a b)
+ (zero? (remainder b a)))
+
+(define (prime? x)
+ (= x (smallest-divisor x)))
+
+;; this sort of coercion shouldn't be necessary
+(define (odd? num)
+ (cond ((and (float? num) (equal? num (floor num))) (= (mod (floor num) 2) 1))
+ ((float? num) (display "odd? expects an integer, given:" num) #f)
+ (else (= (mod num 2) 1))))
+(define (even? num)
+ (cond ((and (float? num) (equal? num (floor num))) (zero? (mod (floor num) 2)))
+ ((float? num) (display "even? expects an integer, given:" num) #f)
+ (else (zero? (mod num 2)))))
+
+(define (square x) (* x x))
+(define (abs x)
+ (cond ((< x 0) (- x))
+ (else x)))
+
+;; exponentation using recursion (pretty fast)
+(define (expt-rec b n)
+ (if (zero? n)
+ 1
+ (* b (expt-rec b (dec n)))))
+
+;; exponentation using foldl (slowest)
+(define (expt-fold b n)
+ (fold * 1 (fill (range 1 n) b)))
+
+;; exponentation using iteration
+;; (seems a bit slower than the recursive version, but still fast)
+(define (expt-iter b counter . product)
+ (let product (lambda (if (null? product) 1 (car product)))
+ (if (zero? counter)
+ product
+ (expt-iter b (dec counter) (* b product)))))
+
+;; fast exponentation
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define expt fast-expt)
+
+;; calculate square roots
+(define (sqrt-good-enough? guess x)
+ (let ((delta 0.0001))
+ (< (abs (- (square guess) x))
+ delta)))
+
+(define (sqrt-improve guess x)
+ (average guess (/ x guess)))
+
+(define (sqrt-iter guess x)
+ (if (sqrt-good-enough? guess x)
+ guess
+ (sqrt-iter (sqrt-improve guess x) x)))
+
+(define (sqrt x)
+ (sqrt-iter 1.0 x))
+
+(define (factorial n)
+ (if (<= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+(define ! factorial)
+
+;; greatest common denominator
+(define (gcd a b)
+ (if (zero? b)
+ a
+ (gcd b (remainder a b))))
+
+(define (find-divisor n test-divisor)
+ (let ((next (lambda (n)
+ (if (eq? n 2)
+ 3
+ (+ n 2)))))
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (next test-divisor))))))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+
+(define (expmod base exp m)
+ (cond ((zero? exp) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (dec exp) m))
+ m))))
+
+;; test for prime numbers using Fermat's method
+(define (fermat-test n)
+ (let ((try-it (lambda (a)
+ (= (expmod a n n) a))))
+ (try-it (inc (random (dec n))))))
+
+;; this runs Fermat's test a given number of times
+(define (fast-prime? n times)
+ (cond ((zero? times) true)
+ ((fermat-test n) (fast-prime? n (dec times)))
+ (else false)))
+
+;; folds
+
+;; SICP calls this accumulate
+(define (foldr func end lst)
+ (if (null? lst)
+ end
+ (func (car lst) (foldr func end (cdr lst)))))
+
+(define (foldl func accum lst)
+ (if (null? lst)
+ accum
+ (foldl func (func accum (car lst)) (cdr lst))))
+
+(define fold foldl)
+(define reduce fold)
+
+(define (unfold func init pred)
+ (if (pred init)
+ (cons init '())
+ (cons init (unfold func (func init) pred))))
+
+(define (sum-list lst) (fold + 0 lst))
+(define (sum . lst) (sum-list lst))
+(define (product . lst) (fold * 0 lst))
+(define (average . xs) (/ (sum-list xs) (length xs)))
+(define avg average)
+
+(define (max first . num-list) (fold (lambda (old new) (if (> old new) old new)) first num-list))
+(define (min first . num-list) (fold (lambda (old new) (if (< old new) old new)) first num-list))
+(define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst))
+(define (reverse lst) (fold (flip cons) '() lst))
+(define (nth n lst) (if (= n 1) (car lst) (nth (- n 1) (cdr lst))))
+
+
+(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
+(define (memq obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))
+(define (memv obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))
+(define (member obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))
+(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
+(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
+(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
+
+;; TODO define fold-k (fold w/ continuations) and use it to short-circuit these
+(define (any? pred lst) (fold (lambda (any-found x) (or any-found (pred x))) #f lst))
+(define (all? pred lst) (fold (lambda (all-matched x) (and (pred x) all-matched)) #t lst))
+
+;; transformations
+;; (define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst))
+;; (define (mapr func lst) (fold (lambda (x y) (cons (func y) x)) '() lst))
+(define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
+(define (fill lst n) (map (lambda (x) n) lst))
+
+;; the more general version of map, similar to mapcar in Lisp
+(define (map func . seqs)
+ (cond ((= 1 (length seqs))
+ (foldr (lambda (x y) (cons (func x) y)) '() (car seqs)))
+ ((null? (car seqs)) nil)
+ (else
+ (cons (apply func (map car seqs))
+ (apply map (cons func (map cdr seqs)))))))
+
+
+(define (caar lst) (car (car lst)))
+(define (cadr lst) (car (cdr lst)))
+(define (caddr lst) (car (cdr (cdr lst))))
+(define (cadddr lst) (car (cdr (cdr (cdr lst)))))
+
+
+;; like python's range
+;; SICP calls this enumerate-interval ... i prefer range
+(define (range min max)
+ (if (> min max)
+ nil
+ (cons min (range (inc min) max))))
+
+;; recursive method of concatenating 2 lists
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1) (append (cdr list1) list2))))
+
+;; string manipulation
+(define (string-map func s)
+ (list->string (map func (string->list s))))
+
+(define (string-upcase s)
+ (string-map char-upcase s))
+
+(define (string-downcase s)
+ (string-map char-downcase s))
+
+(define (string-append . lst)
+ (string-concatenate lst))

0 comments on commit 7b39ccc

Please sign in to comment.