一些简单的东西
div1 :: Integer -> Integer -> Integer
div1 x y = if x >= y then (div1 (x - y) y) + 1 else 0
factBranch :: Integer -> Integer
factBranch n | n == 0 = 1
| otherwise = n * factBranch(n - 1)
在 ghci 里调用 div1 _ _ 即可。
main = do
num <- getLine
putStrLn (show((read num) + 3))
很不方便的 IO。
一些中等难度的东西
通过统计字母的出现次数解密恺撒密码,主要是 zip 和 list comprehension 的应用
encode n xs = [shift n x | x <- xs]
shift n c = if (ord c >= ord 'a') && (ord c <= ord 'z')
then int2let (mod (let2int c + n) 26) else c
let2int c = ord c - ord 'a'
int2let n = chr (ord 'a' + n)
crack xs = head (take_min pr)
where pr = zip [encode n xs | n <- [0..25]] [calc (encode n xs) | n <- [0..25]]
table = [8.1, 1.5, 2.8, 4.2, 12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4, 6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.0, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
calc xs = value (zip [count (int2let n) xs | n <- [0..25]] table)
value xs = sum [((x - y) ^ 2) / y | (x, y) <- xs]
count x xs = 100 * (sum [1 | y <- xs, y == x]) / (length xs)
where length xs = sum [1 | x <- xs]
take_min xs = [x | (x, y) <- xs, y == mn]
where mn = minimum [y | (_, y) <- xs]
在能理解的范围内
-- Problem #1: define prelude functions using recursions
and :: [Bool] -> Bool
and [] = True
and (x : xs) = x && (and xs)
concat :: [[a]] -> [a]
concat xs = [y | x <- xs, y <- x]
replicate :: Int -> a -> [a]
replicate 0 x = []
replicate n x = x : (replicate (n - 1) x)
(!!) :: [a] -> Int -> a
(!!) xs 0 = head xs
(!!) (x : xs) n = (!!) xs (n - 1)
elem :: Eq a => a -> [a] -> Bool
elem x xs = (sum [1 | y <- xs, y == x]) > 0
-- End Problem #1
-- Problem #2: merge ascending lists
merge :: Ord a => [a] -> [a] -> [a]
merge [] y = y
merge x [] = x
merge xss@(x : xs) yss@(y : ys) = if x < y then (x : merge xs yss) else (y : merge xss ys)
-- End Problem #2
-- Problem #3: merge sort
msort :: Ord a => [a] -> [a]
msort [] = []
msort xs = do
let l = length xs
if l == 1 then xs
else merge (msort (frn (div l 2) xs)) (msort (drop (div l 2) xs))
frn :: Int -> [a] -> [a]
frn 0 xs = []
frn n (x : xs) = x : (frn (n - 1) xs)
foldl, foldr 就不太好理解了。感觉 Haskell 的核心就是不断抽象。
foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b
filter :: (a -> Bool) -> [a] -> [a]
filter p = foldr (filfun p) []
filfun p x xs = (if p x then [x] else []) ++ xs
map :: (a -> b) -> [a] -> [b]
map f = foldr (mapfun f) []
mapfun f x xs = (f x) : xs
type Bit = Int
bin2int :: [Bit] -> Int
bin2int = foldr (\x y -> x + 2 * y) 0
decode :: [Bit] -> String
-- modify this line to add error checking
decode = map (chr . bin2int) . chop
mycheck :: [Bit] -> [Bit]
mycheck xs = do
if mod (sum xs) 2 == 0 then frn 8 xs
else error "error"
chop :: [Bit] -> [[Bit]]
chop [] = []
chop xs = (mycheck (frn 9 xs)) : (chop (drop 9 xs))
-- hint: not 'chop8' any more
-- End Problem #6
很有趣的加法乘法
-- Problem #1: multiplies for natural numbers
data Nat = Zero | Succ Nat
deriving (Show)
add :: Nat -> Nat -> Nat
add Zero n = n
add (Succ m) n = Succ (add m n)
multiplies :: Nat -> Nat -> Nat
multiplies a Zero = Zero
multiplies a (Succ b) = add (multiplies a b) a
-- End Problem #1
本来 eval 是可以直接写的,但是我们可以抽象一下。
-- Problem #2: folde for Exprs
data Expr
= Val Int
| Add Expr Expr
| Mul Expr Expr
deriving (Show)
-- try to figure out the suitable type yourself
folde :: (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a
folde f g h (Val n) = f n
folde f g h (Add x y) = g (folde f g h x) (folde f g h y)
folde f g h (Mul x y) = h (folde f g h x) (folde f g h y)
eval :: Expr -> Int
eval = folde id (+) (*)
-- End Problem #2
有点难的东西
给一些数字,问它们能不能算出 x。还能理解。
data Op
= Add
| Sub
| Mul
| Div
| Exp
deriving Eq
data Expr
= Val Int
| App Op Expr Expr
deriving Eq
i32 = 4294967296
apply :: Op -> Int -> Int -> Int
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = div x y
apply Exp x y = x ^ y
calc :: Int -> Int -> Int -> Bool
calc x cur 0 = cur < i32
calc x cur y = if cur >= i32 then False else calc x (cur * x) (y - 1)
valid :: Op -> Int -> Int -> Bool
valid Add x y = x <= y && x + y < i32
valid Sub x y = x > y
valid Mul x y = x <= y && x > 1 && y > 1 && x * y < i32
valid Div x y = y > 1 && (mod x y == 0)
valid Exp x y = x > 1 && y > 1 && (calc x 1 y)
-- 所有子集
subs :: [a] -> [[a]]
subs [] = [[]]
subs (x : xs) = ys ++ (map (x :) ys)
where ys = subs xs
ins :: a -> [a] -> [[a]]
ins x [] = [[x]]
ins x (y : xs) = (x : y : xs) : (map (y :) (ins x xs))
-- 所有排列
perms :: [a] -> [[a]]
perms [] = [[]]
perms (x : xs) = concat (map (ins x) (perms xs))
-- 所有子集和排列
choice :: [a] -> [[a]]
choice = concat . map perms . subs
-- 所有划分
split :: [a] -> [([a], [a])]
split [] = []
split [_] = []
split (x : xs) = ([x], xs) : [(x : ls, rs) | (ls, rs) <- (split xs)]
-- App :type constructor
combine :: (Expr, Int) -> (Expr, Int) -> [(Expr, Int)]
combine (l,x) (r,y) = [(App o l r, apply o x y) | o <- [Add, Sub, Mul, Div, Exp], valid o x y]
-- 你需要完成下面的 solutions 函数
results :: [Int] -> [(Expr, Int)]
results [] = []
results [n] = [(Val n, n) | n > 0 && n < i32]
results ns = [res | (ls, rs) <- split ns, lx <- results ls, rx <- results rs, res <- combine lx rx]
qsort :: [[a]] -> [[a]]
qsort [] = []
qsort (x : xs) = qsort ys ++ [x] ++ qsort zs
where
len = length x
ys = [a | a <- xs, length a <= len]
zs = [b | b <- xs, length b > len]
solutions :: [Int] -> Int -> [(Expr, Int)]
solutions ns n = near n [(e, w) | ns' <- qsort (choice ns), (e, w) <- results ns']
near :: Int -> [(Expr, Int)] -> [(Expr, Int)]
near n ns = [(e, w) | (e, w) <- ns, abs(w - n) == mn]
where mn = calcmin n ns
calcmin :: Int -> [(Expr, Int)] -> Int
calcmin n [] = i32
calcmin n ((e, w) : xs) = min (abs (w - n)) (calcmin n xs)
instance Show Op where
show Add = "+"
show Sub = "-"
show Mul = "*"
show Div = "/"
show Exp = "^"
-- 提示:指数运算可以显示为 x ^ y
instance Show Expr where
showsPrec _ (Val n) = shows n
showsPrec p (App op x y)
= showParen (p > q)
$ showsPrec q x . showChar ' ' . shows op
. showChar ' ' . showsPrec (succ q) y
where q = case op of
Add -> 6; Sub -> 6
Mul -> 7; Div -> 7
Exp -> 8
-- 提示:给出指数运算的优先级
-- 可以参考Haskell定义的优先级(:info ^)
认识一下 type constructor, IO
module HW9 where
import Prelude
work :: Int -> IO Int
work 0 = return 0
work a = do
t <- getLine
let x = read t :: Int
(+x) <$> (work (a - 1))
-- y <- work (a - 1)
-- return (x + y)
adder :: IO ()
adder = do
putStr "How many numbers ?"
t <- getLine
let a = read t :: Int
x <- work a
putStr "The total is "
putStrLn $ show x
一些不太能理解的东西
class Functor f where
fmap :: (a -> b) -> f a -> f b
(<$) :: a -> f b -> f a
(<$) = fmap . const
class Functor f => Applicative f where
pure :: a -> f a
(<*>) :: f (a -> b) -> f a -> f b
class Applicative m => Monad m where
return :: a -> m a
return = pure
(>>=) :: m a -> (a -> m b) -> m b
(>>) :: m a -> m b -> m b
m >> k = m >>= \_ -> k
上面这些并没有实际写什么东西,它的意思是一个东西是 Functor,你就要实现 fmap
一个东西是 Applicative,你就要实现 pure 和 <*>,一个东西是 Monad,你就要实现 >>=
感觉这个是对一类 type 的抽象。比如 IO a,Just a。IO Monad 解决了交互式程序不太 fit 函数式编程的问题。
下面是一个超难理解的 State Monad
State 会在类型里面暗流涌动
newtype ST a = S (State -> (a, State))
app :: ST a -> State -> (a, State)
app (S f) s = f s
我们先将它定义为 Functor
instance Functor ST where
-- fmap :: (a -> b) -> ST a -> ST b
fmap g st = S $ \s -> let (x, s') = app st s in (g x, s')
然后升级成 Applicative
instance Applicative ST where
-- pure :: a -> ST a
pure x = S $ \s -> (x,s)
-- (<*>) :: ST (a -> b) -> ST a -> ST b
stf <*> stx = S $ \s -> let (f, s' ) = app stf s
(x, s'') = app stx s'
in (f x, s''))
然后升级成 Monad
instance Monad ST where
-- (>>=) :: ST a -> (a -> ST b) -> ST b
st >>= f = S $ \s -> let (x,s') = app st s
in app (f x) s'
有什么用呢?考虑给一颗树重新编号的问题(就是 dfs)
data Tree a = Leaf a | Node (Tree a) (Tree a)
deriving Show
rlabel :: Tree a -> Int -> (Tree Int, Int)
rlabel (Leaf _) n = (Leaf n, n+1)
rlabel (Node l r) n = (Node l' r', n'')
where
(l',n') = rlabel l n
(r',n'') = rlabel r n'
我们用 State 来写,就可以让编号暗流涌动,给出两种写法。
type State = Int
fresh :: ST Int
fresh = S (\n -> (n, n+1))
alabel :: Tree a -> ST (Tree Int)
alabel (Leaf _) = Leaf <$> fresh
alabel (Node l r) = Node <$> alabel l <*> alabel r
mlabel :: Tree a -> ST (Tree Int)
mlabel (Leaf _) = do n <- fresh
return (Leaf n)
mlabel (Node l r) = do l' <- mlabel l
r' <- mlabel r
return (Node l' r')
do 的写法是等价的,我的理解是定义好了的,上面的写法我认为更为容易理解暗流涌动,下面的更直观好写。最后的 label 要靠 app (alabel tree x) 来编(x 是初始编号)。还有我觉得 Leaf 和 Node 应该理解为 function
然后还可以有其他一些 Monad
-- Problem #2: Functor, Applicative, Monad
data Expr a
= Var a
| Val Int
| Add (Expr a) (Expr a)
deriving (Show)
instance Functor Expr where
-- fmap :: (a -> b) -> Expr a -> Expr b
fmap f (Var x) = Var (f x)
fmap f (Val x) = Val x
fmap f (Add x y) = Add (fmap f x) (fmap f y)
instance Applicative Expr where
-- pure :: a -> Expr a
pure = Var
-- <*> :: Expr (a -> b) -> Expr a -> Expr b
(<*>) (Var f) y = fmap f y
(<*>) (Val x) y = Val x
(<*>) (Add x y) z = Add ((<*>) x z) ((<*>) y z)
instance Monad Expr where
-- (>>=) :: Expr a -> (a -> Expr b) -> Expr b
(>>=) (Var x) f = f x
(>>=) (Val x) f = Val x
(>>=) (Add x y) f = Add ((>>=) x f) ((>>=) y f)
-- Write your example here:
-- And explain what the >>= operator for this type does
{- Manual #2
给一个 Expr a, 一个将 a 映射到 Expr b 的函数,(>>=) 会将 Expr a 中所有的 Var a 替换为 Expr b 而不改变 Expr a 的结构。
-}
-- End Problem #2
另一个暗流涌动的例子,是解析一个表达式,暗流涌动的部分在于 String -> (a, String),即 State 表示输入的串,每次取一个出来,把剩下的作为状态流下去。
module HW11 where
import Prelude hiding (Maybe (..))
import Control.Applicative
import Data.Char
-- Problem #1: Extend the expression parser
newtype Parser a = P { parse :: String -> [(a, String)] }
instance Functor Parser where
-- fmap :: (a -> b) -> Parser a -> Parser b
fmap g p = P (\x -> case parse p x of
[] -> []
[(v, out)] -> [(g v, out)])
instance Applicative Parser where
-- pure :: a -> Parser a
pure v = P (\x -> [(v, x)])
-- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
(<*>) pg px = P (\x -> case parse pg x of
[] -> []
[(g, out)] -> parse (fmap g px) out)
item :: Parser Char
item = P (\x -> case x of
[] -> []
(x : xs) -> [(x, xs)])
instance Monad Parser where
-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
p >>= f = P (\x -> case parse p x of
[] -> []
[(v, out)] -> parse (f v) out)
instance Alternative Parser where
-- empty :: Parser a
empty = P (\x -> [])
-- (<|>) :: Parser a -> Parser a -> Parser a
p <|> q = P (\x -> case parse p x of
[] -> parse q x
y -> y)
sat :: (Char -> Bool) -> Parser Char
sat p = do {x <- item; if p x then return x else empty }
char :: Char -> Parser Char
char x = sat (== x)
string :: String -> Parser String
string [] = return []
string (x : xs) = do { char x; string xs; return (x : xs) }
digit :: Parser Char
digit = sat isDigit
space :: Parser()
space = do{ many (sat isSpace); return ()}
token :: Parser a -> Parser a
token p = do {space; v <- p; space; return v }
nat :: Parser Int
nat = do {xs <- some digit; return (read xs) }
natural :: Parser Int
natural = token nat
symbol :: String -> Parser String
symbol xs = token (string xs)
eval :: String -> Int
eval = fst . head . parse expr
expr1 :: (Int -> Int) -> Parser Int
expr1 f = do {
t <- term;
do { symbol "+"; e <- expr1 ((+) (f t)); return e }
<|> do {symbol "-"; e <- expr1 ((-) (f t)); return e}
<|> do {return (f t)}
}
expr :: Parser Int
expr = expr1 ((+) 0)
term1 :: (Int -> Int) -> Parser Int
term1 f = do {
x <- factor;
do {symbol "*"; t <- term1 ((*) (f x)); return t }
<|> do {symbol "/"; t <- term1 (div (f x)); return t }
<|> do {return (f x)}
}
term :: Parser Int
term = term1 ((*) 1)
factor :: Parser Int
factor = do {symbol "("; e <- expr; symbol ")"; return e } <|> natural
-- End Problem #1
最后有一些 lazy evaluation 的例子
-- Problem #4: fibonacci using zip/tail/list-comprehension
gen :: [Integer] -> [Integer]
gen (x : y : xs) = x : gen(y : [z | z <- xs, z >= x + y])
fibs :: [Integer]
fibs = gen [0 ..]
-- 怎么用 zip 和 tail 做呢?
-- End Problem #4
-- Problem #5: Newton's square root
gen2 :: Double -> [Double]
gen2 n = iterate (\x -> (x + n / x) / 2) 1
sqroot :: Double -> Double
sqroot n = fst (head [t | t <- ys, fst t - snd t <= 0.0001, snd t - fst t <= 0.00001])
where xs = gen2 n
ys = zip xs (0 : xs)
-- End Problem #5
我认为 Haskell 就算不断抽象的过程,从遍历 list 普遍抽象到 fold,map 还能抽象到 fmap,IO, Maybe 能抽象成 Monad。另外声明函数类型我觉得是非常美和直观的东西,很难出错。函数返回函数也是一大妙点。