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

1-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)

2-labelState.hs

{-# LANGUAGE InstanceSigs #-} -- Jako na minulém cvičení chceme typové anotace u instancí typových tříd

-- Opakování: stavové výpočty
newtype State s a = State { runState :: s -> (s, a) }
-- Připomínám: runState :: State s a -> s -> (s, a)

-- Jako na minulém cvičení:
instance Functor (State s) where
--  fmap :: (a -> b) -> (s -> (s, a)) -> s -> (s, b)
    fmap :: (a -> b) -> State s a -> State s b
    fmap f stavovyVypocet = State $ \s ->       -- Nový stavový výpočet bere stav
        let (s', a) = runState stavovyVypocet s -- spustí starý výpočet, čímž dostane nový stav a ačko 
         in (s', f a)                           -- a vrátí nový stav a 'f a :: b'

instance Monad (State s) where
    return :: a -> State s a
    return a = State $ \s -> (s, a)

    (>>=) :: State s a -> (a -> State s b) -> State s b
    stavovyVypocet >>= f = State $ \s -> 
        let (s', a) = runState stavovyVypocet s  -- spustíme starý výpočet, dostaneme nový stav a ačko
            stavovyVypocet' = f a                -- aplikací f na a dostaneme nový stavový výpočet
         in runState stavovyVypocet' s'          -- který spustíme aplikací na nový stav

-- | Vrátí aktuální stav
get :: State s s
get = State $ \s -> (s, s)

-- | Nastaví nový stav
set :: s -> State s ()
set s = State $ \_ -> (s, ())

-- | Příklad: přičte jedničku ke stavu
--
-- Konkrétněji je to jako `state++` v C++ (tedy postinkrementace)
increment :: State Int Int
increment = do
    i <- get
    set (i + 1)
    return i

-- Alternativně:
-- increment = State $ \s -> (s + 1, s)

-- | Typ pro binární strom jako z domácího úkolu
data Strom a = Konec | Vetev (Strom a) a (Strom a)
  deriving (Eq, Show)

-- | Chceme funkci, která do každého vnitřního vrcholu stromu
-- vloží i číslo, které odpovídá inorder průchodu.
--
-- Tohle se hodí modelovat jako stavový výpočet,
-- abychom si nemuseli stav protahovat programem ručně.
label :: Strom a -> Strom (a, Int)
label strom = snd $ runState (labelStatefully strom) initialState
  where
    initialState :: Int
    initialState = 1
  
    labelStatefully :: Strom a -> State Int (Strom (a, Int))
    labelStatefully Konec = return Konec
    labelStatefully (Vetev l x r) = do
        l' <- labelStatefully l    -- rekurze do levého podstromu
        inorder <- increment       -- vrátí aktuální stav a zvýší jej o 1
        r' <- labelStatefully r    -- rekurze do pravého podstromu
        
        let x' = (x, inorder)
        return (Vetev l' x' r')
        
-- Poznámka: Všimněte si, že pouhým prohozením řádek dostanete preorder a postorder průchod!

{- Pro testování:

      testovaciStrom:

         'd'
        /   \ 
      'c'   'e'
      / \
   'a'  'b'
-}

testovaciStrom :: Strom Char
testovaciStrom = Vetev (Vetev (Vetev Konec 'a' Konec) 'b' (Vetev Konec 'c' Konec)) 
                       'd' 
                       (Vetev Konec 'e' Konec)
{-
>>> label testovaciStrom
Vetev (Vetev (Vetev Konec ('a', 1) Konec) ('b', 2) (Vetev Konec ('c', 3) Konec)) 
      ('d', 4) 
      (Vetev Konec ('e', 5) Konec)
-}

-- Opět schovávám instanci Applicative,
-- třídy, která je mezi Functor a Monad.
-- Více viz předchozí soubor :)
instance Applicative (State s) where
    pure = return
    mf <*> mx = do
        f <- mf
        x <- mx
        return $ f x

3-io.hs

module Main where

import System.IO

-- IO je příklad běžně používané monády
-- Výpočet v IO má neomezené vedlejší efekty (může libovolně interreagovat se systémem)
--
-- Kdybychom mohli předávat celý svět jako stav, pak:
--       IO a == RealWorld -> (RealWorld, a)
-- Samozřejmě, reálná implementace IO je složitější a daná implementací.

{-
Dvě základní funkce pro práci se vstupem:

>>> :t getLine
getLine :: IO String

>>> :t putStrLn
putStrLn :: String -> IO ()
-}

-- | Funkce, která se zeptá na jméno uživatele a pozdraví jej
pozdrav :: IO ()
pozdrav = do
    putStrLn "Ahoj, jak se jmenuješ?"
    jmeno <- getLine
    let pozdrav = "Ahoj, " <> jmeno <> "!"
    putStrLn pozdrav

-- | Funkce 'main' je entrypoint do Haskellového programu
--
-- Pokud máte něco typu 'IO a', pak to nutně musí "probublat" až do mainu.
main :: IO ()
main = do
    pozdrav
{-
Spouštění Haskellového programu v terminálu:

~> ghc <názevsouboru>.hs -o mujprogram
~> ./mujprogram
Ahoj, jak se jmenuješ?
> Jirka
Ahoj, Jirka!
-}
     
{-
Dávejte si pozor na následující: String není to samé jako IO String,
podobně jako recept na dort není to samé jako dort.
IO String je akce s vedlejšími efekty, která když se povede, tak vrátí String.
Podobně recept na dort je jen popis akce, která musí být provedena,
aby byl vytvořen dort.

Jinými slovy: funkce typu 'IO a -> a' nedává smysl
a nemůže existovat její bezpečná varianta!
-}

-- | Vrátí tři řádky vstupu
getThreeLines :: IO [String]
getThreeLines = do
    l1 <- getLine
    l2 <- getLine
    l3 <- getLine
    return [l1, l2, l3]

{-
Obecná návrhová věc:

V IO by měl být jen ten kód, který tam být _musí_.
Návrh programu by tedy měl mít imperativní skořápku s IO,
ale funkcionální jádro bez IO.

Příklad:

-- | Načte vstup
readData :: IO Input
readData = ...

-- | Vezme vstup a vrátí výstup.
-- Obecně je tohle nějaká "business logic"
-- 
-- Nepotřebuje IO!
process :: Input -> Output
process = ...

-- | Velká funkce (skořápka), která načte vstup,
-- předá je `process` a vrátí výstup.
--
-- Typicky je tohle někde poblíž, či rovnou v 'main'u.
readAndProcess :: IO Output 
readAndProcess = do
    data <- readData
    let data' = process data
    return data'

-}

-- Následující funkce se hodí pro každou monádu
-- a obzvlášť se hodí v 'do'-notaci

-- | Pokud platí podmínka, proveď akci, jinak nedělej nic.
when :: Monad m => Bool -> m () -> m ()
when cond action = if cond then action else return ()

{-
Typické použití:

```
when (userId `notIn` database) $ do
  throwError "Stala se chyba"
  redirect
...
```
-}

-- | Pokud _neplatí_ podmínka, proveď akci, jinak nedělej nic.
unless :: Monad m => Bool -> m () -> m ()
unless = when . not

-- | Příklad skoro rozumné IO akce.
--
-- Načte řádek a vypíše jej.
-- Pokud řádek není prázdný, zavolá se znovu.
-- To má podobný efekt jako 'while True:' loop
echo :: IO ()
echo = do
    l <- getLine
    putStrLn l

    unless (null l) echo

-- | Obecná abstrakce pro 'while True: ...'
forever :: Monad m => m () -> m ()
forever m = do
    m
    forever m

{-
Užitečné funkce pro práci s monádami:

'mapM' je jako 'map', ale zároveň skládá vedlejší efekty:

  mapM  :: Monad m => (a -> m b) -> [a] -> m [b]

'sequence' vezme seznam akcí a vrátí akci seznamu:

  sequence  :: Monad m => [m a] -> m [a]

Poznámka:
Funkce s 'M' jsou typicky nějaká varianta klasické funkce pro monády.
Například 'mapM', či 'foldM'.
Funkce s '_' na konci jsou takové, které jen provedou vedlejší efekty
a samotnou hodnotu zahodí.

Příklad funkcí s '_' jsou 'mapM_' a 'sequence_':

  mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
  sequence_ :: Monad m => [m a] -> m ()

-}

-- | 'getThreeLines' výše za pomocí 'sequence' :)
getThreeLines' :: IO [String]
getThreeLines' = sequence [getLine, getLine, getLine]

{- Práce se soubory:

Soubory jdou otevřít v různých módech:
  data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode

Soubory jdou otevřít a zavřít:
  openFile :: FilePath -> IOMode -> IO Handle
  hClose :: Handle -> IO ()

Do souborů jde psát a jde z nich i číst:
  hPutStrLn :: Handle -> String -> IO ()
  hGetLine :: Handle -> IO String

-}

-- | Příklad: Vezme string na vstupu a připíše jej do logu
logLine :: String -> IO ()
logLine myLine = do
    h <- openFile "myprogram.log" WriteMode
    hPutStrLn h myLine
    hClose h 

-- Užitečný kombinátor:
--   withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-- se chová jako 'with' konstrukce v Pythonu.
-- S ní nezapomenete na to zavřít soubor :)

-- | Homemade verze 'withFile':
withFile' :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile' path iomode action = do
    h <- openFile path iomode
    result <- action h
    hClose h
    return result

-- | 'logLine', ale pomocí 'withFile'
logLine' :: String -> IO ()
logLine' myLine = do
    withFile "myprogram.log" WriteMode $ \h -> do
        hPutStrLn h myLine

4-parser.hs

-- Povídali jsme si o Parseru, ale nestihli jsme ho.
-- Místo toho si monadický parser vyrobíte v posledním úkolu :)