Haskell ！我的 Haskell！

一些简单的东西

  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。另外声明函数类型我觉得是非常美和直观的东西，很难出错。函数返回函数也是一大妙点。