Cvičení z Neprocedurálního programování - 12

1-funktory.hs

{-# LANGUAGE InstanceSigs #-} -- umožňuje psát typové anotace u metod typových tříd

-- OPAKOVÁNÍ: Funktory
class MujFunctor f where
    mujFmap :: (a -> b) -> f a -> f b

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

instance MujFunctor [] where
    mujFmap :: (a -> b) -> [a] -> [b]
    mujFmap = map

{- Either je typ ze standardní knihovny!


data Either e a 
    = Left e
    | Right a

Buď má (levou) hodnotu typu e,
nebo má (pravou) hodnotu typu a.

Je to něco jako "součet" typů 'e' a 'a'
(Oproti tomu např. typ '(a, b)' je "součin" typů 'a' a 'b')

Typické použití:
'Either String a'
je výpočet, který vrací 'a', nebo error typu 'String'.
=> Konvence: Left je pro errory, Right je pro hodnoty.
-}

-- | Odmocní číslo, nebo vrátí error typu String
odmocni :: Double -> Either String Double
odmocni x
    | x >= 0.0 = Right $ sqrt x
    | otherwise = Left "ohno, negative in odmocni :("
    
instance MujFunctor (Either e) where
    mujFmap :: (a -> b) -> Either e a -> Either e b
    mujFmap f (Right x) = Right $ f x
    mujFmap _ (Left err) = Left err

2-andThen.hs

{-# LANGUAGE InstanceSigs #-} -- umožňuje psát typové anotace u metod typových tříd

-- | Vezme klíč 'k', který je porovnatelný
-- a seznam dvojic (k, v).
-- Pokud je 'k' v seznamu dvojic, vrátí jeho "hodnotu",
-- jinak vrátí Nothing
lookUp :: Eq k => k -> [(k, v)] -> Maybe v
lookUp _ [] = Nothing
lookUp k ((x, v):xs)
    | k == x = Just v
    | otherwise = lookUp k xs

-- Seznam pro testování
mujSeznam :: [(Int, Char)]
mujSeznam = zip [1..] "abcde"

-- Poznámka: funkce 'enumerate' v Pythonu je jen 'zip [1..]'

{-
>>> lookUp 2 mujSeznam
Just 'b'

>>> lookUp (-1) mujSeznam
Nothing
-}

-- | Co kdybychom chtěli udělat následující věc:
-- Najít hodnotu x pro k a potom najít hodnotu x' pro x, atd.
-- než to provedeme čtyřikrát?
--
-- Metafora: seznam [(a, a)] je seznam dvojic [(syn, otec)]
-- a chceme čtyřikrát zavolat otec (najít pra-pra-dědu)
lookUp4 :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4 k xs =
    case lookUp k xs of
        Nothing -> Nothing
        Just k1 ->
            case lookUp k1 xs of
                Nothing -> Nothing
                Just k2 ->
                    case lookUp k2 xs of
                        Nothing -> Nothing
                        Just k3 -> lookUp k3 xs
-- Podobný problém v C++/C#/Javě:
{-
if (x != null) {
    if (x.y != null) {
        if (x.y.z != null) {
            if (x.y.z.w != null) {
                return x.y.z.w;    
            }    
        }    
    }
}
-}

-- Tohle není moc hezké, co kdybychom si udělali nějakou funkci,
-- která by nám pomohla tohle napsat slušněji?
andThen :: Maybe a -> (a -> Maybe b) -> Maybe b
andThen Nothing _ = Nothing
andThen (Just x) f = f x

-- Nyní můžeme lookup4 napsat takhle:
lookUp4' :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4' k xs =
    lookUp k xs `andThen` \k1 ->
        lookUp k1 xs `andThen` \k2 ->
            lookUp k2 xs `andThen` \k3 ->
                lookUp k3 xs
-- Prosím, fakt se podívejte výše a přesvědčte se o tom,
-- že funkce lookUp4 a lookUp4' dělají to samé

{- Alternativní způsob jak zapsat lookUp4':

lookUp4' :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4' k xs =
    lookUp k xs `andThen`
    \k1 -> lookUp k1 xs `andThen`
    \k2 -> lookUp k2 xs `andThen`
    \k3 -> lookUp k3 xs
    
`andThen` nápadně připomíná "chytrý středník" ;)
-}

-- Dále si všimněme, že:
-- 'Just :: a -> Maybe a' je "neutrální operace"
-- Just x `andThen` f     === f x
--    v   `andThen` Just  === v

-- Označme si ji jako 'done'
done :: a -> Maybe a
done = Just

-- | Verze lookUp4, která používá 'done', aby byla hezky symetrická
lookUp4'' :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4'' k xs =
    lookUp k xs `andThen`
    \k1 -> lookUp k1 xs `andThen`
    \k2 -> lookUp k2 xs `andThen`
    \k3 -> lookUp k3 xs `andThen`
    \k4 -> done k4
-- Nevypadá 'done' trochu jako 'return'? ;)

{-
Jiný pohled na 'Maybe a' je, že je to _výpočet_ hodnoty typu 'a', který se nemusí povést.
Tento pohled se nám bude hodit později. ;)
-}

-- Zdánlivě z jiného soudku:

-- Vezměme si následující funkci, která vrací sousedy daného políčka na šachovnici
-- zapsáno pomocí List Comprehension (viděli jsme dříve)
neighbours :: (Int, Int) -> [(Int, Int)]
neighbours (x, y) = [ (x + 1, y), (x, y + 1), (x - 1, y), (x, y - 1) ]

-- Příklad:
-- >>> neighbours (0, 0)
-- [(1,0),(0,1),(-1,0),(0,-1)]

-- Co kdybychom chtěli funkci, která vrátí políčka, která jsou dosažitelná dvěma kroky?
-- (nebudeme řešit duplicity)
twoStepNeighbours :: (Int, Int) -> [(Int, Int)]
twoStepNeighbours position = concat $ map neighbours (neighbours position)
-- ^ Na každého souseda position zavoláme neighbours, tím dostaneme seznam seznamů pozicí
-- a ten pak sploštíme pomocí concat (concat :: [[a]] -> [a]).

-- Příklad:
-- >>> twoStepNeighbours (0, 0)
-- [(2,0),(1,1),(0,0),(1,-1),(1,1),(0,2),(-1,1),(0,0),(0,0),(-1,1),(-2,0),(-1,-1),(1,-1),(0,0),(-1,-1),(0,-2)]

-- Tenhle vzor vypadá nějak podezřele známý.
-- Zkusme se na něj podívat blíže:
hmm :: [a] -> (a -> [b]) -> [b]
hmm x f = concat $ map f x

{- Podívejme se na typy 'hmm' a 'andThen' pod sebou:

>>> :t andThen
andThen :: Maybe a -> (a -> Maybe b) -> Maybe b

>>> :t hmm
mystery :: [a] -> (a -> [b]) -> [b]
-}

-- | 'andThenL' je podobné jako 'andThen', ale pro seznamy.
andThenL :: [a] -> (a -> [b]) -> [b]
andThenL x f = concat $ map f x

-- | Sousedi vzdálení tři kroky pomocí 'andThenL'
threeStepNeighbours :: (Int, Int) -> [(Int, Int)]
threeStepNeighbours p =
    neighbours p `andThenL` \p1 ->
    neighbours p1 `andThenL` \p2 ->
    neighbours p2

-- | Podobná neutrální operace jako 'done', ale pro seznamy:
doneL :: a -> [a]
doneL x = [x]


-- | Sousedi vzdálení tři kroky pomocí 'andThenL' a 'doneL'
threeStepNeighbours :: (Int, Int) -> [(Int, Int)]
threeStepNeighbours p = do
    neighbours p `andThenL` \p1 ->
    neighbours p1 `andThenL` \p2 ->
    neighbours p2 `andThenL` \p3 ->
    doneL p3

{-
Nabízí se alternativní pohled na hodnoty typů 'Maybe a' a '[a]':

'Maybe a' je výpočet typu 'a', který může selhat
'[a]' je výpočet typu 'a', který může vrátit více variant
-}

-- | Naprogramujme si kartézský součin dvou seznamů:
times :: [a] -> [b] -> [(a, b)]
times xs ys =
    xs `andThenL` \x ->
    ys `andThenL` \y ->
    doneL (x, y)
    
-- >>> times [1, 2, 3] "abc"
-- [(1, 'a'), (2, 'b'), (3, 'c')]

-- Opravdu se přesvědčte, _že_ tohle počítá kartézský součin
-- a rozmyslete si _jak_ to počítá kartézský součin.

{-
Máme tedy:
andThenL ::   [a]   -> (a ->   [b]  ) ->   [b]
andThen  :: Maybe a -> (a -> Maybe b) -> Maybe b

Pokud bychom generalizovali, dostaneme:
obecneAndThen :: m a -> (a -> m b) -> m b

Podobně:
doneL :: a ->   [a]
done  :: a -> Maybe a

Zase po generalizaci dostáváme:
obecneDone :: a -> m a 

Máme i nějaká rozumná pravidla pro tyto typy -- konkrétně:
'obecnyDone' by měla být "identita" pro 'obecneAndThen'
a nějakým způsobem by 'obecneAndThen' mělo být asociativní.

Dostáváme tedy typovou třídu 'Monad':

class Monad m where
    return :: a -> m a                  -- done, doneL
    
    -- ^ pozor, 'return' nesouvisí s návratem z funkce
    -- jako v procedurálních jazycích, jméno je to trochu nešťastné...
    
    (>>=) :: m a -> (a -> m b) -> m b   -- andThen, andThenL
    
    -- ^ tento operátor se čte "bind"
    -- představujte si to jako záchodový zvon 🪠 :)
-}

-- | 'times' napsaný pomocí (>>=) a return
times' :: [a] -> [b] -> [(a, b)]
times' xs ys =
    xs >>= \x ->
    ys >>= \y ->
    return (x, y)

3-doNotation.hs

{-# LANGUAGE InstanceSigs #-}

-- Z minulého souboru:

-- | Vezme klíč 'k', který je porovnatelný
-- a seznam dvojic (k, v).
-- Pokud je 'k' v seznamu dvojic, vrátí jeho "hodnotu",
-- jinak vrátí Nothing
lookUp :: Eq k => k -> [(k, v)] -> Maybe v
lookUp _ [] = Nothing
lookUp k ((x, v):xs)
    | k == x = Just v
    | otherwise = lookUp k xs

{-
Připomínám, že třída 'Monad' vypadá takhle:

class Monad m where
    return :: a -> m a
    (>>=) :: m a -> (a -> m b) -> m b
-}

-- Monády jsou v Haskellu využívány tak často, že existuje syntaktický cukr ve formě
-- takzvané "do-notace", která vypadá _velmi_ imperativně!

-- | Kartézský součin napsaný pomocí (>>=) a return
times' :: [a] -> [b] -> [(a, b)]
times' xs ys =
    xs >>= \x ->
    ys >>= \y ->
    return (x, y)

-- | Kartézský součin pomocí do notace:
times :: [a] -> [b] -> [(a, b)]
times xs ys = do
    x <- xs
    y <- ys
    return (x, y)
    
-- | Čtyřnásobný 'lookUp' pomocí (>>=) a return:
lookUp4 :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4 k xs =
    lookUp k xs >>=
    \k1 -> lookUp k1 xs >>=
    \k2 -> lookUp k2 xs >>=
    \k3 -> lookUp k3 xs >>=
    \k4 -> return k4

-- | Čtyřnásobný 'lookUp' pomocí do notace:
lookUp4''' :: Eq a => a -> [(a, a)] -> Maybe a
lookUp4''' k xs = do
    k1 <- lookUp k xs
    k2 <- lookUp k1 xs
    k3 <- lookUp k2 xs
    k4 <- lookUp k3 xs
    return k4

{- Obecný návod jak se odcukrovává do notace:

do  
    a <- ma
    mb

ma >>= \a -> mb

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

do
    ma
    mb

ma >>= \_ -> mb

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

do
    let x = y
    mb

let x = y in mb
-}

vsechnySoucty :: [Int] -> [Int] -> [Int]
vsechnySoucty xs ys = do
    x <- xs
    y <- ys
    let result = x + y
    return result

-- je syntaktický cukr pro:

vsechnySouctyBezCukru :: [Int] -> [Int] -> [Int]
vsechnySouctyBezCukru xs ys =
    xs >>= \x ->
    ys >>= \y ->
    let result = x + y in
    return result

4-monads.hs

{-# LANGUAGE InstanceSigs #-}

-- Z minulého souboru:

andThen :: Maybe a -> (a -> Maybe b) -> Maybe b
andThen Nothing _ = Nothing
andThen (Just x) f = f x

andThenL :: [a] -> (a -> [b]) -> [b]
andThenL x f = concat $ map f x

-- Pár vlastních instancí monád:

class Functor m => MojeMonada m where
    mReturn :: a -> m a
    mBind :: m a -> (a -> m b) -> m b
-- Pozor, všimněte si, že každá monáda musí být funktor.
-- Zároveň musí platit, že 'fmap f xs == xs >>= return . f'
-- Monády jsou ale silnější koncept než funktory
-- (Ne každý funktor je monáda)

-- Tuto instanci už jsme víceméně měli výše:
instance MojeMonada Maybe where
    mReturn :: a -> Maybe a
    mReturn = Just

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

-- Tuto instanci už jsme také víceméně měli výše:
instance MojeMonada [] where
    mReturn :: a -> [a]
    mReturn x = [x]

    mBind :: [a] -> (a -> [b]) -> [b]
    mBind = andThenL

-- Připomínám, Either je definován následovně:
-- 'data Either e a = Left e | Right a'
instance MojeMonada (Either e) where
    mReturn :: a -> Either e a
    mReturn x = Right x

    -- errory neupravujeme, na hodnoty aplikujeme funkci:
    mBind :: Either e a -> (a -> Either e b) -> Either e b
    mBind (Left err) _ = Left err
    mBind (Right x) f = f x

-- Příklad funkce, která používá 'Either'
odmocni :: Double -> Either String Double
odmocni x
    | x >= 0.0 = Right x
    | otherwise = Left "ohno, negative"

odmocniDvakrat :: Double -> Either String Double
odmocniDvakrat x = do
    y <- odmocni x
    z <- odmocni y
    return z
    
-- 'Either e a' je výpočet, který může selhat s errorem typu 'e'.
-- Tedy 'Maybe', 'Either e' a '[]' jsou vlastně _nějaké_
-- vedlejší efekty!

5-triples.hs

-- | Pythagorejské trojice menší než @n@, tedy
-- trojice, kde x <= y <= z <= n a x² + y² = z²
--
-- Zapsáno pomocí list comprehension:
triples :: Int -> [(Int, Int, Int)]
triples n = [(x, y, z) | x <- [1..n], y <- [x..n], z <- [y..n],
                (x * x + y * y == z * z)]

-- Příklad:
-- >>> triples 15
-- [(3,4,5),(5,12,13),(6,8,10),(9,12,15)]

-- Nevypadají list comprehensions vlastně trochu jako do notace?
-- Ano!
-- To je schválně -- do notace je vlastně zobecnění list comprehensions!

-- | Vrátí _všechny_ trojice, kde x <= y <= z <= n.
-- Nemusí to být _Pythagorejské_ trojice!
allTriples :: Int -> [(Int, Int, Int)]
allTriples n = do
    x <- [1..n]
    y <- [x..n]
    z <- [y..n]
    return (x, y, z)

-- Příklad:
-- >>> allTripes 3
-- [(1,1,1),(1,1,2),(1,1,3),(1,2,2),(1,2,3),(1,3,3),(2,2,2),(2,2,3),(2,3,3),(3,3,3)]

-- Jak můžeme naprogramovat hlídání podmínky?
-- Použijeme funkci 'guard'!
guard :: Bool -> [()]
guard True = [()] -- <- pokud je podmínka pravdivá, vrať jednu hodnotu!
guard False = [] -- <- pokud ne, nevracej žádnou hodnotu

-- To znamená, že pokud podmínka není splněná, tak nemáme co mapovat dál
-- a tato větev výpočtu vrátí pouze prázdný seznam.
-- Ten je pak zploštěn s jinými seznamy, což odpovídá tomu,
-- že z výsledek této větve není ve výsledném seznamu!

{-
Příklady pro ilustraci:

>>> guard True >>= \_ -> [42]
[42]

>>> guard False >>= \_ -> [42]
[]

>>> [1, 2, 3, 4, 5] >>= \x -> guard (even x)
[(),()]

>>> [1, 2, 3, 4, 5] >>= \x -> guard (even x) >>= \_ -> return x
[2,4]
-}

-- Poznámka: Mohli bychom vracet _jakoukoliv_ hodnotu,
-- volající ji stejně typicky zahazuje

-- Mimochodem, tohle je přesně způsob, jak jsou podmínky implementovány v list comprehension!

-- | Pythagorejské trojice pomocí do notace:
triples' :: Int -> [(Int, Int, Int)]
triples' n = do
    x <- [1..n]
    y <- [x..n]
    z <- [y..n]
    guard (x * x + y * y == z * z) -- to samé jako '_ <- guard (x * x + y * y == z * z)', ignorujeme návratovou hodnotu
    return (x, y, z)
    
    
-- Jiný příklad:
safeDivide :: Int -> Int -> Maybe Int
safeDivide x y
    | y == 0 = Nothing
    | otherwise = Just $ x `div` y
 
-- >>> safeDivide 5 2
-- Just 2
-- (je to celočíselné dělení ;) )

-- >>> safeDivide 5 0
-- Nothing
  
-- Napsaný pomocí do notace a 'guard':
safeDivide' :: Int -> Int -> Maybe Int
safeDivide' x y = do
    guard $ y /= 0
    return $ x `div` y
 
-- Tedy jde vidět, že můžeme používat něco jako list comprehension,
-- ale pro každou monádu!

6-state.hs

{-# LANGUAGE InstanceSigs #-}

-- Motivace: Chceme si udělat vlastní generátor pseudonáhodných čísel (PRNG).

type Seed = Int

-- Tomuto kódu víceméně nemusíte rozumět:
-- Berte to tak, že vygeneruje náhodné číslo [0..max]
-- Potřebuje ale 'Seed' a potřebuje také vrátit nový 'Seed'
randInt :: Int -> Seed -> (Seed, Int)
randInt max seed = (newSeed, n)
  where
      newSeed = (1664525 * seed + 1013904223) `mod` (2 ^ 32)
      n = newSeed `mod` max

-- Problém/neproblém: když to zavoláme vícekrát se stejným seedem, dostaneme stejnou hodnotu.
-- Tedy, ehm, to není problém, to je _korektní_ chování :D
-- Prostě si musíme ty seedy předávat dál, no

-- >>> randInt 100 1
-- (1015568748, 48)
-- -- ^ seed     ^ náhodné číslo

-- A chceme další číslo, tak dosadíme "starý seed"
-- >>> randInt 100 1015568748
-- (1586005467, 67)
-- -- ^ seed     ^ náhodné číslo

-- | Náhodná trojice čísel
randTriple :: Int -> Seed -> (Seed, (Int, Int, Int))
randTriple max seed = (seed3, (n1, n2, n3))
    where
        (seed1, n1) = randInt max seed
        (seed2, n2) = randInt max seed1 
        (seed3, n3) = randInt max seed2
        
-- Tohle je vopruz.
-- Přece nechceme takhle manuálně propagovat seedy.
-- Obecně je to nějaký stavový výpočet!
-- Vezme to předchozí stav a vrátí dvojici,
-- ve které je nový stav a výsledná hodnota.

-- Software Engineering řešení: abstrahujme to!

-- | Typ pro stavový výpočet nad stavem 's':
newtype State s a = State { runState :: s -> (s, a) }

-- Tvrdím, že tohle je monáda a že můžeme použít monády
-- a do notaci k tomu, abychom si masivně ušetřili práci.

instance Functor (State s) where
    fmap f (State m) = State $ \s ->     -- vezmeme 's :: s' a 
      let (s', a) = m s      -- spustíme stavový výpočet 'm :: s -> (s, a)' na 's :: s', čímž dostaneme 'a :: a' a nový stav 's' :: s'
       in (s', f a)          -- a vrátíme stav s' a (f a)
       
instance Monad (State s) where
    -- return je jednoduchý, vytvoříme "dummy" výpočet, který jen vrátí 'x' :)
    return :: a -> State s a
    return x = State $ \s -> (s, x)

    (>>=) :: State s a -> (a -> State s b) -> State s b
    State m >>= f = State $ \s ->
        let (s', a) = m s     -- spustíme stavový výpočet 'm :: s -> (s, a)' na 's :: s', čímž dostaneme 'a :: a' a nový stav 's' :: s'
        in  runState (f a) s' -- potom spustíme stav daný 'f a' na ten nový stav
        
 -- Tato instance dává o trochu více smysl, když si namalujete jak se mají předávat stavy.
 -- Je jednoznačně určená, protože chcete stavy posílat "dopředu",
 -- tak jak to slušné programy dělají

-- | Pomocná funkce 'get' vrátí aktuální stav
get :: State s s
get = State $ \s -> (s, s)

-- | Pomocná funkce 'set' _nastaví_ aktuální stav
set :: a -> State a ()
set a = State $ \_ -> (a, ())

-- | Konečně, 'randInt' jako stavový výpočet:
randIntS :: Int -> State Seed Int
randIntS max = do
    seed <- get
    let (newSeed, k) = randInt max seed
    set newSeed
    return k
-- No uznejte, nevypadá to jako procedurální jazyk?
-- Zakázali nám proměnné, tak jsme si je vytvořili sami :)

-- >>> runState (randIntS 100) 1
-- (1015568748,48)

-- >>> runState (randIntS 100 >>= \_ -> randIntS 100) 1
-- (1586005467,67)

-- Příklady jsou stejné jako výše, takže jde poznat, že jsme to udělali stejně dobře jako manuálně :)

-- | Náhodná trojice čísel pomocí stavového výpočtu:
randTripleS :: Int -> State Seed (Int, Int, Int)
randTripleS max = do
    n1 <- randIntS max 
    n2 <- randIntS max
    n3 <- randIntS max
    return (n1, n2, n3)
-- Tohle vypadá fakt hodně jako C++ :D

-- Technická poznámka:
--
-- Tady se přiznám, že jsem pro zjednodušení trochu lhal.
-- Technicky vzato je mezistupeň mezi Functor a Monad, kterému se říká
-- Applicative (česky "aplikativní funktor").
-- Každá monáda je aplikativní funktor, ale Haskell to neví.
--
-- Používáme tedy dummy implementaci níže, která se dá použít vždycky,
-- když už máme 'Monad' instanci :)
instance Applicative (State s) where
    pure = return
    mf <*> ma = do
        f <- mf
        a <- ma
        return (f a)