baby.hs

{-# LANGUAGE InstanceSigs #-}

-- import Geometry 
import qualified Data.Map as Map  
import Data.Char  
import Data.List
import Data.Monoid
import qualified Data.Foldable as F  
import Control.Applicative
import Control.Monad
import Control.Monad.Writer 
import Control.Monad.State
import Data.Ratio
import Control.Monad.Trans.Cont

{- 多行註解 comment 
-- 單行註解 comment   

參考資料  https://wiki.haskell.org/Reference_card

指令
:l [filename].hs	讀入程式碼
:r			重新讀入程式碼
:t			查看function 的 type signature。 :t mod, :t (-)
:k			kinds ，其中 * 代表 concrete type ， :k Int, :k (->), :k (), :k (,)
:info

prefix infix postfix  同一個 function 各種表達方式 這都是為了增加程式的可讀性
例如:
map (+1) [1]
(+1) `map`  [1]
兩種表達方式都是相等的，operator 放在前面的是 prefix 是 map ，operator 放在中間的是 infix 是 `map` 
典型的 infix 有  +, -, *, /, =, /= ( Haskell裡面的不等於  ) 
infix 的 operator 要寫成 prefix 的形式時要加上()括號，例如 (+) 1 1 
prefix 的 operator 要寫成 infix 的形式時要加上`` 重音符號 grave accent，例如 (+1) `map` [1] 


Curry 最基本卻是最具魔力的利器，也是 type signature 能有相同的樣子不同的組合的最大利器 



Haskell 的重點 lift 的概念
https://wiki.haskell.org/Lifting
https://stackoverflow.com/a/2395956/1584100

    (<$>) :: Functor f => (a -> b) -> f a -> f b
It applies the function to the wrapped value. 
    (<*>) :: Applicative f => f (a -> b) -> f a -> f b
It applies the wrapped function to the wrapped value. 
    liftA :: Applicative f => (a -> b) -> f a -> f b
    liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
    liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
But you don't actually use them very often because there is another operator 
    (<$>) = fmap
This lets you write:
    result = myFunction <$> arg1 <*> arg2 <*> arg3 <*> arg4
This in turn can be applied to the next argument using (<*>), and so on.
不管是 (<$>) 或 (<*>) 都可以看成
    (<$>) :: Functor f => (a -> b) -> (f a -> f b)
    (<*>) :: Applicative f => f (a -> b) -> (f a -> f b)
仔細觀察其中 (a -> b) function 轉換成帶有特定 Type Class  (如: Functor, Applicative) 的 (f a -> f b) function
Lifting is a concept which allows you to transform a function into a corresponding function within another (usually more general) setting.
    > liftA2 (+) (Just 1) (Just 2)
    Just 3
    > (+) <$> (Just 1) <*> (Just 2)
    Just 3
在 Haskell 中的 Type Class 就如同 Java 的 interface 一樣，data type 可以 instance 數個 Type class  


Function composition
    (.) :: (b -> c) -> (a -> b) -> a -> c
    (.) f g = (\ x -> f (g x) )

    (.) . (.) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
    (.) . (.)   = (\ x -> (.) ((.) x) )

                根據 ((.) x) 對應 x 為 
                x  :: (b -> c) 
                而 (.) x 等同於剩下的 Type signature 為 (a -> b) -> a -> c  為了區別而寫成 (a2 -> b2) -> a2 -> c2
                也就是需要兩個參數 (a2 -> b2) 跟 a2 才能得到結果 c2 因此令
                x2 :: (a2 -> b2)
                (.) x :: (a2 -> b2) -> a2 -> c2
                (.) x = (\ x2  a2 -> x(x2 a2))
                = (\ x -> (.) (\ x2 a2 -> x(x2 a2) ) )
  
                根據 (.) (\ x2 a2 -> x(x2 a2) ) 對應 (b -> c) 為了區別而且成 (b3 -> c3)
                b3 對應 x2 ， 而 c3 對應 a2 -> x(x2 a2) 的剩餘結果
                而 (.) (\ x2 a2 -> x(x2 a2) ) 等同於剩下的 Type signature 為 (a3 -> b3) -> a3 -> c3
                也就是需要兩個參數 (a3 -> b3) 跟 a3 才能得到結果 c3 因此令
                x3 :: (a3 -> b3)
                (.) (\ x2 a2 -> x(x2 a2) ) :: (a3 -> b3) -> a3 -> c3
                (.) (\ x2 a2 -> x(x2 a2) ) = (\ x3 a3 -> (\ x2 a2 -> x(x2 a2) )(x3 a3) )
                = (\ x -> (\ x3 a3 -> (\ x2 a2 -> x(x2 a2) )(x3 a3) ) )

                根據觀察進行推斷  * 代表 concrete type
                a2 :: *
                x2 :: * -> *
                x  :: * -> *
                a3 :: *
                x2 為 (x3 a3) 帶入的結果，因此可推斷 x3
                x3 :: * -> * -> * 
                a2 :: *
                依序輸入為 x x3 a3 a2 共4個參數

    > ((.) . (.)) (/2) (/) 8 2
    2.0

    > let f = (\ x -> (\ x3 a3 -> (\ x2 a2 -> x(x2 a2) )(x3 a3) ) )
    > f (/2) (/) 8 2
    2.0

Type Signature 是從最右邊的輸出往左邊推出來的，例如
    (.) :: (b -> c) -> (a -> b) -> a -> c
    當 apples (b -> c) function to b 結果為 c
    當 apples (a -> b) function to a 結果為 b
    a c 都是某種 concrete type 
    
    假設 c 是帶有1個參數的function 表示為 (c -> d)
    那反推回去就是
    (.) :: (b -> (c -> d)) -> (a -> b) -> a -> (c -> d)
    而 (b -> (c -> d)) 因為 Curry 特性的關係可以看成 (b -> c -> d)
    也就是 輸入 b 回傳一個 (c -> d) 的 function
    或者是 輸入 b 和 c 回傳一個 d 的 function
    例如 
    > (.) (/) (/2) 12 
    就是一個  12 / 2 = 6 帶入 (/) 變成 (6/) 的 function 也就是 (c -> d)
    > (.) (/) (/2) 12 2
    3
    此時是輸入 b c 得到 d 的 function
    > (6/) 2
    3

    假設現在 b 是也是帶有1個參數 function 表示為 (b1 -> b2)
    那反推回去就是
    (.) :: ((b1 -> b2) -> (c -> d)) -> (a -> (b1 -> b2)) -> a -> (c -> d)
    此時 ((b1 -> b2) -> (c -> d)) 是不能把 (b1 -> b2) 拆開的，因為 (b1 -> b2) 來自於 (a -> (b1 -> b2)) function 的輸出
    因此 ((b1 -> b2) -> (c -> d)) 最多拆成 ((b1 -> b2) -> c -> d) 跟之前一樣
    而 (a -> (b1 -> b2)) 可以拆成 (a -> b1 -> b2) 可以拆成兩個參數 a 跟 b1 回傳 b2 的 function
    例如
    > (.) (\ f x -> f x) (/) 12  
    12 帶入 (/) 得到 (12/) , 帶入 (\ f x -> f x) 得到 (\ x -> (12/) x ) 的 function
    > (.) (\ f x -> f x) (/) 12 2
    6.0


Concrete Type
使用 :k 指令來查詢 資料型態的 concrete type
Int :: *
String :: *
Maybe :: * -> *
Either :: * -> * -> *
Maybe 需要一個 concrete type 才能成為一個 concrete type
Maybe String, Maybe Int 這都是 concret type
Eitehr 需要兩個 concrete type 才能成為一個 concrete type
Either String Int
    

Tuple 資料型態
() zero-element tuple
(1) one-element tuple
(1,2) two-elements tuple


Function 資料型態
(->) 在 Haskell 代表輸入輸出的 Function
> :k (->) 
(->) :: TYPE q -> TYPE r -> *


Lambda 表示方式
(\ a b -> a + b) 其中 a b 是參數 ，a + b 是輸出結果


Pattern Match
而 Pattern Match 也是可以看成 Overload (Ad hoc polymorphism)


縮排代表程式的範圍


where用法
https://youtu.be/02_H3LjqMr8?t=42m37s


-}

batAvgRating hits atBats
    | avg <= 0.002 = "Terrible Batting Average"
    | avg <= 0.250 = "Average Player"
    | avg <= 0.280 = "You doing pretty goood"
    | otherwise = "You're a Superstar"
    where avg = hits / atBats

times4 :: Int -> Int
times4 x = x * 4

listTimes4 = map times4 [1,2,3,4,5]
-- [4,8,12,16,20]

multBy4 :: [Int] -> [Int]
multBy4 [] = []
multBy4 (x:xs) = times4 x : multBy4 xs
{-
    x 為第一個  xs 為剩餘的
    [1,2,3,4] : x = 1 | xs = [2,3,4]
    [2,3,4] : x = 2 | xs = [3,4]
-}
    
doMult :: (Int -> Int) -> Int
doMult func = func 3
num3Times4 = doMult times4


-- Curry 基本概念
getAddFunc :: Int -> (Int -> Int)
getAddFunc x y = x + y

adds3 = getAddFunc 3
-- x=3  這裡返回是 function

fourPlus3 = adds3 4
-- y=4  輸出結果是 7

threePlusList = map adds3 [1,2,3,4,5]
-- [4,5,6,7,8]


--  /= 不相等 布林運算子
doubleEvenNumber y =
    if (y `mod` 2 /= 0) then 
        y
    else 
        y*2

{-
    In Haskell
    So functions are Functors too!
    When you use fmap on a function, you're just doing function composition!
-}















data LockerState = Taken | Free deriving (Show, Eq)  
type Code = String  
type LockerMap = Map.Map Int (LockerState, Code) 

lockerLookup :: Int -> LockerMap -> Either String Code 
lockerLookup lockerNumber map = 
        case Map.lookup lockerNumber map of
            Nothing             ->  Left $ "Locker number " ++ show lockerNumber ++ " doesn't exist!"
            Just (state, code)  ->  if (state == Taken) then 
                                        Left $ "Locker " ++ show lockerNumber ++ " is already taken!" 
                                    else 
                                        Right code

lockers :: LockerMap  
lockers = Map.fromList   
    [(100,(Taken,"ZD39I"))  
    ,(101,(Free,"JAH3I"))  
    ,(103,(Free,"IQSA9"))  
    ,(105,(Free,"QOTSA"))  
    ,(109,(Taken,"893JJ"))  
    ,(110,(Taken,"99292"))  
    ]  



doubleMe :: Num a => a -> a
doubleMe x = x + x
doubleUs :: Num a => a -> a -> a
doubleUs x y = doubleMe x + doubleMe y
doubleSmallNumber x = if x > 100 
                        then x 
                        else x * 2
doubleSmallNumber' x = (if x > 100 then x else x * 2) + 1

length' :: Num b => [a] -> b
-- length' xs = sum [1 | x <- xs]
length' [] = 0
length' (_:xs) = 1 + length' xs

addThree :: Int -> Int -> Int -> Int  
addThree x y z = x + y + z  

lucky :: (Integral a) => a -> String
lucky 7 = "Lucky number 7!"
lucky x = "Sorry, you're out of luck, pal!"

factorial :: (Integral a) => a -> a
factorial 0 = 1
factorial n = n * factorial(n-1)

addVectors :: (Num a) => (a, a) -> (a, a) -> (a, a)  
addVectors a b = (fst a + fst b, snd a + snd b)  

head' :: [a] -> a
head' [] = error "empty"
head' (a:_) = a  


tell :: (Show a) => [a] -> String  
tell [] = "The list is empty"  
tell (x:[]) = "The list has one element: " ++ show x  
tell (x:y:[]) = "The list has two elements: " ++ show x ++ " and " ++ show y  
tell (x:y:_) = "This list is long. The first two elements are: " ++ show x ++ " and " ++ show y

sum' :: Num a => [a] -> a
sum' [] = 0
sum' (x:xs) = x + sum' xs

max' :: Ord a => a -> a -> a
max' a b
    | a > b = a
    | b > a = b
    | otherwise = a

myCompare :: Ord a => a -> a -> Ordering
a `myCompare` b
    | a > b = GT
    | a == b = EQ
    | otherwise = LT

bmiTell :: (RealFloat a) => a -> a -> String
bmiTell weight height
    | bmi <= skinny = "You're underweight."
    | bmi <= normal = "You're normal."
    | bmi <= fat    = "You're fat!"
    | otherwise     = "You're a whale."
    where   bmi = weight / height ^ 2
            skinny = 18.5
            normal = 25.0
            fat = 30.0
            -- (skinny, normal, fat) = (18.5, 25.0, 30.0) 


initials :: String -> String -> String  
initials firstname lastname = [f] ++ ". " ++ [l] ++ "."  
    where   (f:_) = firstname  
            (l:_) = lastname

calcBmis :: (RealFloat a) => [(a, a)] -> [a]
calcBmis xs = [bmi | (w, h) <- xs, let bmi = w / h ^ 2, bmi >= 25.0]  
{-
calcBmis xs = [ bmi w h | (w, h) <- xs ]
                where   bmi weight hight = weight / hight ^ 2
-}

describeList :: [a] -> String  
describeList xs = "The list is " ++ case xs of [] -> "empty."  
                                               [x] -> "a singleton list."   
                                               xs -> "a longer list."  

describeList' :: [a] -> String  
describeList' xs = "The list is " ++ what xs  
    where what [] = "empty."  
          what [x] = "a singleton list."  
          what xs = "a longer list." 

maximum' :: (Ord a) => [a] -> a
maximum' [] = error "maximum' of empty list"
maximum' [x] = x
maximum' (x:xs) = let max 
                        | x > x2 = x
                        | otherwise = x2
                        where x2 = maximum' xs
                  in max
{-
maximum' (x:xs) = if x > x2
                  then x 
                  else x2
                  where x2 = maximum' xs
-}


-- use guards
replicate' :: (Num n, Ord n) => n -> value -> [value]
replicate' n value
    | n <=0 = []
    | otherwise = value : replicate' (n-1) value

take' :: (Num i, Ord i) => i -> [a] -> [a]
take' i []          = []
take' i (x:xs)
    | i <= 0        = []
    | otherwise     = x : take' (i-1) xs

reverse' :: [a] -> [a]
reverse' []         = []
reverse' (x:[])     = [x]
reverse' (x:xs)     = reverse' xs ++ [x]

repeat' :: a -> [a]
repeat' x = x:repeat' x

zip' :: [a] -> [b] -> [(a, b)]
zip' [] ignore = []
zip' ignore [] = []
zip' (x:xs) (y:ys) = (x,y) : zip' xs ys

elem' :: (Eq a) => a -> [a] -> Bool
elem' _ []      = False
--elem' a (x:xs)  = if a==x then True else elem' a xs
--elem' a (x:xs) = a==x || elem' a xs
elem' a (x:xs)
    | a==x      = True
    | otherwise = elem' a xs

quicksort :: (Ord a) => [a] -> [a]
quicksort [] = []
{-
quicksort (x:xs) = lteSorted ++ [x] ++ gtSorted 
                    where 
                        lteSorted = quicksort [a | a <- xs, a<=x]
                        gtSorted  = quicksort [a | a <- xs, a>x]
-}
quicksort (x:xs) =
    let
        lteSorted = quicksort [a | a <- xs, a<=x]
        gtSorted  = quicksort [a | a <- xs, a>x]
    in lteSorted ++ [x] ++ gtSorted

multiThree :: (Num a) => a -> a -> a -> a
multiThree x y z = x * y * z


compareWith100 :: (Num a, Ord a) => a -> Ordering
-- compareWith100 x = 100 `compare` x
-- curried
-- compareWith100 = compare 100
compareWith100 = (100 `compare`)

zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' _ [] _             = []
zipWith' _ _ []             = []
zipWith' f (x:xs) (y:ys)    = f x y : zipWith' f xs ys

flip' :: (a -> b -> c) -> (b -> a -> c)  
flip' f x y = f y x

filter' :: (a -> Bool) -> [a] -> [a]  
filter' _ [] = []
filter' p (x:xs)
    | p x       = x : filter' p xs
    | otherwise = filter' p xs

largestDivisible :: (Integral a) => a
largestDivisible = head (filter p [100000,99999 .. 1])
                   where
                        p :: (Integral a) => a -> Bool
                        p x = (mod x 3829) == 0
{-
    let 
        r   = [100000,99999 .. 1]
        p :: (Integral a) => a -> Bool
        p x = x `mod` 3829 == 0 
    in head (filter p r)  
-}

collatz :: (Integral a) => a -> [a]
collatz 1 = [1]
collatz n
        | odd n     = n : collatz (n*3 + 1)  
        | otherwise = n : collatz (div n 2)

-- fromIntegral  可以將 length 從 int 轉成 num
collatz100ChainGt15 :: Int
collatz100ChainGt15 = length (filter lengthGt15 [(collatz n) |n <- [100,99..1]])
-- collatz100ChainGt15 = length (filter lengthGt15 (map collatz [100,99..1]))
                      where 
                            lengthGt15 :: (Integral a) => [a] -> Bool
                            lengthGt15 xs = (length xs > 15)

-- JS reduce, Haskell foldl 
--  (accumulator -> currentValue -> newAccumulator) -> initialValue


elem'' :: (Eq a) => a -> [a] -> Bool
-- elem'' x y = foldl (\acc e -> acc || x==e) False y
elem'' x y = foldl (\acc e -> if x==e then True else acc) False y

map' :: (a -> b) -> [a] -> [b]
map' f xs = foldr (\x acc -> f x:acc) [] xs

maximum'' :: (Ord a) => [a] -> a
-- maximum'' (x:xs) = foldl (\acc v-> if v > acc then v else acc) x xs
maximum'' = foldl1 (\acc v-> if v > acc then v else acc)

reverse'' :: [a] -> [a]
-- reverse'' xs = foldl (\acc v-> v:acc ) [] xs
-- reverse'' = foldl (\acc v-> v:acc ) []
reverse'' = foldl (flip (:)) []

product'' :: (Num a) => [a] -> a
--product'' = foldl1 (\acc v -> acc * v)
product'' = foldl1 (*)

filter'' :: (a -> Bool) -> [a] -> [a]
filter'' p = foldr (\v acc->if p v then v:acc else acc) []

head'' :: [a] -> a
head'' = foldl1 (\acc v-> acc)

last'' :: [a] -> a
last'' = foldr1 (\v acc-> acc)


-- data List a = Empty | Cons { listHead :: a, listTail :: List a} deriving (Show, Read, Eq, Ord)  
infixr 5 :-:
data List a = Empty | a :-: (List a) deriving (Show, Read, Eq, Ord)  

infixr 5  .++  
(.++) :: List a -> List a -> List a   
Empty .++ ys = ys  
(x :-: xs) .++ ys = x :-: (xs .++ ys) 


data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)  

singleton :: a -> Tree a  
singleton x = Node x EmptyTree EmptyTree

treeInsert :: (Ord a) => a -> Tree a -> Tree a
treeInsert x EmptyTree = singleton x
treeInsert x (Node a left right)
    |   x == a  = Node x left right 
    |   x < a   = Node a (treeInsert x left) right
    |   x > a   = Node a left (treeInsert x right)

treeElem :: (Ord a) => a -> Tree a -> Bool
treeElem x EmptyTree = False
treeElem x (Node a left right)
    | x == a    = True
    | x < a     = treeElem x left
    | x > a     = treeElem x right


-- 定義紅綠燈
data TrafficLight = Red | Yellow | Green  
-- 實作 Eq typeclass 
instance Eq TrafficLight where  
    Red == Red          = True  
    Green == Green      = True  
    Yellow == Yellow    = True  
    _ == _              = False 

instance Show TrafficLight where  
    show Red = "Red light"  
    show Yellow = "Yellow light"  
    show Green = "Green light"

{-
class (Eq a) => Num a where  
    ... 

 As we mentioned previously, there are a lot of places where we can cram in class constraints. 
 So this is just like writing class Num a where, only we state that our type a must be an instance of Eq. 
-}

class YesNo a where  
    yesno :: a -> Bool  

instance YesNo Int where
    yesno 0 = False
    yesno _ = True

instance YesNo [a] where  
    yesno [] = False  
    yesno _ = True  

instance YesNo Bool where  
    yesno = id 

-- Huh? What's id? It's just a standard library function that takes a parameter and returns the same thing, 
-- which is what we would be writing here anyway.

instance YesNo (Maybe a) where  
    yesno (Just _) = True  
    yesno Nothing = False  

instance YesNo (Tree a) where 
    yesno EmptyTree = False
    yesno _ = True

instance YesNo TrafficLight where  
    yesno Red = False  
    yesno _ = True  

yesnoIf :: (YesNo y) => y -> a -> a -> a
yesnoIf yesnoVal yesResult noResult = if yesno yesnoVal then yesResult else noResult

instance Functor Tree where  
    fmap f EmptyTree = EmptyTree
    fmap f (Node x leftsub rightsub) = Node (f x) (fmap f leftsub) (fmap f rightsub)

class Tofu t where  
    tofu :: j a -> t a j

data Frank a b  = Frank {frankField :: b a} deriving (Show)

instance Tofu Frank where  
    tofu x = Frank x

{-
    > tofu (Just 'a') :: Frank Char Maybe  
    Frank {frankField = Just 'a'}  

    > tofu ["HELLO"] :: Frank [Char] []  
    Frank {frankField = ["HELLO"]}  
-}

data Barry t k p = Barry { yabba :: p, dabba :: t k } 

instance Functor (Barry a b) where  
    fmap f (Barry {yabba = x, dabba = y}) = Barry {yabba = f x, dabba = y}  


main :: IO()
main = do 
    line <- fmap reverse getLine  
    putStrLn $ "You said " ++ line ++ " backwards!"  
    putStrLn $ "Yes, you really said" ++ line ++ " backwards!"  

main2 = do 
    line <- fmap (intersperse '-' . reverse . map toUpper) getLine  
    putStrLn line  


data CMaybe a = CNothing | CJust Int a deriving (Show)  
instance Functor CMaybe where  
    fmap f CNothing = CNothing  
    fmap f (CJust counter x) = CJust (counter+1) (f x)  


data CoolBool = CoolBool { getCoolBool :: Bool }  

helloMe :: CoolBool -> String  
helloMe (CoolBool _) = "hello"  

-- helloMe undefined  
-- "*** Exception: Prelude.undefined  
-- helloMe $ CoolBool False

instance F.Foldable Tree where  
    foldMap f EmptyTree = mempty
    foldMap f (Node x l r) = F.foldMap f l `mappend`
                             f x           `mappend`
                             F.foldMap f r

nums = [5,3,1,9,6,8,10]  
testTree  = foldr treeInsert EmptyTree nums

justH :: Maybe Char
justH = do  
    (x:xs) <- Just "hello"  
    return x 

justH2 =
    Just "hello" >>= (\(x:xs)->
        return x)


wopwop :: Maybe Char  
wopwop = do  
    (x:xs) <- Just ""  
    return x
    

listOfTuples :: [(Int,Char)]  
listOfTuples = do  
    n <- [1,2]  
    ch <- ['a','b']  
    return (n,ch)  


listOfTuples2 :: [(Int,Char)]  
listOfTuples2 =
    [1,2] >>= (\n ->  
    ['a','b'] >>= (\ch -> 
    return (n,ch)))


class (Monad m) => MonadPlus2 m where  
    mzero2 :: m a
    mplus2 :: (Monoid a) => m a -> m a -> m a  

{-
    MonadPlus 的定義 如同 Functor 類似， 他不是一個 concrete type ，似乎是根據 function 的定義推斷出來的
    這裡的 mplus 增加了 (Monoid a) 限制了 a 必須為 Monoid 所以才能使用 mappend

    class Functor f where  
        fmap :: (a -> b) -> f a -> f b

    instance Functor [] where  
        fmap = map  
    
    instance Functor Maybe where  
        fmap f (Just x) = Just (f x)  
        fmap f Nothing = Nothing  

    [] 和 Maybe 實作 Functor 時的宣告也不是一個 concrete type，是缺少一個參數的  type constructor that takes one type

    data Either a b = Left a | Right b  

    instance Functor (Either a) where  
        fmap f (Right x) = Right (f x)  
        fmap f (Left x) = Left x  

    而這裡的 Either 需要兩個參數，但在實作時為了確保跟 Functor 一樣需要一個參數，因此需要寫成 (Either a) 只缺一個參數的形式
    根據 Functor 的定義 class Functor f where 套用在 Either 的實作上 f 指的是 (Either a)
    必須吻合 fmpa ::  (a -> b) -> f a -> f b 的定義，為了避免混淆改將代數 (Either a) 改寫成 (Either c) 表示 套用到Functor 的fmap 對應的 type signature 就是
    fmpa ::  (a -> b) -> (Either c) a -> (Either c) b

    
-}

instance MonadPlus2 [] where  
    mzero2 :: [a]
    mzero2 = []  
    mplus2 :: (Monoid a) => [a] -> [a] -> [a]
    mplus2 = (++)  

{-
    instance MonadPlus [] where  這裡也不是一個 concrete type， 這裡的 [] array 缺乏一個參數才能成為 concrete type 
    比如 [Int] [String] [[String]] 這些都才算是 concrete type
    這裡的 mplus = (++) 其實可以寫成 mplus = mappend 
-}

{-
    > mzero2 :: [()]
    []
    > mezro2 :: [String]
    []
    > mzero2 :: [a]
    []
-}

instance MonadPlus2 Maybe where
    mzero2 :: Maybe a
    mzero2 = Nothing
    mplus2 :: (Monoid a) => Maybe a -> Maybe a -> Maybe a  
    Nothing `mplus2` m = m  
    m `mplus2` Nothing = m  
    Just m1 `mplus2` Just m2 = Just (m1 `mappend` m2)

{-
    instance MonadPlus Maybe where  也不是一個 concrete type ， 這裡只有 Maybe 缺乏另一個參數才能成為 concrete type
    例如 Maybe (), Maybe String, Maybe Int
-}

class (Monad m, Alternative m) => MonadPlus3 m where  
    mzero3 :: m a
    mplus3 :: m a -> m a -> m a  

instance MonadPlus3 [] where  
    mzero3 :: [a]
    mzero3 = []  
    mplus3 :: [a] -> [a] -> [a]
    mplus3 = (<|>) 

instance MonadPlus3 Maybe where
    mzero3 :: Maybe a
    mzero3 = Nothing
    mplus3 :: Maybe a -> Maybe a -> Maybe a  
    mplus3 = (<|>) 

{-
    MonadPlus3 使用原始碼中的寫法  限定 m 為 Alternative

    class Applicative f => Alternative f where
        empty :: f a
        (<|>) :: f a -> f a -> f a

    Alternative 至少要實作 empty 跟 (<|>) 還有限定必須是 Applicative，而 Applicative 又依賴 Functor
    其中 empty 是 (<|>) 的 identity value,  identity 的涵義是在特定運算執行後還是本身
    例如 在乘法的運算中 1 就是乘法的 identity value，在加法的運算中 0 就是加法的 identity value

    instance Alternative [] where
        empty = []
        (<|>) = (++)

    instance Alternative Maybe where
        empty = Nothing
        Nothing <|> r = r
        l       <|> _ = l
-}

guard2 :: (MonadPlus2 m) => Bool -> m ()  
guard2 True = return ()
guard2 False = mzero2  

sevensOnly :: [Int]  
sevensOnly = do  
    x <- [1..50]  
    guard ('7' `elem` show x)  
    return x

sevensOnly2 :: [Int]  
sevensOnly2 =  
    [1..50] >>= (\ x->  
    guard ('7' `elem` show x) >>= (\_-> 
    return x))  

type KnightPos = (Int,Int)  
moveKnight :: KnightPos -> [KnightPos]  
moveKnight (c,r) = do  
    (c',r') <- [(c+2,r-1),(c+2,r+1),(c-2,r-1),(c-2,r+1)  
               ,(c+1,r-2),(c+1,r+2),(c-1,r-2),(c-1,r+2)  
               ]  
    guard (c' `elem` [1..8] && r' `elem` [1..8])  
    return (c',r') 

moveKnight2 :: KnightPos -> [KnightPos]  
moveKnight2 (c,r) = filter onBoard  
    [(c+2,r-1),(c+2,r+1),(c-2,r-1),(c-2,r+1)  
    ,(c+1,r-2),(c+1,r+2),(c-1,r-2),(c-1,r+2)  
    ]  
    where onBoard (c,r) = c `elem` [1..8] && r `elem` [1..8]  

in3 :: KnightPos -> [KnightPos]  
in3 start = do   
    first <- moveKnight start  
    second <- moveKnight first  
    moveKnight second  
-- in3 start = return start >>= moveKnight >>= moveKnight >>= moveKnight  


isBigGang :: Int -> (Bool, String)  
isBigGang x = (x > 9, "Compared gang size to 9.")  
    
applyLog :: (a,String) -> (a -> (b,String)) -> (b,String)  
applyLog (x, log) f = let 
    (y, newLog) = f x 
    in (y, log ++ newLog)  

applyLog2 ::(Monoid m) => (a, m) -> (a -> (b, m)) -> (b, m)  
applyLog2 (x, log) f = let 
    (y, newLog) = f x 
    in (y, log `mappend` newLog)  

-- newtype 用法  注意只能接受一個參數
newtype CharList = CharList { getCharList :: [Char] } deriving (Eq, Show)  
-- > ChartList "123"
-- CharList {getCharList = "123"}
-- > getCharList (ChartList "123")
-- "123"

newtype Pair a b = Pair { getPair :: (a, b) } deriving (Eq, Show)  

instance Functor (Pair a) where  
    fmap :: (b -> c) -> Pair a b -> Pair a c
    fmap f (Pair (a, b)) = Pair (a, f b)  
{-
    > Pair (1,2)
    Pair {getPair = (1,2)}
    > fmap (+1) (Pair (1,2))
    Pair {getPair = (1,3)}
    > getPair (Pair (1,2))
    (1,2)
-}

newtype Pair2 b a = Pair2 { getPair2 :: (a, b) } deriving (Eq, Show)  

instance Functor (Pair2 b) where  
    fmap :: (a -> c) -> Pair2 b a -> Pair2 b c 
    fmap f (Pair2 (a, b)) = Pair2 (f a, b)  
{-
    > Pair2 (1,2)
    Pair2 {getPair2 = (1,2)}

    > fmap (+1) (Pair2 (1,2))
    Pair2 {getPair2 = (2,2)}

    > getPair2 (Pair2 (1,2))
    (1,2)
-}

newtype Writer2 w a = Writer2 { runWriter2 :: (a, w) } deriving (Eq, Show) 

instance Functor (Writer2 w) where
    fmap f m =  let
                (a, w) = (runWriter2 m)
                in Writer2 (f a, w)

{-
    http://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Functor.html#t:Functor

    class Functor f where
        fmap :: (a -> b) -> f a -> f b

    Functor 至少要實作 fmap

    > fmap (+1) (Writer2 (0,"Hi"))
    Writer2 {runWriter2 = (1,"Hi")}
-}

instance (Monoid w) => Applicative (Writer2 w) where
    pure a  = Writer2 (a, mempty)
    f <*> v =   let
                (a, w) = (runWriter2 f) 
                (b, w') = (runWriter2 v)
                in Writer2 (a b, w `mappend` w')

{-
    http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Applicative.html#t:Applicative

    class Functor f => Applicative f where
        pure :: a -> f a
        (<*>) :: f (a -> b) -> f a -> f b
        liftA2 :: (a -> b -> c) -> f a -> f b -> f c

    Applicative至少要實作 pure, ((<*>) 或是 liftA2)  
    根據 Applicative 的定義 還需要實作 Functor

    > (Writer2 ((+1),"plus one to ")) <*> (Writer2 (0,"zero"))
    Writer2 {runWriter2 = (1,"plus one to zero")}
-}

instance (Monoid w) => Monad (Writer2 w) where  
    return a = Writer2 (a, mempty)
    Writer2 (a, w) >>= f =  let 
                            Writer2 (b, w') = (f a)
                            in Writer2 (b, w `mappend` w')
{-
    另一種寫法 使用 runWriter2 取得 Writer2 裡面的 tuple 內容

    instance (Monoid w) => Monad (Writer2 w) where  
        return a = Writer2 (a, mempty)
        m >>= f = let 
            (a, w) = runWriter2 m
            (b, w') = runWriter2 (f a)
            in Writer2 (b, w `mappend` w')
-}


{-
    http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#t:Monad

    class Applicative m => Monad m where
        return :: a -> m a  
      
        (>>=) :: m a -> (a -> m b) -> m b  
        (>>) :: m a -> m b -> m b  
        x >> y = x >>= \_ -> y  
      
        fail :: String -> m a  
        fail msg = error msg  
    
    Monad 至少要實作 (>>=)
    因此 若想實作 Monad (Writer2 w) 就必須同時實作其所倚賴的  Applicative
    如果有實作 fail 的話，當程式出錯時還可以進行其他處理


    > (Writer2 (0, "zero")) >>= (\ x-> Writer2 (x+1," ," ++ show x ++ "+1=" ++ show (x+1)))
    Writer2 {runWriter2 = (1,"zero ,0+1=1")}

    Monad 定義不是一個 concrete type 還需要一個參數才能變成 concrete type

    > return 3 :: Writer2 String Int
    Writer2 {runWriter2 = (3,"")}
    > runWriter2 (return 3 :: Writer2 String Int)
    (3,"")
    > runWriter2 (return 3 :: Writer2 (Sum Int) Int)  
    (3,Sum {getSum = 0})
    > runWriter2 (return 3 :: Writer2 (Product Int) Int)
    (3,Product {getProduct = 1})

    The Writer instance doesn't feature an implementation for fail, 
    so if a pattern match fails in do notation, error is called. 
-}

tell2 w = Writer2 ((), w)
      
logNumber :: Int -> Writer2 [String] Int  
logNumber x = Writer2 (x, ["Got number: " ++ show x])  
  
multWithLog :: Writer2 [String] Int
multWithLog = do  
    a <- logNumber 3  
    b <- logNumber 5
    tell2 ["Gonna multiply these two"]
    return (a * b)  

multWithLog2 :: Writer2 [String] Int
multWithLog2 =  
    logNumber 3 >>= (\ a -> 
    logNumber 5 >>= (\ b ->
    -- tell2 這裡丟進去的參數是 () 但是沒有被用到 因此用 _ 代表 ignore
    tell2 ["Gonna multiply these two"] >>= (\ _->
    Writer2 ((a * b), mempty)  
    )))

{-
    tell2 ["Gonna multiply these two"] 其實是 Writer2 ((),["Gonna multiply these two"])
    將 () 丟入變成 參數後取得 Writer2 ((a * b), []) 帶入後變成
    Writer2 ((a * b), ["Gonna multiply these two"] `mappend` [] ) 變成
    Writer2 ((a * b), ["Gonna multiply these two"])

    之後 logNumber 5 其實是 Writer2 (5, ["Got number: 5"]) >>= (\b -> Writer2 ((a * b), ["Gonna multiply these two"])) 帶入後變成
    Writer2 ((a * 5), ["Got number: 5"]  `mappend` ["Gonna multiply these two"])
    Writer2 ((a * 5), ["Got number: 5", "Gonna multiply these two"])

    之後 logNumber 3 其實是 Writer2 (3, ["Got number: 3"]) >>= (\a -> Writer2 ((a * 5), ["Got number: 5", "Gonna multiply these two"])) 結果為
    Writer2 ((3 * 5), ["Got number: 3"] `mappend` ["Got number: 5", "Gonna multiply these two"]))
    Writer2 (15, ["Got number: 3", "Got number: 5", "Gonna multiply these two"]))

    觀察後發現 其為 右結合優先  因此效率比較高 ++ 定義為 infixr  代表infix 中序運算子 r 是右結合律
    ["Got number: 3"] ++ (["Got number: 5"] ++ (["Gonna multiply these two"]++[]))

    > multWithLog
    Writer2 {runWriter2 = (15,["Got number: 3","Got number: 5","Gonna multiply these two"])}

    > multWithLog2
    Writer2 {runWriter2 = (15,["Got number: 3","Got number: 5","Gonna multiply these two"])}
-}

gcd' :: Int -> Int -> Int  
gcd' a b   
    | b == 0    = a  
    | otherwise = gcd' b (a `mod` b)  

{-
    > gcd' 8 2
    2
-}

gcd2 :: Int -> Int -> Writer2 [String] Int  
gcd2 a b 
    | b == 0    = do
        tell2 ["Finished with " ++ show a]
        return a  
    | otherwise = do
        tell2 [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)]
        gcd2 b (a `mod` b)

gcd3 :: Int -> Int -> Writer2 [String] Int  
gcd3 a b 
    | b == 0    = 
        tell2 ["Finished with " ++ show a] >>= (\ _->
        return a)
    | otherwise =
        tell2 [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)] >>= (\ _->
        gcd3 b (a `mod` b))


gcdReverse :: Int -> Int -> Writer2 [String] Int  
gcdReverse a b  
    | b == 0 = do  
        tell2 ["Finished with " ++ show a]
        return a  
    | otherwise = do  
        result <- gcdReverse b (a `mod` b)  
        tell2 [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)]  
        return result

gcdReverse2 :: Int -> Int -> Writer2 [String] Int  
gcdReverse2 a b  
    | b == 0 =
        tell2 ["Finished with " ++ show a] >>= (\ _->
        return a) 
    | otherwise = 
        gcdReverse b (a `mod` b) >>= (\ result ->
        tell2 [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)] >>= (\_ ->
        return result))

{-
    > gcd3 8 2
    Writer2 {runWriter2 = (2,["8 mod 2 = 0","Finished with 2"])}
    > gcdReverse 8 2
    Writer2 {runWriter2 = (2,["Finished with 2","8 mod 2 = 0"])}

   
    根據 Writer2 的定義  越晚加入的字串 放越後面 可以看出gcd3 的執行順序是先 (["8 mod 2 = 0"] ++ ( ["Finished with 2"] ++ [] ))
    [] 是由 return a 所產生的 Writer2 [] a 的結果 , 其執行順序剛好是 右結合律  因此比較有效率

    gcdReverse 執行順序剛好返了過來是左邊會先運算，而右邊最後得到因此比較沒有效率，跟結合律相反
    ( ["Finished with 2"] ++ [] ) ++ ["8 mod 2 = 0"]
-}

newtype DiffList a = DiffList { getDiffList :: [a] -> [a] }
-- 根據觀察 DiffList 是一個 Function 傳入[a] 回傳[a] 的 function
toDiffList :: [a] -> DiffList a  
toDiffList xs = DiffList (xs++)  
-- toDiffList 將單純的 [a] 陣列資料轉換成 toDiffList
fromDiffList :: DiffList a -> [a]  
fromDiffList (DiffList f) = f []
-- fromDiffList 將本來的 DiffList 轉回原本的陣列資料 把空陣列傳入 f 就可以得到原本在 Function 裡面的 陣列資料了

instance Semigroup (DiffList a) where
    (DiffList f) <> (DiffList g) = DiffList (\xs -> f (g xs))   

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

finalCountDown :: Int -> Writer2 (DiffList String) ()  
finalCountDown 0 = do  
    tell2 (toDiffList ["0"])  
finalCountDown x = do  
    finalCountDown (x-1)  
    tell2 (toDiffList [show x])

finalCountDownSlow :: Int -> Writer2 [String] ()  
finalCountDownSlow 0 = do  
    tell2 (["0"])  
finalCountDownSlow x = do  
    finalCountDownSlow (x-1)  
    tell2 ([show x])
    
finalCountDown2 :: Int -> Writer2 (DiffList String) ()  
finalCountDown2 0 = tell2 (toDiffList ["0"])  
finalCountDown2 x = 
    (finalCountDown (x-1)) >>= (\ _ ->
    tell2 (toDiffList [show x]))

{-
    -- 使用 DiffList 比較有效率
    > mapM_ putStrLn . fromDiffList . snd . runWriter2 $ finalCountDown 500000  

    -- 比較沒有效率 直接使用 [String]
    > mapM_ putStrLn . snd . runWriter2 $ finalCountDownSlow 500000  
    
    -- ctrl + C 可中斷執行
-}

{-
    ($) 是單純的 Function 帶入隨後一個參數
    ($) :: (a -> b) -> a -> b

    ---------------

    class Functor f where
        fmap :: (a -> b) -> f a -> f b
    (<$>) 是 fmap 的 infix 型式  是一的
    (<$>) :: Functor f => (a -> b) -> f a -> f b
     fmap :: Functor f => (a -> b) -> f a -> f b
    將 (a -> b) function apply 到 f a 中的 a 得到 b 後，再包裝成 f b
    Functor 的定義是個 Type Constructor 不是一個 concrete type 可以從fmap結果可以看到 
    
    instance Functor ((->) r) where
        fmap = (.)
    (.) :: (b -> c) -> (a -> b) -> a -> c
    (.) f g = \x -> f (g x)
    ((->) r) 是function 定義，而Function實作的 Functor 其實是 composite

    ---------------

    class (Functor f) => Applicative f where  
        pure :: a -> f a  
        (<*>) :: f (a -> b) -> f a -> f b  
    
    Applicative 是強化版的 fmap 將 f (a -> b) 的 (a -> b) function apply 到 f a 的 a 得到 b 後，再包裝成 f b

    >  (+1)  <$> [1,2,3]
    [2,3,4]

    > [(+1)] <*> [1,2,3]
    [2,3,4]

    > [(+1), ((-)1)] <*> [1,2,3]
    [2,3,4,0,-1,-2]

    const :: a -> b -> a
    const x _ =  x

    instance Applicative ((->) a) where
        pure = const
        (<*>) f g x = f x (g x)
        liftA2 q f g x = q (f x) (g x)

    ---------------

    class Applicative m => Monad m where
        -- | Sequentially compose two actions, passing any value produced
        -- by the first as an argument to the second.
        (>>=)       :: forall a b. m a -> (a -> m b) -> m b

    Monad 的 (>>=) bind 定義為  將 function (a -> m b) 套用在 m a 中的 a上，然後取得 m b 的結果 
    (often called .bind() or .chain()) flatMap
    lift (aka of/unit) 指的是 return

    So, if you define .of() and .chain()/.join() for your monad, you can infer the definition of .map().
    The lift is the factory/constructor and/or constructor.of() method. In category theory, it's called “unit”. 
    All it does is lift the type into the context of the monad. It turns an a into a Monad of a.

    In Haskell, it’s (very confusingly) called return, 
    which gets extremely confusing when you try to talk about it out-loud because nearly everyone confuses it with function returns. 
    I almost always call it "lift" or "type lift" in prose, and .of() in code.

    That flattening process (without the map in .chain()) is usually called flatten() or join(). 
    Frequently (but not always), flatten()/join() is omitted completely 
    because it's built into .chain()/.flatMap().

    The same holds true for Kleisli composition. 
    You just have to read it backwards. When you see the composition operator (chain), think after:

    instance Monad ((->) r) where  
        return x = \_ -> x  
        h >>= f = \w -> f (h w) w  
    
    instance Monad ((->) r) where
        f >>= k = \ r -> k (f r) r
    
-}

addStuff :: Int -> Int  
addStuff = do  
    a <- (*2)  
    b <- (+10)  
    return (a+b)

addStuff' :: Int -> Int  
addStuff' x = let  
    a = (*2) x  
    b = (+10) x  
    in a+b  

addStuff2 :: Int -> Int  
addStuff2 = 
    (*2) >>= (\ a -> 
    (+10) >>= (\ b -> 
    return (a+b)))

addStuff3 :: Int -> Int  
addStuff3 = 
    (*2) >>= (\ a -> 
        (\r -> 
            -- k (f r) r
            (\b -> 
                -- return 根據 type signature 得知是 (Int -> Int) function 因此包裝成 function 的形式
                (\_ -> (a + b))
            ) ((+10) r) r
        )
    )

addStuff4 :: Int -> Int  
addStuff4 = 
    (\r2 -> 
        -- k (f r) r
        (\ a -> 
            (\r -> 
                (\b -> 
                    (\_ -> (a + b))
                ) ((+10) r) r
            )
        ) ((*2) r2) r2
    )

{-
    > addStuff4 3
    19
    
    3 丟進去後 r2 為3
    a = ((*3) 2) = 6

    r 接收 r2 的結果也為 3

    b = ((+10) 3) = 13

    _ 接收 r 其結果回傳 a + b = 6 + 13 = 19

-}


{-

We'll say that a stateful computation is a function that takes some state and returns a value along with some new state. 

    s -> (a,s)  

-}
type Stack = [Int]  
pop :: Stack -> (Int,Stack)  
pop (x:xs) = (x,xs)  
push :: Int -> Stack -> ((),Stack)  
push a xs = ((),a:xs)  

stackManip :: Stack -> (Int, Stack)  
stackManip stack = let  
    ((),newStack1) = push 3 stack  
    (a ,newStack2) = pop newStack1  
    in pop newStack2  
{-
    > stackManip [5,8,2,1]
    (5,[8,2,1])
-}


newtype State2 s a = State2 { runState2 :: s -> (a,s) }  
{-
    http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.ST.html#ST
    A State s a is a stateful computation that manipulates a state of type s and has a result of type a. 
    A computation of type ST s a transforms an internal state indexed by s, and returns a value of type a. 

    注意! State 是一個 (->) r 的 function 結構!!

    第一個 s 是一個外部輸入的狀態，執行後會得到一組 新的狀態s 跟 運算 result a
    根據 Monad 的定義 可以透過 bind (>>=) 來結合兩個 相同狀態 卻不同result a 的運算
-}
instance Functor (State2 s) where
    fmap :: (a -> b) -> State2 s a -> State2 s b 
    fmap f (State2 m) = State2 (\ p -> 
        let
        -- 透過將 State2 s a  裡存放的 function apply 到參數p 上  得到原本儲存於 State2 s a 的 (a, s)
        (r, new_s) = m p
        -- 之後再將 function f apply 到 a 上得到 b 則為 State2 s b 
        in (f r, new_s)
        )

{-
    > let a1 = pure 1 :: State2 Int Int
    > let a1Minus1 = fmap ((-)1) a1
    > runState2 a1Minus1 $ 5
    (0,5)
    -- 外部的 state 是 5 沒有改變
-}

ap2 :: (Monad m) => m (a -> b) -> m a -> m b
ap2 mf ma = do 
    f <- mf
    a <- ma
    return (f a) 
-- 注意這裡的 retrun 是包裝成 monad m

ap2' :: (Monad m) => m (a -> b) -> m a -> m b
ap2' mf ma =
    mf >>= (\ f ->
    ma >>= (\ a ->
    return (f a)))
-- 注意這裡的 retrun 是包裝成 monad m

instance Applicative (State2 s) where
    pure :: a -> State2 s a 
    pure x = State2 (\s -> (x, s))
    (<*>) :: State2 s (a -> b) -> State2 s a -> State2 s b 
    (<*>) = ap2

{-
    > let aPlus1 = pure (+1) :: State2 Int (Int -> Int)
    > let a2 = pure 2 :: State2 Int Int
    > runState2 (aPlus1 <*> a2) $ 100
    (3,100)
    -- 外部的 state 是 100 沒有改變
-}

instance Monad (State2 s) where  
    return :: a -> State2 s a 
    return a = State2 $ \s -> (a,s)  
    (>>=) :: State2 s a -> (a -> State2 s b) -> State2 s b 
    ssa >>= a_ssb = 
        State2 $ (\s -> 
        let sa = runState2 ssa
            (a, newState) = sa s  
            (State2 sb) = a_ssb a  
        in  sb newState)
{-
    首先將 sa function (s ->(a,s)) apply to 外部的 state s 上得到 (a, newState)
    之後將 a_sb function apply to a 上 得到 State2 裡的 sb function (s ->(b, s)) 
    最後將 sb function apply to newState 得到 (b, newState)

    從Type Signatrure 觀察得知 s 雖然 type 沒有改變，但是s內容已變成了 State2 s a 所改變了 
-}

pop2 :: State2 Stack Int  
pop2 = State2 $ (\ (sHead:sTail) -> (sHead, sTail) )  
-- pop2 外部輸入 state 將第一個 element 取出放在a的位置 隨後跟著新的 state s

push2 :: Int -> State2 Stack ()  
push2 a = State2 $ (\ s -> ((), a:s) )  
-- push2 則將新的輸入 a append 到state當中 ，在a的位置設定為 ()

{-
    pop2 的定義為 State2 Stack Int 是一個 concrete type
    但本質上一個包裝 function 的 box ，而 function 本身也能看成是一個 box
    使用時要先解開 State2 這層包裝才能取得裡面的 function apply 到外部的 State s上才能得到結果 
    
    push2 輸入一個Int參數 之後回傳 State2 Stack ()，只要外部State s輸入後，就會將 a 給加上去  
-}

stackManip2 :: State2 Stack Int  
stackManip2 = do  
    push2 3  
    a <- pop2  
    pop2  
{-
    > runState2 stackManip2 [5,8,2,1]
    (5,[8,2,1])
-}

stackManip3 :: State2 Stack Int  
stackManip3 =   
    push2 3 >>= (\ _-> 
    pop2 >>= (\ a -> 
    pop2 )) 
{-
    > runState2 stackManip3 [1,2,3]
    (1,[2,3])
-}

stackManip4 :: State2 Stack Int  
stackManip4 =  
    push2 3 >>= (\ _-> 
        -- pop2 >>= (\ a -> pop2 )
        State2 (\ s -> 
            let
                sa = runState2 pop2
                (a, newState) = sa s
                (State2 sb)   = (\a -> pop2) a
            in sb newState
        )
    ) 
{-
    > runState2 stackManip4 [1,2,3]
    (1,[2,3])
-}

stackManip5 :: State2 Stack Int  
stackManip5 =  
    State2 (\ s2 -> 
        let sa = runState2 (push2 3)
            (a, newState)   = sa s2
            -- ((), 3:s2) 其中s是外部的state  type為 Stack, 其 newStaet為 3:s2 !注意這裡是 Stack
            (State2 sb)     = 
                (\ _-> 
                    -- pop2 >>= (\ a -> pop2 )
                    State2 (\ s -> 
                        let sa = runState2 pop2
                            (a, newState) = sa s
                            (State2 sb)   = (\a -> pop2) a
                        in sb newState
                    )
                ) a
                {-
                    此時將 a = () 帶入, _ 其實就是 a = ()
                    其後可以直接觀察出(State2 sb) 對應的就是裡面的 \_-> 所回傳的
                    State2 (\ s -> 
                        let sa = runState2 pop2
                            (a, newState) = sa s
                            (State2 sb)   = (\a -> pop2) a
                        in sb newState
                    )
                -}
        in sb newState
        {-
            sb 帶入 newState 也就是
            (\ s -> 
                -- s 等於 3:s2
                let sa = runState2 pop2
                    (a, newState) = sa s
                    -- pop2 執行後 3:s2 變成 s2，把 3 pop出來 
                    (State2 sb)   = (\a -> pop2) a
                in sb newState
                -- 最後又將 s2 pop 一次，因此將s2拆成 s2x:s2xs 則結果為 (s2x, [s2xs]) 
            ) 3:s2
        -}
    )
{-
    > runState2 stackManip5 [1,2,3]
    (1,[2,3])
-}


stackStuff :: State2 Stack ()  
stackStuff = do  
    a <- pop2  
    -- (a -> State s b) 這裡充分暗示了 result a 如何去影響 State (s -> (b, s)) 的也就是 State s b
    if a == 5 then 
        push2 555  
    else 
        do 
        push2 333  
        push2 888
{-
    else 底下的 do 是因為連結兩個指令，若只有一個指令不需要用到 do 

    > runState2 stackStuff [5]
    ((),[555])
    > runState2 stackStuff [2,1]
    ((),[888,333,1])

-}

moreStack :: State2 Stack ()  
moreStack = do  
    a <- stackManip2
    if a == 6 then stackStuff  
    else return ()

{-
    > runState2 moreStack [6,1]
    ((),[888,333])
    > runState2 moreStack [6,5]
    ((),[555])
    > runState2 moreStack [7,5,4]
    ((),[5,4])
    > runState2 moreStack [1,5,4]
    ((),[5,4])

-}

get2 = State2 $ \s -> (s,s)  
put2 newState = State2 $ \s -> ((),newState)  

stackyStack :: State2 Stack ()  
stackyStack = do  
    stackNow <- get2  
    if stackNow == [1,2,3] then 
        put2 [8,3,1]  
    else 
        put2 [9,2,1]  
{-
    > runState2 stackyStack [1,2,3]
    ((),[8,3,1])
    > runState2 stackyStack [1]
    ((),[9,2,1])
    > runState2 stackyStack [1,2,3,4]
    ((),[9,2,1])
-}

{-

(>>=) :: State s a -> (a -> State s b) -> State s b  

See how the type of the state s stays the same but the type of the result can change from a to b? 
This means that we can glue together several stateful computations whose results are of different types 
but the type of the state has to stay the same. Now why is that? 
Well, for instance, for Maybe, >>= has this type:

(>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b  

It makes sense that the monad itself, Maybe, doesn't change. It wouldn't make sense to use >>= between two different monads. 
Well, for the state monad, the monad is actually State s, 
so if that s was different, we'd be using >>= between two different monads. 

-}

{-

 An Either e a value can either be a Right value, signifying the right answer and a success, 
 or it can be a Left value, signifying failure. 

    instance (Error e) => Monad (Either e) where  
        return x = Right x   
        Right x >>= f = f x  
        Left err >>= f = Left err  
        fail msg = Left (strMsg msg)  

    > Right 3 >>= \x -> return (x + 100)  
    Right 103  
    > Right 3 >>= \x -> return (x + 100) :: Either String Int  
    Right 103 
    
-}


{-
    liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
    liftM f m1  = do { x1 <- m1; return (f x1) }

    class Functor f where  
        fmap :: (a -> b) -> f a -> f b
-}

liftM' :: (Monad m) => (a1 -> r) -> m a1 -> m r
liftM' f m1 =   m1 >>= (\x1 -> return (f x1)) 

{-
    > runState2 (pop2 >>= (\ x1 -> return ((+100) x1))) [1,2,3]
    (101,[2,3])

    根據定義 return ((+100) x1) 這裡對應的是 (State2 sb) = a_ssb a  
    因此必須符合 pop2 的定義，因此結果為 State2 Stack Int 而對應 return ((+100) x1) 就是 State2 (\ s -> (+100) x1, s))
    最後其結果就是 (\ s -> (+100) x1, s)) newState 等於 ((+100) x1, newState)

    (>>=) :: State2 s a -> (a -> State2 s b) -> State2 s b 
    ssa >>= a_ssb = 
    State2 $ (\s -> 
    let sa = runState2 ssa
        (a, newState) = sa s  
        (State2 sb) = a_ssb a  
    in  sb newState)



    > (+) <$> Just 3 <*> Just 5  
    Just 8

    其中 <$> 是 fmap 而 fmap的特性是保持其外部容器 因此其結果必定為 Just 但其內容套用在 (+) function 上則變成
    Just ((+) 3)
    其形態為 Num a => Maybe (a -> a)， Maybe裡面包裝了一個 function
    而 <*> Applicative Functor 所做的實情就是將 Just 5 包裝中的 5 帶入到 Just ((+)3) 包裝的 ((+)3) function 中又重新包裝 Just
    Just ( ((+)3) 5 ) 因此等於 Just 8

    class Functor f => Applicative f where
        pure :: a -> f a

        (<*>) :: f (a -> b) -> f a -> f b
        (<*>) = liftA2 id

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

        Just f <*> m       = fmap f m
        Nothing <*> _m      = Nothing

        liftA2 f (Just x) (Just y) = Just (f x y)
        liftA2 _ _ _ = Nothing

    觀察後發現 <*> 跟 liftA2可以互相轉換，因此只要實作其中一個就好

    (<*>) :: (Applicative f) => f (a -> b) -> f a -> f b  
    So it's kind of like fmap, only the function itself is in a context. 

    ap :: (Monad m) => m (a -> b) -> m a -> m b  
    ap mf m = do  
        f <- mf  
        x <- m  
        return (f x) 

The ap function is basically <*>, only it has a Monad constraint instead of an Applicative one.

In fact, many times when a type is found to be a monad, people first write up a Monad instance and then make an Applicative instance by 
just saying that pure is return and <*> is ap. Similarly, if you already have a Monad instance for something, 
you can give it a Functor instance just saying that fmap is liftM. 


The liftA2 function is a convenience function for applying a function between two applicative values. It's defined simply like so: 

    liftA2 :: (Applicative f) => (a -> b -> c) -> f a -> f b -> f c  
    liftA2 f x y = f <$> x <*> y  

    從式子中可以推斷 f <$> x 代表 fmap f x 根據 fmap :: (a -> b) -> f a -> f b  可以推斷是 其結果必然為 f b 因此推斷結果是  (Applicative f) => f (b -> c)
    而 根據式子就是執行 <*> y  根據  (<*>) :: f (a -> b) -> f a -> f b  其對應結果就是 (Applicative f) => f c

The liftM2 function does the same thing, only it has a Monad constraint.


    join :: (Monad m) => m (m a) -> m a  
    join x = x >>= id

So it takes a monadic value within a monadic value and gives us just a monadic value, so it sort of flattens it. 
Here it is with some Maybe values: 

    > join (Just (Just 9))
    Just 9

    > join (Just Nothing)
    Nothing

    > join Nothing
    Nothing

    > join [[1,2,3],[4,5,6]]  
    [1,2,3,4,5,6]

    > runWriter2 $ join (Writer2 (Writer2 (1,"aaa"),"bbb"))
    (1,"bbbaaa")


    >Writer2 (Writer2 (1,"aaa"),"bbb") >>= id
    Writer2 {runWriter2 = (1,"bbbaaa")}

    > join (Right (Right 9)) :: Either String Int  
    Right 9  
    > join (Right (Left "error")) :: Either String Int  
    Left "error"  
    > join (Left "error") :: Either String Int  
    Left "error"  

    Perhaps the most interesting thing about join is that for every monad, 
    feeding a monadic value to a function with >>= is the same thing as just mapping that 
    function over the value and then using join to flatten the resulting nested monadic value! 
    In other words, m >>= f is always the same thing as join (fmap f m)! 

-}

keepSmall :: Int -> Writer2 [String] Bool  
keepSmall x  
    | x < 4 = do  
        tell2 ["Keeping " ++ show x]  
        return True  
    | otherwise = do  
        tell2 [show x ++ " is too large, throwing it away"]  
        return False  

{-

    class Functor f => Applicative f where
        liftA2 :: (a -> b -> c) -> f a -> f b -> f c
        liftA2 f x = (<*>) (fmap f x)

    liftA2 重定義來看 fmap f x 對應的是 fmap (a -> b -> c) (f a) 根據 Functor 定義結果為 f (b -> c)
    之後套用 (<*>) f (b -> c) 若再補上參數 f b 則結果會變成將各自的context取出後套用作後再包裝成 f 因此
    f ((b -> c) b) 等同於 f c

    class Foldable t where
        foldr :: (a -> b -> b) -> b -> t a -> b
    
        foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)
        foldr f z [x1, x2, ..., xn] == f x1 (f x2 ... (f xn z))


    b 是結果，也是一開始的初始值，再者每次將(a->b->b) function 套用到 a 時，b也會被套用，因此得到新的b    


    filterM          :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
    filterM p        = foldr    (\ x -> 
                                    liftA2 
                                    (\ flg -> 
                                        if flg then 
                                            (x:) 
                                        else 
                                            id
                                    ) 
                                    (p x)
                                ) 
                                (pure [])

    filterM 的定義為 p 為 (a -> m Bool) predicate function
    (pure []) 是對應到 foldr 初始的 b 對應其結果 m []
    (p x) 對應的是 filterM 的 ((a -> m Bool) a) 其結果為 m Bool
    flg 對應的是 m Bool 中的 Bool 其結果為  (x:) 或 (id) 其中一個，都是需要一個參數b的的function (b -> b) 因為 liftA2 的包裝變成 m (b -> b)
    其結果 foldr 會在每次套用 a 時得到的 m (b -> b) ，再將 m (b -> b) 套用在初始的 m [] 上隨後複寫初始值 m b
    m (b -> b) <*> (pure [])
    而其 m b 對應 filterM 的 m [a]

    > fst $ runWriter2 $ filterM keepSmall [9,1,5,2,10,3]
    [1,2,3]

    mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () 
    putStrLn :: String -> IO () 

    > mapM_ putStrLn $ snd $ runWriter2 $ filterM keepSmall [9,1,5,2,10,3]
    9 is too large, throwing it away
    Keeping 1
    5 is too large, throwing it away
    Keeping 2
    10 is too large, throwing it away
    Keeping 3

-}

powerset :: [a] -> [[a]]  
powerset xs = filterM (\x -> [True, False]) xs  

{-
    > powerset [1,2,3]
    [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]

    > (<*>) [(1:), id] ((<*>) [(2:), id] ((<*>) [(3:), id] (pure [])))
    [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]
    > [(1:), id] <*> ( [(2:), id] <*> ( [(3:), id] <*> (pure []) ))
    [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]
    > [(1:), id] <*> ( [(2:), id] <*> ( [(3:), id] <*> [[]] ))
    [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]


    [True, False] 對應 filterM 定義中的 (p x) 的結果也就是 m Bool 在此的 Monad m 是指 Array []

    liftA2 根據 flg bool回傳 (x:) 或 id 其中一個 此時 (p x) 是 m bool ，m為[]， [True, False]
    根據 liftA2 定義 (<*>) (fmap    (\ flg -> 
                                    if flg then 
                                        (x:) 
                                    else 
                                        id
                                    )  
                                    [True, False] )  

    其 liftA2的結果為 (<*>) [(x:), id]
    根據從foldr知道是從右邊開始依序丟入因此得到 (<*>) [(1:), id] ((<*>) [(2:), id] ((<*>) [(3:), id] (pure [])))
    重新整理為 [(1:), id] <*> ( [(2:), id] <*> ( [(3:), id] <*> (pure []) ))
    其中 pure [] 為 [[]]

    其中[1,2,3]分別的到  [[True, False], [True, False], [True, False]] 使用 list comprehension 去理解
    也就是三層迴圈 
    [True, True, True]      [1,2,3]
    [True, True, False]     [1,2]
    [True, False, True]     [1,3]
    [True, False, False]    [1]
    [False, True, True]     [2,3]
    [False, True, False]    [2]
    [False, False, True]    [3]
    [False, False, False]   []
-}

binSmalls :: Int -> Int -> Maybe Int 
binSmalls acc x  
    | x > 9     = Nothing  
    | otherwise = Just (acc + x)  

foldlM2 :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
foldlM2 f z0 xs = (foldr f' return xs) z0
                  where f' x k z = f z x >>= k

foldlM3 :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
foldlM3 f b0 ta = (foldr f' return ta) b0
                where f' a b bb = f bb a >>= b

foldlM4 :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
foldlM4 f b0 ta = (foldr f' return ta) b0
                where f' a b = (\ bb -> f bb a >>= b )

{-
    foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b
    foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b
    
    foldr :: Foldable t => (a -> b -> b) ->     b ->        t a     -> b
                           f'                   return      ta      (* -> *)
    
    對應 foldr 中的 b 是 retrun 而 type signature 為 return :: Monad m => a -> m a ， 是帶1個參數的 function
    因此 foldr 的輸出結果 b 也必然也就相同的 type signature 也是帶1個參數的 function
    而 return 對應的是 foldr 中的 b 為了區別將 return 中的 a 改寫為 bb 
    因此改寫為 return :: Monad m => bb -> m bb 

    foldr :: Foldable t => (a -> b -> b) ->     b               ->  t a     ->  b
                           f'                   (bb -> m bb)        t a         (bb -> m bb)

    而 f'所接受的參數 a 跟 帶1個參數 function b (bb -> m bb)，f' 輸出結果為 帶1個參數 function (bb -> m bb)
    foldlM4 中 f' 的寫法
                           f' :: Monad m => ( a -> (bb -> m bb) -> (bb -> m bb))

    而 foldlM3 中 f' 把 bb 從輸出結果拉到左邊來變成輸入參數之一， 而輸出結果變為 m bb
    foldlM3 中 f' 的寫法
                           f' :: Monad m => ( a -> (bb -> m bb) ->  bb -> m bb )

    ta 有 n 個 分別是 a1 a2 ... a(n-2) a(n-1) an 
    
    假設: ta 有 3 個 分別是 a1 a2 a3 進行模擬

    第 1 次執行 f' a 為 a3, b 為 return , 
    f' a3 return bb = f bb a3 >>= return

    而 bb 為 b function 中的輸入參數，其結果為
    (\ bb -> f bb a3 >>= return) :: (bb -> m bb)

    第 2 次執行 f' a 為 a2, b 為 第 1 次執行 f' 的結果 , 
    f' a2 b bb = f bb a2 >>= b
    (\ bb -> f bb a2 >>= (\ bb -> f bb a3 >>= return) ) :: (bb -> m bb)

    第 3 次執行 f' a 為 a1, b 為 第 2 次執行 f' 的結果 , 
    f' a1 b bb = f bb a1 >>= b
    (\ bb -> f bb a1 >>= (\ bb -> f bb a2 >>= (\ bb -> f bb a3 >>= return) ) )  :: (bb -> m bb)

    從上面可以看出來 b0 就是當作最一開始輸入的參數 bb 接著一層接著一層執行下去，同時也符合 foldlM 的執行順序 

    > foldlM2 binSmalls 0 [1,2,3,4] 
    Just 10
    > foldlM3 binSmalls 0 [1,2,3,4] 
    Just 10
    > foldlM4 binSmalls 0 [1,2,3,4] 
    Just 10

    foldM f a1 [x1, x2, ..., xm]
    ==
    do
    a2 <- f a1 x1
    a3 <- f a2 x2
    ...
    f am xm

    > foldM binSmalls 0 [2,8,3,1]  
    Just 14 

    > foldM binSmalls 0 [2,11,3,1] 
    Nothing    
-}

{-
    https://stackoverflow.com/a/27906939/1584100

    If we had a function

    g :: x -> y -> z -> w

    With

    foldr :: (a -> b -> b) -> b -> [a] -> b

    Where we want to pass g to foldr, then (a -> b -> b) ~ (x -> y -> z -> w) (where ~ is type equality). 
    Since -> is right associative, this means we can write g's signature as

    x -> y -> (z -> w)

    and its meaning is the same. Now we've produced a function of two parameters that returns a function of one parameter. 
    In order to unify this with the type a -> b -> b, we just need to line up the arguments:

    a ->   |  x ->
    b ->   |  y -> 
    b      |  (z -> w)

    This means that b ~ z -> w, so y ~ b ~ z -> w and a ~ x so g's type really has to be

    g :: x -> (z -> w) -> (z -> w)

    implying

    foldr g :: (z -> w) -> [x] -> (z -> w)

    This is certainly not impossible, although more unlikely. Our accumulator is a function instead, and to me this begs to be demonstrated with DiffLists:

    type DiffList a = [a] -> [a]

    append :: a -> DiffList a -> DiffList a
    append x dl = \xs -> dl xs ++ [x]

    reverse' :: [a] -> [a]
    reverse' xs = foldr append (const []) xs $ []

    Note that foldr append (const []) xs returns a function which we apply to [] to reverse a list. 
    In this case we've given an alias to functions of the type [a] -> [a] called DiffList, 
    but it's really no different than having written

    append :: a -> ([a] -> [a]) -> [a] -> [a]

    which is a function of 3 arguments.
-}     

solveRPN :: String -> Double  
solveRPN = head . foldl foldingFunction [] . words 

foldingFunction :: [Double] -> String -> [Double]  
foldingFunction (x:y:ys) "*" = (x * y):ys  
foldingFunction (x:y:ys) "+" = (x + y):ys  
foldingFunction (x:y:ys) "-" = (y - x):ys  
foldingFunction xs numberString = read numberString:xs 

{-
    > read "1.1" :: Double
    1.1
    > read "hi" :: Double
    *** Exception: Prelude.read: no parse
    
    > reads "1.1" :: [(Double, String)]
    [(1.1,"")]
    > reads "Hi" :: [(Double, String)]
    []

-}

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

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

solveRPN2 :: String -> Maybe Double  
solveRPN2 st = do  
    [result] <- foldM foldingFunction2 [] (words st)  
    return result  
{-
    -- | Promote a function to a monad.
    liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
    liftM f m1 = do { x1 <- m1; return (f x1) }

    liftM 嘗試將 (readMaybe numberString) 的結果 Maybe a 中的 a 取出並將 (:xs) apply to a 上，其結果再用 m 包裝回去也就是 Maybe


-}

patternMatch :: Maybe Int   
patternMatch = do  
    [result] <- Just [1]
    return result

patternMatchFails :: Maybe Int    
patternMatchFails = do  
    [result] <- Just [1,2]
    return result

{-
    > patternMatchFails
    Nothing

    > patternMatch
    Just 1

    當使用do時其實就是使用 Monad 的 >>= 也就是 bind function
    而Maybe定義了 當 fail 產生的時候則回傳 Nothing

    instance  Monad Maybe  where
        (Just x) >>= k      = k x
        Nothing  >>= _      = Nothing

        (>>) = (*>)

        fail _              = Nothing
 
-}

-- readEither :: (Read a) => String -> Either String a  
readEither st = case reads st of [(x,"")] -> Right x
                                 _ -> Left st  


{-
Composing monadic functions

When we were learning about the monad laws, we said that the <=< function is just like composition, 
only instead of working for normal functions like a -> b, it works for monadic functions like a -> m b. 

    > let f = (+1) . (*100)  
    > f 4  
    401  
    > let g = (\x -> return (x+1)) <=< (\x -> return (x*100))  
    > Just 4 >>= g  
    Just 401  

In this example we first composed two normal functions, applied the resulting function to 4 and then 
we composed two monadic functions and fed Just 4 to the resulting function with >>=. 

    > let f = foldr (.) id [(+2),(*100),(+1)]  
    > f 1  
    202  

The function f takes a number and then adds 1 to it, multiplies the result by 100 and then adds 1 to that. 
Anyway, we can compose monadic functions in the same way, only instead normal composition we use <=< and instead of id we use return. 
We don't have to use a foldM over a foldr or anything because the <=< function makes sure that composition happens in a monadic fashion.    
    
    > let f = foldr (<=<) return [ (\ x ->return (x+2)), (\ x -> return (x*100)), (\ x -> return (x+1))] 
    > f 1
    202
    > Just 1 >>= f
    Just 202

-}


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

{-
Alright. Is this a functor? Well, the list is a functor, so this should probably be a functor as well, 
because we just added some stuff to the list. When we map a function over a list, we apply it to each element. 

Here, we'll apply it to each element as well, only we'll leave the probabilities as they are. Let's make an instance: 
-}

instance Functor Prob where  
    fmap f (Prob xs) = Prob $ map (\(x,p) -> (f x,p)) xs  
{-
    (Prob xs) 的 pattern matching 使得可以直接extract 裡面的 [(a,Rational)]  
    然後將 a apply to function 重新包裝回去
-}

thisSituation :: Prob (Prob Char)  
thisSituation = Prob  
    [
        ( Prob [('a',1%2),('b',1%2)] , 1%4 ),
        ( Prob [('c',1%2),('d',1%2)] , 3%4)  
    ]  

joinProb :: Prob (Prob a) -> Prob a  
joinProb (Prob xs) = Prob $ concat $ map multAll xs  
    where multAll (Prob innerXs, p) = map (\(x, r) -> (x, r*p)) innerXs  

instance Applicative Prob where
    pure = return
    (<*>) = ap
{-
    利用 Monad 跟 Applicative 的對應關係  可以不用真的實作 Applicative
    ap 定義於 Monadic lifting operators 屬於 Control.Monad
    
    ap :: (Monad m) => m (a -> b) -> m a -> m b
    ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
-}

instance Monad Prob where  
    return x = Prob [(x, 1%1)]  
    m >>= f = joinProb (fmap f m)  
    fail _ = Prob []  
{-
    m >>= f = join (fmap f m) 這是等價的!

    m :: m a
    f :: (a -> m a)
    而 fmap 會將 m 中的內容擷取丟入 f 其結果又包裝成 m
    fmap :: (a -> b) -> m a -> m b
    因此 
    fmap f m :: m (m b)
    join :: m(m a) -> m a
    結果為 join (m (m b)) :: m b
    
    (>>=) :: m a -> (a -> m b) -> m b 
    其結果也是 m b

    (return m >>= id) == m
    > (return thisSituation >>= id) == thisSituation
    True

    (m >>= return) == m
    > (thisSituation >>= return) == thisSituation
    True

    f <=< (g <=< h) should be the same as (f <=< g) <=< h.

    <=< 是 Monad 的 composition
-}

data Coin = Head | Tails deriving (Eq, Show)

normalCoin ::  Prob Coin
normalCoin = Prob [(Head,1%2),(Tails,1%2)]

loadedCoin :: Prob Coin
loadedCoin = Prob [(Head,1%10),(Tails,9%10)]

{-

flipThree :: Prob Bool  
flipThree = do  
    a <- normalCoin  
    b <- normalCoin  
    c <- loadedCoin  
    return (all (==Tails) [a,b,c])  
-}

{-
    The Continuation Monad
    
    Cont r a meaning take (a -> r) function apply to its own value a, then return r. 
-}
newtype Cont2 r a = Cont2 { runCont2 :: (a -> r) -> r }

instance Functor (Cont2 r) where
    fmap :: (a -> b) -> Cont2 r a -> Cont2 r b
    fmap ab cont2_r_a = Cont2 
        (\br -> 
            (runCont2 cont2_r_a)(\a -> 
                br(ab(a))
            )
        )

instance Applicative (Cont2 r) where
    pure :: a -> Cont2 r a
    pure a = Cont2  
        (\ar -> 
            ar(a)
        )
    (<*>) :: Cont2 r ( a -> b ) -> Cont2 r a -> Cont2 r b
    (<*>) cont2_r_ab cont2_r_a = Cont2 
        (\br -> 
            runCont2(cont2_r_a)(\a -> 
                runCont2(cont2_r_ab)(\ab -> 
                    br(ab(a))
                ) 
            )
        )

instance Monad (Cont2 r) where
    (>>=) :: Cont2 r a -> (a -> Cont2 r b) -> Cont2 r b
    (>>=) cont2_r_a a_cont2_r_b = Cont2 
        (\br ->
            runCont2(cont2_r_a)(\a ->
                runCont2(a_cont2_r_b a)(\b ->
                    br b
                )
            )   
        )