tut11.hs

import Data.Function

class Queue q where
    emptyQueue :: q a
    isEmpty :: q a -> Bool
    enqueue :: a -> q a -> q a
    dequeue :: q a -> (a, q a)

data SQueue a = SQ [a] [a]

instance Queue SQueue where
    emptyQueue = SQ [] []

    isEmpty (SQ [] []) = True
    isEmpty _          = False

    enqueue x (SQ a b) = SQ a (x:b)

    dequeue (SQ [] [])   = error "dequeue: empty queue"
    dequeue (SQ [] b)    = dequeue $ SQ (reverse b) []
    dequeue (SQ (x:a) b) = (x, SQ a b)

toList :: SQueue a -> [a]
toList (SQ a b) = a ++ reverse b

instance Eq a => Eq (SQueue a) where
    (==) = (==) `on` toList

instance Show a => Show (SQueue a) where
    show = ('q':) . show . toList

instance Functor SQueue where
    fmap f (SQ a b) = SQ (fmap f a) (fmap f b)

queue_of_nums :: Queue q => Int -> Int -> q Int
queue_of_nums a b = foldl (flip enqueue) emptyQueue [a .. b]


newtype Sum a = Sum { getSum :: a }
newtype Product a = Product { getProduct :: a }

instance (Num a) => Semigroup (Sum a) where
    Sum a <> Sum b = Sum (a + b)

instance (Num a) => Monoid (Sum a) where
    mempty = Sum 0

instance (Num a) => Semigroup (Product a) where
    Product a <> Product b = Product (a * b)

instance (Num a) => Monoid (Product a) where
    mempty = Product 1

-- Proč se bavíme o monoidech? Nedávno jsme si ukazovali funkce 'foldr' a
-- 'foldl'. Podobně jako 'Functor' zobecňuje 'map' (na 'fmap'), tak 'Foldable'
-- zobecňuje 'foldr' (na 'foldMap').
--
-- > :i Foldable
-- class Foldable (t :: * -> *) where
--   foldMap :: Monoid m => (a -> m) -> t a -> m

instance Foldable Tree where
    foldMap _ Leaf = mempty
    foldMap f (Node l x r) = foldMap f l <> f x <> foldMap f r

-- > let t = Node (Node Leaf 2 Leaf) 4 (Node Leaf 6 Leaf)
-- > foldr (+) 0 t
-- 12
--
-- > length t
-- 3
--
-- Pomocí 'foldMap' implementujte:

length' :: (Foldable t) => t a -> Int
length' = undefined

sum' :: (Foldable t, Num a) => t a -> a
sum' = undefined

product' :: (Foldable t, Num a) => t a -> a
product' = undefined

toList' :: (Foldable t) => t a -> [a]
toList' = undefined

-- Minule jsme se podívali na typovou třídu Functor.
--
-- class Functor f where
--     fmap :: (a -> b) -> f a -> f b
--
-- Dva typické příklady typových konstruktorů, které jsou součástí třídy
-- Functor, jsou: Maybe a []
--
-- instance Functor Maybe where
--     fmap _ Nothing  = Nothing
--     fmap f (Just a) = Just (f a)
--
-- instance Functor [] where
--     fmap = map
--
-- Dalším krokem je typová třída Monad, což je mnohem silnější verze třídy
-- Functor. Nejdřív ale začneme konkrétním příkladem.
--
-- > :t lookup
-- lookup :: (Eq a) => a -> [(a, b)] -> Maybe b
--
-- Pokud chceme najít hodnotu pro daný klíč ve dvou (nebo více) asociativních
-- seznamech najedou, můžeme použít např.

lookup2, lookup2' :: (Eq a) => a -> [(a, b)] -> [(a, c)] -> Maybe (b, c)
lookup2 a ab ac = case lookup a ab of
    Nothing -> Nothing
    Just b  -> case lookup a ac of
        Nothing -> Nothing
        Just c  -> Just (b, c)

-- Pro tři a více seznamů už by tahle funkce začala být nepřehledná, přitom
-- ale neděláme nic zajímavého. Naštěstí můžeme použít case i takhle:

lookup2' a ab ac = case (lookup a ab, lookup a ac) of
    (Just b, Just c) -> Just (b, c)
    _                -> Nothing

-- Často se náme ale může stát, že klíč, který budeme hledat v druhém (třetím,
-- atp.) seznamu závisí na nalezené hodnotě z prvního seznamu.

lookupChain :: (Eq a, Eq b) => a -> [(a, b)] -> [(b, c)] -> Maybe (b, c)
lookupChain a ab bc = case lookup a ab of
    Nothing -> Nothing
    Just b  -> case lookup b bc of
        Nothing -> Nothing
        Just c  -> Just (b, c)

-- Tady už nám předchozí trik nepomůže a musíme použít "case kaskádu".
--
-- Musí to jít lépe! Všimněte si, co se v téhle funkci děje: Nejprve se podíváme
-- na první lookup. Pokud neuspěl, tak končíme. Pokud uspěl, tak vezeme
-- nalezenou hodnotu a použijeme ji v další části kódu.
--
-- Tohle jsme schopni s použitím funkcí vyššího řádu jednoduše reprezentovat.

andThen :: Maybe a -> (a -> Maybe b) -> Maybe b
andThen Nothing  _ = Nothing  -- První akce neuspěla, konec.
andThen (Just a) f = f a      -- První akce uspěla, vezmeme hodnotu a předáme
                              -- ji zbytku (zde v podobě funkce).

lookupChain' :: (Eq a, Eq b) => a -> [(a, b)] -> [(b, c)] -> Maybe c
lookupChain' a ab bc =
    lookup a ab `andThen` \b ->
    lookup b bc

-- Jsme na dobré cestě, ale funkce lookupChain' nám vrátí pouze druhý nalezený
-- prvek, zatímco originální implementace vracela oba nalezené prvky. To lze
-- ale snadno opravit, buď za použití funkce fmap, nebo dalším použitím andThen.

lookupChain'' :: (Eq a, Eq b) => a -> [(a, b)] -> [(b, c)] -> Maybe (b, c)
lookupChain'' a ab bc =
    lookup a ab `andThen` \b  ->
    lookup b bc `andThen` \c ->
    Just (b, c)

-- resp. (pozor, hodně apostrofů)

lookupChain''' :: (Eq a, Eq b) => a -> [(a, b)] -> [(b, c)] -> Maybe (b, c)
lookupChain''' a ab bc =
    lookup a ab `andThen` \b ->
    fmap (\c -> (b, c)) (lookup b bc)

-- Další důležitý poznatek je ten, že Just je v určitém smyslu neutrální
-- operace.
--
-- Just x `andThen` f     ==  f x
-- v      `andThen` Just  ==  v

done :: a -> Maybe a
done = Just

lookupChain3 :: (Eq a, Eq b, Eq c)
             => a                                 -- První klíč
             -> [(a, b)] -> [(b, c)] -> [(c, d)]  -- Asociativní seznamy
             -> Maybe (b, c, d)
lookupChain3 a ab bc cd =
    lookup a ab `andThen` \b ->
    lookup b bc `andThen` \c ->
    lookup c cd `andThen` \d ->
    done (b, c, d)

-- Na Maybe a se můžeme dívat jako na výpočet, který buď vyprodukuje hodnotu
-- typu a, nebo skončí neúspěchem. andThen nám potom umožňuje skládat tyto
-- "výpočty s neúspěchem".
--
-- Můžeme najít podobnou operaci pro jiné typy?

sqrt' :: Complex Double -> [Complex Double]
sqrt' z = [mkPolar r' theta', mkPolar (-r') theta']
  where
    (r, theta) = polar z

    theta' = theta / 2
    r'     = sqrt r

-- Pokud bychom chtěli spočítat 4. odmocninu, tak sqrt' můžeme aplikovat
-- dvakrát. To se dá udělat např. takhle:

root4 :: Complex Double -> [Complex Double]
root4 x = concat (map sqrt' (sqrt' x))

-- Nejdříve namapujeme, tak pomocí funkce concat zploštíme dvojitý seznam.

mystery x f = concat $ map f x

-- > :t mystery
-- mystery :: [a] -> (a -> [b]) -> [b]
--
-- Tohle je povědomé! Porovnejte typ této funkce s typem funkce andThen.

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

root8, root8' :: Complex Double -> [Complex Double]
root8 x =
    sqrt' x `andThenL` \y ->
    sqrt' y `andThenL` \z ->
    sqrt' z

-- Nebo jednoduše

root8' x = sqrt' x `andThenL` sqrt' `andThenL` sqrt'

-- Na seznam se obvykle díváme pouze jako na strukturu obsahující data. Ale
-- podobně jako na Maybe a můžeme nahlížet jako na výpočet, který může skončit
-- neúspěchem, tak [a] je výpočet, který může nabývat více hodnot. Trochu
-- jako nedeterminismus v Prologu.
--
-- Zbývá nám najít ekvivalent pro operaci done. Musí být neutrální vzhledem
-- k andThenL, což nám dává jen jednu možnost.

doneL :: a -> [a]
doneL a = [a]

times :: [a] -> [b] -> [(a, b)]
times as bs =
    as `andThenL` \a ->
    bs `andThenL` \b ->
    doneL (a, b)

-- Máme dva konkrétní příklady, teď tento koncept "spojování výpočtů" můžeme
-- generalizovat.
--
-- class Applicative m => Monad m where
--     return :: a -> m a                  -- done, doneL
--     (>>=)  :: m a -> (a -> m b) -> m b  -- andThen, andThenL
--
-- Pozn. return má možná trochu nešťastné jméno. Narozdíl od return
-- v ostatních jazycích nekončí výpočet. Místo return budeme používat
-- funkci pure (z typové třídy Applicative), která dělá to samé.

weird :: Maybe Int
weird =
    return 1 >>= \_ ->
    Nothing

-- > weird == Nothing
-- True

times' :: [a] -> [b] -> [(a, b)]
times' as bs =
    as >>= \a ->
    bs >>= \b ->
    pure (a, b)

lookupChain3' :: (Eq a, Eq b, Eq c)
              => a
              -> [(a, b)] -> [(b, c)] -> [(c, d)]
              -> Maybe (b, c, d)
lookupChain3' a ab bc cd =
    lookup a ab >>= \b ->
    lookup b bc >>= \c ->
    lookup c cd >>= \d ->
    pure (b, c, d)

-- Použití >>= je v Haskellu tak časté, že pro něj existuje syntaktická
-- zkratka, tzv. do notace.
--
-- Na zarovnání záleží, jedině tak pozná Haskell, jestli začínáme novou řádku,
-- pokračujeme předchozí nebo končíme do blok.

times'' :: [a] -> [b] -> [(a, b)]
times'' as bs = do
    a <- as
    b <- bs
    pure (a, b)

failIf :: Bool -> Maybe ()
failIf True = Nothing
failIf _    = Just ()

weird' :: (Eq a) => (b -> Bool) -> a -> [(a, b)] -> Maybe b
weird' cond a ab = do
    b <- lookup a ab
    failIf (cond b)   -- Pokud nás hodnota z failIf nezajímá, můžeme
                      -- šipku vynechat.
    pure b

-- Kromě toho můžeme ještě používat zkrácenou formu let.
--
-- do x <- y
--    let z = x * x
--    ...
--
-- pure na konci do-bloku není nutný, tak jak jsme viděli např. u funkce
-- root8.

root8'' :: Complex Double -> [Complex Double]
root8'' x = do
    y <- sqrt' x
    z <- sqrt' y
    sqrt' z

-- do notace lze přeložit zpět do obyčejného výrazu:
--
-- do a <- ma    ===  ma >>= \a ->
--    mb              mb
--
-- do ma         ===  ma >>= \_ ->
--    mb              mb
--
-- do let x = y  ===  let x = y
--    ma              in  ma
--