Haskell Monads

Monoid

幺半群

定义: 集合 $M$ 对二元运算满足

封闭性(类型)
结合律(函数)
单位元(幺元)

class Monoid m where
	mempty :: m
	
	mappend :: m -> m -> m
	mappend = (<>)
	
	mconcat :: [m] -> m
	mconcat = foldr mappend mempty

幺半群定律

mempty `mappend` x = x		-- 左幺元
x `mappend` mempty = x		-- 右幺元
(x `mappend` y) `mappend` z = x `mappend` (y `mappend` z)	-- 结合律

Instance

List

++ []

instance Monoid [a] where
	mempty = []
	mappend = (++)

DiffList

二元运算: 右结合 ++

幺元: \xs -> [] ++ xs

newtype DiffList a = DiffList { getDiffList :: [a] -> [a] }

toDiffList :: [a] -> DiffList a
toDiffList xs = DiffList (xs ++)

fromDiffList :: DiffList a -> [a]
fromDiffList (DiffList f) = f []

instance Monoid (DiffList a) where
	mempty = DiffList (\xs -> [] ++ xs)
	(DiffList f) `mappend` (DiffList g) = DiffList (\xs -> f (g xs))

Product

* 1

newtype Product a =  Product { getProduct :: a } deriving (Eq, Ord, Read, Show, Bounded)

instance Num a => Monoid (Product a) where
	mempty = Product 1
	Product x `mappend` Product y = Product (x * y)

Sum

+ 0

newtype Sum a =  Product { getSum :: a } deriving (Eq, Ord, Read, Show, Bounded)

instance Num a => Monoid (Sum a) where  
    mempty = Sum 0  
    Sum x `mappend` Sum y = Sum (x + y)

Any

|| False

newtype Any = Any { getAny :: Bool } deriving (Eq, Ord, Read, Show, Bounded)

instance Monoid Any where  
    mempty = Any False  
    Any x `mappend` Any y = Any (x || y)

All

&& True

newtype All = All { getAll :: Bool } deriving (Eq, Ord, Read, Show, Bounded)

instance Monoid All where  
	mempty = All True  
	All x `mappend` All y = All (x && y)

Ordering

二元运算: 链式比较短路逻辑

幺元 EQ

compare (a1, b1, c1) (a2, b2, c2) = compare a1 a2 <> compare b1 b2 <> compare c1 c2

data Ordering = LT | EQ | GT

instance Monoid Ordering where  
    mempty = EQ  
    LT `mappend` _ = LT  
    EQ `mappend` y = y  
    GT `mappend` _ = GT

结合律证明

(x <> y) <> z = x <> (y <> z)

若 x 为 EQ, 两边均为 y <> z
若 x 不为 EQ, 两边短路返回 x

Maybe

二元运算: Just x <> Just y = Just (x <> y)

幺元: Nothing

instance Monoid a => Monoid (Maybe a) where  
    mempty = Nothing
    
    Nothing `mappend` m = m  
    m `mappend` Nothing = m  
    
    Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)

First

二元运算: 保留第一个 First Just

幺元: First Nothing

newtype First a = First { getFirst :: Maybe a }

instance Monoid (First a) where  
	mempty = First Nothing
	
	First (Just x) `mappend` _ = First (Just x)  
	First Nothing `mappend` x = x

Last

二元运算: 保留第二个 Last Just

幺元: Last Nothing

newtype Last a = Last { getLast :: Maybe a }

instance Monoid (Last a) where
	mempty = Last Nothing
	
	_ `mappend` Last (Just x) = Last (Just x)
	x `mappend` Last Nothing = x

Foldable

foldMap | foldr

class Foldable t where
	foldMap :: Monoid m => (a -> m) -> t a -> m
	foldr :: (a -> b -> b) -> t a -> b

Maybe Monad

context: 可能失败计算

组合: 任一失败则全部失败

pure value: 成功值

类型

data Maybe a = Nothing | Just a

Functor

函数作用于成功值

instance Functor Maybe where
	fmap :: (a -> b) -> Maybe a -> Maybe b
	fmap _ Nothing  = Nothing
	fmap f (Just x) = Just (f x)

Applicative

instance Applicative Maybe where
	pure :: a -> Maybe a
	pure = Just
	
	(<*>) :: Maybe (a -> b) -> Maybe a -> Maybe b
	Nothing <*> _  = Nothing
	(Just f) <*> x = fmap f x

Monad

instance Monad Maybe where
	(>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b
	Nothing >>= _ = Nothing
	Just x >>= f = f x

带错误处理 RPN

总函数

solveRPN :: String -> Maybe Double  
solveRPN st = do  
  			[result] <- foldM eval [] (words st)  
  			return result

读单个 word

readMaybe :: (Read a) => String -> Maybe a 
readMaybe st = case reads st of 
					[(x,"")] -> Just x
                    _ -> Nothing

累加函数

eval :: [Double] -> String -> Maybe [Double] 
eval (x:y:ys) "*" = return ((x * y):ys)  
eval (x:y:ys) "+" = return ((x + y):ys)  
eval (x:y:ys) "-" = return ((y - x):ys)  
eval xs s = liftM (:xs) (readMaybe s)

测试

ghci> solveRPN "1 2 * 4 +"  
Just 6.0  
ghci> solveRPN "1 2 * 4"  
Nothing  
ghci> solveRPN "1 8 wharglbllargh"  
Nothing

State Monad

context: 状态计算

组合: 状态转移

pure value: 状态相关值

定义

类型

-- 状态转换器
type State s = s -> s

-- 状态转换的同时返回结果值
type State s a = s -> (a,s)

状态转换

状态转换器参数通过柯里化来实现

Char -> s -> (a,s)

状态转换2

data 和 newtype 定义的类型才能作为 instance

newtype State s a = State (s -> (a,s))

State s a 是状态转换器, 输入状态, 输出值和状态

类型转换

app :: State s a -> s -> (a,s)
app (State st) = st

app 将状态转换器应用在状态上

Functor

函数应用于状态转换的值上

instance Functor (State s) where
    fmap :: (a -> b) -> State s a -> State s b
    fmap g st = State (\s -> 
                let (x, s') = app st s 
                in (g x, s'))

![fmap 状态转换](../image/fmap 状态转换.png)

Applicative

静态状态转换, 前一状态转换的值(函数)作用于后一状态转换的值

instance Applicative (State s) where
    pure :: a -> State s a
    pure x  = State (\s -> (x,s))

    (<*>) :: State s (a -> b) -> State s a -> State s b
    stf <*> stx = State (\s ->
                        let (f,s')  = app stf s
                            (x,s'') = app stx s'
                        in (f x, s''))

pure

状态转换3

Monad

动态状态转换, 状态转换的值带入 a -> m b 函数

instance Monad (State s) where
    (>>=) :: State s a -> (a -> State s b) -> State s b
    stx >>= f = State (\s ->
            let (x,s') = app stx s
            in app (f x) s')

状态转换4

重标记树

类型

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show

tree :: Tree Char
tree = Node (Node (Leaf 'a') (Leaf 'b')) (Leaf 'c')

需求

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'
> fst (rlabel tree 0)
Node (Node (Leaf 0) (Leaf 1)) (Leaf 2)

定义状态转换器

fresh :: State Int Int
fresh = State (\n -> (n, n+1))

<*> 版重标记函数

alabel :: Tree a -> State Int (Tree Int)
alabel (Leaf _) = Leaf <$> fresh
alabel (Node l r) = Node <$> alabel l <*> alabel r

  alabel (Leaf _) :: State Int (Tree Int)
= Leaf <$> fresh
= ST (\n -> (Leaf n, n+1))

  alabel (Node l r) :: State Int (Tree Int)
= Node <$> alabel l <*> alabel r
= Node <$> State Int (Tree Int) <*> State Int (Tree Int)
= State (\s -> 
		let (l, s') = app (State Int (Tree Int)) s
		in (Node l, s')) <*> State Int (Tree Int)
= State (\s ->
		let
			(Node l, s') = app (Node <$> State Int (Tree Int)) s
			(r , s'') = app (State Int (Tree Int)) s'
		in	(Node l r, s''))
= State Int (Tree Int)

> fst (app (alabel tree) 0)
Node (Node (Leaf 0) (Leaf 1)) (Leaf 2)

>>= 版重标记函数

mlabel :: Tree a -> State Int (Tree Int)
mlabel (Leaf _) = Leaf <$> fresh
mlabel (Node l r) = do  l' <- mlabel l
                        r' <- mlabel r
                        return (Node l' r')

> fst fst (app (mlabel tree) 0)
Node (Node (Leaf 0) (Leaf 1)) (Leaf 2)

((->) r) Monad

context: 依赖环境计算

组合: 环境共享

pure value: 函数作用后值

定义

Functor

函数作用于函数返回值

instance Functor ((->) r) where
	fmap :: (a -> b) -> (r -> a) -> r -> b
	fmap = (.)

Applicative

共享环境 r, 函数作用于返回值

instance Applicative ((->) r) where
	pure :: a -> r -> a
	pure = const
	
	(<*>) :: (r -> a -> b) -> (r -> a) -> r -> b
	f <*> g = \x -> f x (g x)

Monad

依赖性传递 pure value

instance Monad ((->) r) where
	(>>=) :: (r -> a) -> (a -> r -> b) -> r -> b
	g >>= f = \x -> f (g x) x

<*> 练习

(\x y z -> [x,y,z]) <$> (+1) <*> (*2) <*> (/3) $ 3

值表达式归约

  (\x y z -> [x,y,z]) <$> (+1) <*> (*2) <*> (/3)
= (\r -> (\y z -> [r+1,y,z])) <*> (*2) <*> (/3)
= (\r -> (\z -> [r+1,r*2,z])) <*> (/3)
= \r -> [r+1,r*2,r/3]

类型表达式归约

  (a -> b -> c -> d) <$> (r -> a) <*> (r -> b) <*> (r -> c)
= (r -> b -> c -> d) <*> (r -> b) <*> (r -> c)
= (r -> c -> d) <*> (r -> c)
= r -> d

验证

  (\x y z -> [x,y,z]) <$> (+1) <*> (*2) <*> (/3) $ 3
= (\r -> [r+1,r*2,r/3]) $ 3
= [4,6,1]

`>>=` 练习

f :: Int -> Int

f = do  
  	a <- (*2)  
  	b <- (+3)  
  	return (a+b)
  	
f = (*2) >>= \a -> (+3) >>= \b -> return (a + b)

f 4 = ((*2) >>= \a -> (+3) >>= \b -> return (a + b)) 4
	= (\r -> r*2 >>= \a -> (r+3) >>= \b -> return (a + b)) 4
	= (\r -> let a = r*2, b = r+3 in a+b) 4
	= (4*2) + (4+3)
	= 15

[] Monad

context: 非确定性计算

组合: 笛卡尔积

pure value: 所有值

定义

类型

List a = [] | a : List a

Functor

函数作用于 [] 内所有值

instance Functor [] where
	fmap :: (a -> b) -> [a] -> [b]
	fmap = map

Applicative

[函数] 笛卡尔积作用于 [x] 值

instance Applicative [] where
	pure :: a -> [a]
	pure x = [x]
	
	(<*>) :: [a -> b] -> [a] -> [b]
	fs <*> xs = [f x | f <- fs, x <- xs]

Monad

[x] 每个值映射为一个 [y], 再组装为一个 [y]

instance Monad [] where
	(>>=) :: [a] -> (a -> [b]) -> [b]
	xs >>= f = concatMap f xs

国际象棋

类型

type Pos = (Int, Int)

需求

定义移动函数, 从当前步走到下一步的所有可能

>>= 版 move

move :: Pos -> [Pos]
move (x, y) = do
		(x', y') <- [ (x + dx, y + dy) | (dx, dy) <- [(2, -1), (2, 1), (-2, -1), (-2, 1), (1, -2), (1, 2), (-1, -2), (-1, 2)]]
		guard (x' `elem` [1..8] && y' `elem` [1..8])
		return (x', y')

逻辑函数

in3 :: Pos -> [Pos]
in3 x = do
	y <- move x
	z <- move y
	move z
	
in3 x = return x >>= move >>= move >>= move

inX :: Int -> Pos -> [Pos]
inX x st = return st >>= foldr (<=<) return (replicate x move)

canReach :: Int -> Pos -> Pos -> Bool
canReach x st ed = ed `elem` inX x st

Context 函数

sequenceA

sequenceA :: (Applicative f) => [f a] -> f [a] 
sequenceA [] = pure []  
sequenceA (x:xs) = (:) <$> x <*> sequenceA xs

sequenceA :: (Applicative f) => [f a] -> f [a] 
sequenceA = foldr (liftA2 (:)) (pure [])

sequenceA [Just 1, Just 2] = Just [1, 2]
sequenceA [Just 1, Nothing, Just 2] = Nothing

sequenceA [[1,2], [3,4]] = [[1,3], [1,4], [2,3], [2,4]]
sequenceA [[1,2,3],[4,5,6],[3,4,4],[]] = []

sequenceA [getLine, getLine, getLine] = do
	x <- getLine
	y <- getLine
	z <- getLine
	return [x,y,z]

sequenceA [(+3), (*2), (/2)] = \r -> [r+3, r*2, r/2]

自定义 Monad

context: 带有几率的 List

类型

[(a,p)] 元素后附带几率

newtype Prob a = Prob { getProb :: [(a, Rational)]}

Prob [(1, 1%2), (2, 1%4), (3, 1%4)] :: Prob Int

Functor

context 维护: fmap f 作用于包裹的值, 不影响几率

instance Functor Prob where
	fmap :: (a -> b) -> Prob a -> Prob b
	fmap f (Prob xs) = Prob $ map (\(x, p) -> (f x, p)) xs
	fmap f (Prob xs) = Prob $ [ (f x, p) | (x, p) <- xs]

数据流

fmap gegate (Prob [(1, 1%2), (2, 1%4), (3, 1%4)]) = Prob [(-1, 1%2), (-2, 1%4), (-3, 1%4)]

f = gegate
xs = [(1, 1%2), (2, 1%4), (3, 1%4)]
--	xs
--		(x, p) <- xs	-> 	(1, 1%2), (2, 1%4), (3, 1%4) 多种可能性
--		(f x, p)		-> 	(-1, 1%2), (-2, 1%4), (-3, 1%4) 多种可能性
--		[(f x, p)]		-> 	[(-1, 1%2), (-2, 1%4), (-3, 1%4)]

Applicative

context 附加: 最小 context 显然是给 x 附加 1%1 几率

context 维护: Prob fs 与 Prob xs 组合

list context, 结果是 fs xs 笛卡尔积
Prob context, 值为 f 映射后的值, 几率为 f x 二者概率乘法

instance Applicative Prob where
	pure x = Prob [(x, 1%1)]
	(<*>) :: Prob (a -> b) -> Prob a -> Prob b
	Prob fs <*> Prob xs = Prob $ [ (f x, p * p') | (f, p) <- fs, (x, p') <- xs]

数据流

Prob [((+2), 1%2), ((*3), 1%2)] <*> Prob [(1, 1%2), (2, 1%2)] =
Prob [(3, 1 % 4),(4, 1 % 4),(3, 1 % 4),(6, 1 % 4)]

fs = [((+2), 1%2), ((*3), 1%2)]
xs = [(1, 1%2), (2, 1%2)]

--	fs
--		(f, p) <- fs 			->	((+2), 1%2), ((*3), 1%2)
--	xs
--		(x, p') <- xs			-> 	(1, 1%2), (2, 1%2)

--	合流
--		(f x, p * p') 			-> 	(3, 1%4), (4, 1%4), (3, 1%4), (6, 1%4)
--		Prob [ (f x, p * p') ]	->	Prob [(3, 1 % 4),(4, 1 % 4),(3, 1 % 4),(6, 1 % 4)]

Monad

context 附加: 最小 context 显然是给 x 附加 1%1 几率

context 维护: f 维护 Prob xs

list context, 结果是 xs 与 (f a) 笛卡尔积
Prob context, 值为 f 映射后的值, 几率为 x (f x)二者概率乘法

instance Monad Prob where
	return x = Prob [(x, 1%1)]
	
	(>>=) :: Prob a -> (a -> Prob b) -> Prob b
	Prob xs >>= f = Prob $ [ (x, p * p') | (a, p) <- xs, (x, p') <- getProb (f a)]

数据流

f :: Int -> Prob Int
f x = Prob [((x+2), 1%2), ((x*3), 1%2)]

Prob [(1, 1%2), (2, 1%2)] >>= f =
Prob [(3,1 % 4),(3,1 % 4),(4,1 % 4),(6,1 % 4)]

xs = [(1, 1%2), (2, 1%2)]
f x = Prob [((x+2), 1%2), ((x*3), 1%2)]

-- 	xs
--		(a, p) <- xs				->	(1, 1%2), (2, 1%2)
--		(x, p') <- getProb (f a)	-> 	(3, 1%2), (3, 1%2), (4, 1%2), (6, 1%2)
--		(x, p * p')					-> 	(3, 1%4), (3, 1%4), (4, 1%4), (6, 1%4)
--		Prob [ (x, p * p') ]		-> 	Prob [(3,1 % 4),(3,1 % 4),(4,1 % 4),(6,1 % 4)]

m >> f = join (fmap f m) 角度定义 >>=

考虑 Prob (Prob a)

Prob [(Prob [(1, 1%2),(2, 1%2)], 1%4 ), (Prob [(3, 1%2),(4, 1%2)], 3%4)] :: Prob (Prob a)

flatten

脱去一层 m 包裹

flatten :: Prob (Prob a) -> Prob a
flatten (Prob xs) = Prob $ [ (x, p * p') | (a, p) <- xs, (x, p') <- getProb a]

flatten :: Prob (Prob a) -> Prob a  
flatten (Prob xs) = Prob $ concat $ map f xs  
    where
    	f :: (Prob a, Rational) -> [(a, Rational)]
    	f (Prob innerxs, p) = map (\(x, p') -> (x ,p * p')) innerxs 	-- innerxs 等价于上面的 getProb a

数据流

flatten (Prob [(Prob [(1, 1%2),(2, 1%2)], 1%4 ), (Prob [(3, 1%2),(4, 1%2)], 3%4)]) =
Prob [(1,1 % 8),(2,1 % 8),(3,3 % 8),(4,3 % 8)]

xs = [(Prob [(1, 1%2),(2, 1%2)], 1%4 ), (Prob [(3, 1%2),(4, 1%2)], 3%4)]

--	xs
--		x <- xs		->	(Prob [(1, 1%2),(2, 1%2)], 1%4 ), (Prob [(3, 1%2),(4, 1%2)], 3%4)
--		f x			
--			innerxs = [(1, 1%2),(2, 1%2)], [(3, 1%2),(4, 1%2)]
--			p = 1%4, 3%4
--				(x, p') <- innerxs	-> 	(1, 1%2),(2, 1%2)	| 	(3, 1%2),(4, 1%2)
--				(x ,p * p')			-> 	(1, 1%8),(2, 1%8)	| 	(3, 3%8),(4, 3%8)
--		[f x]						-> 	[[(1, 1%8),(2, 1%8)], [(3, 3%8),(4, 3%8)]]
--		concat [f x]				-> 	[(1, 1%8),(2, 1%8),(3, 3%8),(4, 3%8)]
--		Prob $ concat $ map f xs	-> 	Prob [(1, 1%8),(2, 1%8),(3, 3%8),(4, 3%8)]

用 flatten 代替 join 从 m >> f = join (fmap f m) 角度定义 >>=

instance Monad Prob where  
    return x = Prob [(x,1%1)]
    
    m >>= f = flatten (fmap f m)

证明单子定律

return x >>= f 
	= Prob [(x, 1%1)] >>= f 
	= Prob $ [ (x', p) | (x', p ) <- getProb (f x)] 
	= f x

m >> return 
	= Prob $ [ (x, p * p') | (a, p) <- getProb m, (x, p') <- getProb (return a)]
	= Prob $ [ (x, p * p') | (a, p) <- getProb m, (x, p') <- getProb (Prob [(a, 1%1)])]
	= Prob $ [ (a, p)] | (a, p) <- getProb m]
	= m

m >>= (\x -> k x >>= h) 
	= m >>= (\x -> Prob $ [ (a_h, p_k * p_h) | (a_k, p_k) <- getProb (k x), (a_h, p_h) <- getProb (h a_k)])
	= Prob $ [ (a, p_m * p) | (a_m, p_m) <- getProb m, (a, p) <- getProb (... a_m)]
	= Prob $ [ (a_h, p_m * p_k * p_h) | (a_m, p_m) <- getProb m, (a_h, p_k * p_h) <- [ (a_h, p_k * p_h) | (a_k, p_k) <- getProb (k a_m), (a_h, p_h) <- getProb (h a_k)]]
	= Prob $ [(a_h, p_m * p_k * p_h) | (a_m, p_m) <- getProb m, (a_k, p_k) <- getProb (k a_m), (a_h, p_h) <- getProb (h a_k)]


(m >>= k) >>= h
	= (Prob $ [ (a_k, p_m * p_k) | (a_m, p_m) <- getProb m, (a_k, p_k) <- getProb (k a_m)]) >>= h
	= Prob $ [(a_h, p_m * p_k * p_h) | (a_k, p_m * p_k) <- [ (a_k, p_m * p_k) | (a_m, p_m) <- getProb m, (a_k, p_k) <- getProb (k a_m)], (a_h, p_h) <- getProb (h a_k)]
	= Prob $ [(a_h, p_m * p_k * p_h) | (a_m, p_m) <- getProb m, (a_k, p_k) <- getProb (k a_m), (a_h, p_h) <- getProb (h a_k)]
	
所以 m >>= (\x -> k x >>= h) == (m >>= k) >>= h

posted @ 2025-05-07 22:27 (.)$(.) 阅读(15) 评论(0) 收藏举报

刷新页面返回顶部

clearlife

Haskell Monads

Haskell Monads

Monoid

幺半群

幺半群定律

Instance

Foldable

Maybe Monad

带错误处理 RPN

State Monad

定义

重标记树

((->) r) Monad

定义

<*> 练习

`>>=` 练习

[] Monad

定义

国际象棋

Context 函数

sequenceA

自定义 Monad

公告

clearlife

Haskell Monads

Haskell Monads

Monoid

幺半群

幺半群定律

Instance

Foldable

Maybe Monad

带错误处理 RPN

State Monad

定义

重标记树

((->) r) Monad

定义

<*> 练习

>>= 练习

[] Monad

定义

国际象棋

Context 函数

sequenceA

自定义 Monad

公告

`>>=` 练习