JCI: FP

Zagadnienia omówione na wykładzie

W1 (04.03.2025): GHCI i funkcje

Podstawowe polecenie ghci:

:q = wyjście
:t = typ
:i = info
:l = załadowanie modułu

Część kodów, które pojawiły się na tablicy.


module W1 where
-- funkcja jednej zmiennej
f x = 1 + x*(x+1)

g::Num a => a -> a -> a
g x y = 1 + x*y
-- Silnia : IF ... ELSE ...
fact1 :: Integer -> Integer
fact1 n = if n==0 then 1
          else n * fact1 (n-1)
-- Silnia : pattern matching          
fact2 :: Integer -> Integer
fact2 0 = 1
fact2 n = n * fact2 (n - 1)
-- Silnia : case expresion
fact3 n = case n of 
  0 -> 1
  n -> n * fact3 (n-1)
-- Silnia : with let expression  
fact4 :: Integer -> Integer
fact4 n  = let y = fact4 (n-1) in
           if n==0 then 1 else n * y

Ważna sprawa: zrozumienie pojęcia currying i uncurrying.

W2 (11.03.2025): Podstawowe typy

Podstawowe konstruktory typów

(a,b) :pary elementów typu a i b
[a] : ciągi elementów typu a; podstawowe funkcje (:) oraz (++)

Część kodów, które pojawiły się na tablicy.


{-

  modul: W2.hs

  info: Wykład z FP 2024/25 lato

  author: Jacek Cichoń

  date: 11.03.2025

-}



module W02 where

{- PARY -}



fst' (x,_) = x

snd' (_,y) = y



coll n | n == 1    = 1

       | even n    = coll (div n 2)

       | otherwise = coll (3*n+1)

 

collatz :: (Int,Int) -> (Int,Int)

collatz (n,s) | n==1      = (1,s)

              | even n    = collatz (div n 2,s+1)

              | otherwise = collatz (3*n+1,s+1)

lCollatz n = snd (collatz (n,0))



{- LISTY -}

length' []     = 0

length' (x:xs) = 1 + length' xs



head' [] = error "head: pusta lista"

head' (x:xs) = x



tail' [] =[]

tail' (x:xs) = xs



map' f [] = []

map' f (x:xs) = f x : map f xs



filter' p [] = []

filter' p (x:xs) = if p x then x:(filter' p xs) 

                          else filter' p xs

-- Lists comprehension



pythagorean n = [(x,y,z)| z<- [1..n],y<-[1..z], x<-[1..y], gcd x y == 1, x^2 + y^2 == z^2]

Uwagi:

Typ a->a jest intepretowany jako $(\lambda a: \mathrm{Type} \to (a\to a))$
Dummy variable : _
Aplikacja funkcji do zmiennej ma największy priorytet
Notacja infixowa: polecenie gcd x ymożna zapisać jako x `gcd` y
Wyrażenia listowe (list comprehension) są kosztowne.

W3 (18.03.2025): Sortowania; zip'y; foldy

Kody z wykładu:


module W03 where



import Data.List



{- SORTOWANIA -}

-- qS : lipna wersja

qS [] = []

qS (x:xs) = (qS [y| y<- xs, y<x]) ++

            [x] ++

            (qS [y| y<- xs, y>=x])

            

-- partition

{- komentuje, bo jest w Data.List

partition :: (a->Bool) -> [a] ->([a],[a])

partition _ [] = ([],[])

partition p (x:xs) = if p x then (x:l,r)

                            else (l,x:r)

                     where (l,r) = partition p xs

-}



-- sections 

p3 = (+ 3)

m4 = (4 *)



-- qSort

qSort []     = []

qSort [x]    = [x]

qSort (x:xs) = (qSort l) ++ [x] ++ (qSort r)

               where (l,r) = partition (<x) xs 

-- inSort



inSort [] = []

inSort [x] = [x]

inSort (x:xs) = left ++ [x] ++ right

                where sxs = inSort xs

                      (left,right) = partition (<x) sxs



{- ZIPY -}

-- uzywam ' bo zip i zipWith są w Prelude

zip' [] _ = []

zip' _ [] = []

zip' (x:xs) (y:ys) = (x,y): (zip' xs ys)



zipWith' _ [] _ = [] 

zipWith' _ _ [] = []

zipWith' f (x:xs) (y:ys) = (f x y): zipWith' f xs ys



-- zagadka 

addMat = zipWith (zipWith (+)) 



{-- FOLDY --}

-- uzywam myfold* bo foldy sa w Prelude

add [] = 0

add (x:xs) = x + add xs



prod [] = 1

prod (x:xs) = x * prod xs



myfoldr f e [] = e

myfoldr f e (x:xs) = f x (myfoldr f e xs)



myfoldl f e [] = e

myfoldl f e (x:xs) = foldl f (f e x) xs



-- reverse jest Data.List, flip jest w Prelude

myreverse :: [a] -> [a]

myreverse  = foldl (flip (:)) []

W4 (25.03.2025): Foldy, strumienie, wstęp do typów

Zastosowania foldów i strumienie


module W04a where

import Data.List

sum'       xs  = foldl (+) 0 xs
product'   xs  = foldl (*) 1 xs 
minimum'   xs  = foldl1 min xs

-- fold1 f (x:xs) = foldl f x xs
and'       xs  = foldl (&&) True xs
or'        xs  = foldl (||) False xs
concat'    xxs = foldl (++) [] xxs
concatMap' f   = foldl ((++).f) []

{-- Automaty skonczone --}

-- AUTOMAT DETERMINISTYCZNY 
runDFA :: (s -> c -> s) -> s -> [c] -> s
--runDFA delta start cs = foldl delta start cs
runDFA = foldl

acceptDFA :: (s -> c -> s) -> s -> (s -> Bool) -> [c] -> Bool
acceptDFA delta start accept cs = accept (runDFA delta start cs)
 
-- przyklad: parzysta liczba jedynek

delta 1 '1' = 2
delta 1 _   = 1
delta 2 '1' = 1
delta 2 _   = 2
delta _ _   = 1  

-- AUTOMAT NIEDETRMINISTYCZNY 
-- procedure przekonwertowania automatu niedeterministyczngo
-- na automat deterministyczny
convertDelta :: (Eq s)=>(s->c->[s]) -> ([s]->c->[s]) 
convertDelta delta ss c  = nub (concat(map (\s -> delta s c) ss))
        
runNFA :: (Eq s) => (s->c->[s]) -> s -> [c] -> [s]
runNFA delta start cs = 
  runDFA deltaS [start] cs 
  where deltaS = convertDelta delta

convertAcc :: (s->Bool) -> ([s]->Bool)
convertAcc acc ss = or (map acc ss)

acceptNFA :: (Eq s) => (s->c->[s]) -> s -> (s->Bool) -> [c]->Bool
acceptNFA delta start acc cs = 
  accS (runNFA delta start cs)
  where accS = convertAcc acc
   
-- ciagi konczace sie jedynka
rho :: Int -> Char ->[Int]
rho 1 '1' = [1,2]
rho 1  _  = [1]
rho 2 '1' = [2]
rho 2   _ = [1]
           
{-- "Infinite streams" --}

myrepeat x = x:myrepeat x

myrepeat' x = xs where xs = x : xs

cycle' []  = error "cycle: emptyList"
cycle' xs  = xs' where xs' = xs ++ xs'

iterate' :: (a -> a) -> a -> [a]
iterate' f x =  x : iterate f (f x)

approSqrt:: Double->[Double]
approSqrt a = iterate (\x->(x+a/x)/2) a

-- liczby fibonacciego
fibb = 0:1: zipWith (+) fibb (tail fibb)

-- liczby pierwsze
sieve (p:xs) = p : sieve (filter (\n -> mod n p /= 0) xs)
primes = sieve [2..]

better_sieve (p:xs) = p: sieve (filter(\n -> n<p*p ||(mod n p /= 0)) xs)

addGF xs ys = zipWith (+) xs ys

Konstrukcja "type"


module Fizyka(Point,Vector,Time,

              move, translate, moveInGF) where



type Point = (Double,Double)

type Vector = (Double,Double)

type Time = Double



constG = 9.80655



-- lokalna funkcje

generalMove :: Point -> Vector -> Time -> Double -> Point

generalMove (x,y) (vx,vy) t acc = (x+vx*t, y + vy*t + acc*t*t/2)



-- upublicznione 

move :: Point -> Vector -> Time -> Point

move p v t = generalMove p v t 0 



translate :: Point -> Vector -> Point

translate p v = generalMove p v 1 0



moveInGF :: Point -> Vector -> Time -> Point

moveInGF p v t = generalMove p v t (-constG)

Konstrukcja "data" - wstęp


module W04b where



{-- Typy numerowane --}

data DOW = Po|Wt|Sr|Cz|Pi|So|Ni deriving (Eq,Ord,Enum,Bounded)



instance Show DOW where

  show Po = "Poniedziałek"

  show Wt = "Wtorek"

  show Sr = "Środa"

  show Cz = "Czwartek"

  show Pi = "Piatek"

  show So = "Sobota"

  show Ni = "Niedziela"



dniPracujace = [Po .. Pi] -- efekt Enum

Proponuję rzucić okiem na następującą stronę: The Evolution of a Haskell Programmer, na której Fritz Ruehr'er wygłupia się z różnymi sposobami zdefiniowania funkcji silnia.

W5 (01.04.2025): Typy, wstęp do funktorów

Zastosowania foldów i strumienie


module W5b where



-- prototyp

data Osoba' = Osoba' String String String Int Int Int



imie' :: Osoba' -> String

imie' (Osoba' _ x _ _ _ _) = x

-- itd 



{-- RECORD SYNTAX --}



data Osoba = Osoba

     {

      idO :: String

     ,imie :: String

     ,nazwisko :: String

     ,rokUr :: Int

     ,miesiacUr :: Int

     ,dzienUr :: Int

     } deriving (Show,Eq)

  

aaa = Osoba "001" "Anna" "Nowicka" 2005 5 12



bbb = Osoba{idO = "002", 

            imie = "Jan", 

            nazwisko="Balicki", 

            rokUr=2004, miesiacUr = 10, dzienUr = 12}



-- lekkie ulepszenie   



data Date = Date{rok::Int,miesiac::Int,dzien::Int} 

     deriving(Eq)

     

instance Show Date where

  show (Date r m d) = 

    (show r) ++"."++(show m)++"."++(show d)

  

data Person = Person

     {

      _idO :: String

     ,_imie :: String

     ,_nazwisko :: String

     , dataUr :: Date

     } deriving (Show,Eq)

  

ccc = Person "001" "Anna" "Balicka" (Date 2005 5 12)



zmienDate :: Person -> Date -> Person

zmienDate osoba nowaData = 

  osoba{dataUr = nowaData}



zmienRokUr :: Person ->Int -> Person

zmienRokUr osoba rokUr = 

  let urodziny  = dataUr osoba 

      urodziny' = urodziny{rok = rokUr} in 

   osoba{dataUr = urodziny'}



-- to samo - inny zapis

zmienRokUr' osoba rokUr = 

  osoba{dataUr = (dataUr osoba){rok = rokUr}}



--- Pozniej: lenses 



{-- TYPY PARAMETRYZOWALNE --}



-- MODEL KATEGORYJNY: PP (X) = X x X



data Para a = Para (a,a) deriving (Show,Eq)



-- MODEL :: jesli f:X->Y to (fmap f):(X x X) -> (Y x Y)



instance Functor Para  where

  fmap f (Para (x,y)) = Para (f x, f y)



--pmap :: (a->b) -> Para a -> Para b

--pmap f (Para (x,y)) = Para (f x, f y)



f x = 3.5 * x*(1-x)

-- uzycie: fmap f Para(0.25,0.75)

                  

{-- FUNKTOR MAYBE --}



-- data Maybe a = Nothing |  Just a

-- MODEL: MB(X) = ({0} x {*}) u ({1} x X) 

-- fmap f Nothing = Nothing

-- fmap f (Just x) = Just (f x)



safeHead []    = Nothing

safeHead (x:_) = Just x



safeSqrt x 

  | x>=0      = Just (sqrt x)

  | otherwise = Nothing 



safeLog  x 

  | x>0  = Just (log x)

  | otherwise = Nothing



safeDiv x 0 = Nothing 

safeDiv x y = Just (x/y)



-- zaczynamy partyzantkę;

-- pozniej zrobimy to lepiej



-- sqrt(log x)

composeMB :: (a-> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c)

composeMB f g x =

  case f x of 

   Nothing -> Nothing

   Just y  -> g y

 

expr1 = composeMB safeLog safeSqrt



-- (sqrt x)/log(x +1)

composeMB2 :: (a->b->Maybe c) -> Maybe a -> Maybe b -> Maybe c

composeMB2 _ Nothing _  = Nothing

composeMB2 _ _ Nothing  = Nothing

composeMB2 op (Just x) (Just y) = op x y             



expr2 x = let sn = safeSqrt x

              sd = safeLog (x^2-4) in

          composeMB2 safeDiv sn sd

Oto skompresowany katalog W5_BD.zip, z plikami którymi bawiliśmy się na wykładzie.

W6 (08.04.2025): Elementy Teorii Kategorii; wstęp do funktorów

Oto kody omawiane na wykładzie, po uwzględnieniu większości propozycji programu hlint:


module W6a where



import Data.List

import Test.QuickCheck

import Data.Char



{-- PODSTAWOWE FUNKTORY  --}



data    MAYBE  a = NOTHING | JUST a

newtype READER a b = READER{runReader:: a -> b}

newtype WRITER m a = WRITER (a, m)

  

    

instance Functor MAYBE where

  fmap _ NOTHING  =  NOTHING

  fmap f (JUST x) =  JUST (f x)

  

instance Functor (READER a) where

  fmap f (READER phi) = READER (f . phi)

    

instance Functor (WRITER m) where

  fmap f (WRITER (x,m)) = WRITER (f x, m)





{-- Zastosowanie --}



clearChar ch = let lc = toLower ch in

               if lc `elem` ['a'..'z'] then lc 

               else ' '               



toWords :: String ->[String]

toWords = words . map clearChar



filtrujSW :: [String] -> String -> [String]

filtrujSW ws stopW  = 

  let stw = words stopW in

  filter (`notElem` stw) ws



pogrupuj :: [String] -> [(String,Int)]

pogrupuj = sortBy (\ (_,k) (_,l) -> compare l k) . 

           map (\ g -> (head g,length g)) . group . sort 



topN :: [String] -> Int -> [(String,Int)]

topN xs ile = take ile (pogrupuj xs)



-- Zanurzamy obliczenia w funktor RE



type RE a = READER (String, String, Int) a

---- (book, stopwords, ile)



toWordsRE :: RE String -> RE [String]

toWordsRE = fmap toWords



filtrujRE :: RE [String] -> RE [String]

filtrujRE (READER α) =

  READER (\ (b,sw,i) -> filtrujSW (α (b,sw,i)) sw)



topNRE :: RE [String] -> RE [(String,Int)]

topNRE (READER β) =

  READER (\ (b,sw,ile) -> topN (β (b,sw,ile)) ile)



-- teraz inicjujemy proces

getBookRE :: RE String

getBookRE = READER (\(book,_,_) -> book)

-- i skladamy wszystkie funkcje

findTopNRE = (topNRE . filtrujRE . toWordsRE) getBookRE

-- Oto użycie

findTopN = runReader findTopNRE



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

  

run bookPath ile = do

  book <- readFile ("Dane/"++bookPath)

  sw   <- readFile "Dane/stop_words_english.txt" 

  print $ findTopN (book, sw, ile)

Spróbujcie sprawdzić działanie powyższego kodu wywołując w ghci
findTopN ("Ala ma kota, Ala ma psa, Ala ma kanarka", "", 4)

W7 (15.04.2025): Wstęp do funktorów

Quick Check


module W7a where

import Data.List

import Test.QuickCheck

{-- Zabawa z liczbami pierwszymi  --}

-- niezbyt efentywna funkcja

-- Zadanie: zrób to lepiej

primeQ n = 

  length ([k | k<- [1..n], n `mod` k == 0]) == 2

-- wielomian Eulera

eulerPoly n = n*n + n + 41

-- własność do przetestowania 

checkEulerPoly' :: Int -> Bool

checkEulerPoly' n = 

  primeQ (eulerPoly (abs n)) 

checkEuler' = quickCheck checkEulerPoly'

-- trochę lepiej

checkEulerPoly :: Int -> Property

checkEulerPoly n = (n>=0) ==> primeQ (eulerPoly n) 

checkEuler = quickCheck checkEulerPoly



{-- SPLIT string 

  CEL:

    split :: Char -> String -> [String]

  przykład działania:

  split '/' "data/usr/include" = ["data", "usr", "include"]

  split '/' "/usr/include/dat" = ["", "usr", "include", "dat"]

--}

split1 :: Char -> String -> [String]

split1 c [] = []

split1 c xs = 

  let x1 = takeWhile (/= c) xs

      x2 = dropWhile (/= c) xs in

  x1 : if null x2 then [] 

                  else split1 c (tail x2)



unsplit :: Char -> [String] -> String

unsplit c wx = intercalate [c] wx

 -- intercalate :: [a] -> [[a]] -> [a]



{-- 

  wlasnosc do przetestowania :

   ((unsplit c) . (split c)) xs == xs 

    kontrola liczby testów:

    quickCheck (withMaxSuccess 1000 propertyToCheck)

--}

 

propSplit1 c xs = unsplit c (split1 c xs) == xs

checkSplit1 = quickCheck (withMaxSuccess  1000 propSplit1)



-- Poprawiona funkcja SPLIT ---------------

split :: Char -> String -> [String]

split c "" = [""]

split c xs = 

  let x1 = takeWhile (/= c) xs

      x2 = dropWhile (/= c) xs in

  x1 : if null x2 then [] 

                  else split c (tail x2)

-- testowanie ze zbieraniem inforacji o testach: 

--    collect

checkSplit c xs = let ys = split c  xs in

                   collect (length ys) $ unsplit c ys == xs

                   

testSplit = quickCheck (withMaxSuccess 100000 checkSplit)



-- READ: https://jesper.sikanda.be/posts/quickcheck-intro.html

Podstawowe konstruktory danych


module W7b where

{-- PODSTAWOWE FUNKTORY  --}

-- DWA NOWE FUNKTORY



newtype STATE s x = ST (s -> (x,s))

data    EITHER a b = LEFT a | RIGHT b



instance Functor (STATE s) where

  fmap f (ST σ) = ST( \s -> let (x ,t) = σ s in (f x,t))



instance Functor (EITHER a) where

  fmap _ (LEFT x)  = LEFT x

  fmap f (RIGHT x) = RIGHT (f x)

  

-- Przykłady typów parametryzowalnych które nie są 

-- funktorami



newtype ToInt a = TInt (a->Int) 

newtype Predicate a = Pred (a->Bool)

newtype Endo  a = Endo (a->a)

  

-- Typy rekurencynje  



data SimpleTree a = Leaf a | Node (SimpleTree a) (SimpleTree a) 

     deriving (Eq)

Rozważamy odwzorowanie $F(X) = \NN + (X\times X)$ i definiujemy $F^{0} = F(\emptyset)$, $F^{n+1} = F(F^n)$. Mamy (sprawdźcie to) $$ F^0 \subseteq F^1 \subseteq F^2 \subseteq F^3 \subseteq \ldots$$ Kładziemy $F^{\omega} = \bigcup_{n\geq 0} F^n$. Mamy $F(F^\omega) = f^\omega$ (sprawdźcie to). Z tego wynika, że zbiór $F^\omega$ jest najmniejszym punktem stałym odwzorowania $F$. Ten zbiór jest izomorficzny z SimpleTree $\NN$. Tak Haskell interpretuje ten typ rekurencyjny.

W7 (15.04.2025): Wstęp do funktorów

Rekursja na drzewach


module W8a (SimpleTree (Leaf, Node),

            tree1, tree2, tree3) where



import qualified Data.Tree as T hiding (Tree)

 

-- Typy rekurencyjne  



data SimpleTree a = Leaf a | Node (SimpleTree a) (SimpleTree a) deriving (Eq)



instance Show a => Show (SimpleTree a) where

  show (Leaf x)     = "⋖" ++ show x ++ "⋗"

  show (Node t1 t2) = "("++show t1++" △ "++show t2++")"

  

tree1 = Node (Leaf 1) (Node (Leaf 2) (Leaf 3))

tree2 = Node tree1 tree1

tree3 = Node tree2 (Leaf 10)



instance Functor SimpleTree where

  fmap f (Leaf x) = Leaf (f x)

  fmap f (Node t1 t2) = Node (fmap f t1) (fmap f t2)



height :: SimpleTree a -> Int

height (Leaf _)  = 0

height (Node t1 t2) = 1 + max (height t1) (height t2)



flipTree :: SimpleTree a -> SimpleTree a

flipTree (Leaf x) = Leaf x

flipTree (Node t1 t2) = Node t2 t1



symmetricTreeQ :: (Eq a) => SimpleTree a -> Bool

symmetricTreeQ t = t == flipTree t



minheight :: SimpleTree a -> Int

minheight (Leaf _)  = 0

minheight (Node t1 t2) = 1 + min (height t1) (height t2)



balancedTreeQ :: SimpleTree a -> Bool

balancedTreeQ t = (abs (height t) - (minheight t)) <= 1



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

-- przegladanie wszerz

bfsTree :: SimpleTree a -> [a]

bfsTree t = bfsT []

  where

    bfsT :: [SimpleTree a] -> [a] 

    bfsT [] = []

    bfsT ts  = concat (map extractVals ts) ++ 

               bfsT   (concat (map extractNodes ts))

    

    extractVals :: SimpleTree a -> [a]

    extractVals (Leaf x)   = [x]

    extractVals (Node _ _) = []

    

    extractNodes :: SimpleTree a -> [SimpleTree a]

    extractNodes (Leaf _) = []

    extractNodes (Node t1 t2) = [t1,t2]



--- alternatywne wyświetlanie drzewa

--- za pomocą modułu Data.Tree



toDataTree (Leaf a) = T.Node a []

toDataTree (Node cs ds) = T.Node [] [toDataTree cs, toDataTree ds]



showTree t = putStrLn $ T.drawTree (toDataTree (fmap show t))

Semigrupy i monoidy

Funkcjonalnie równoważna implementacja podstawowych monoidów języka Haskell:


{-# LANGUAGE DataKinds #-}

module W8b where



import W8a

import Prelude hiding (Semigroup, Monoid,mempty,(<>))





class Semigroup m where

  (<>) :: m -> m -> m

--wymaganie: <> musi być łączne



class Semigroup m => Monoid m where

  mempty:: m

-- wymagania : 

--   1. mempty <> x = x

--   2. x <> mempty = x



instance Semigroup [a] where

  (<>) = (++)

instance Monoid [a] where

  mempty = []



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

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

newtype Min a = Min { getMin :: a}  deriving ( Bounded,

                                    Eq, Ord, Show, Read)

newtype Max a = Max { getMax :: a}  deriving ( Bounded,

                                    Eq, Ord, Show, Read)

newtype Endo a = Endo { getEndo:: a->a}



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

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



newtype Option a = Option { getOption:: Maybe a }



newtype Last a   = Last { getLast :: a}



instance Num a => Semigroup (Sum a) where

  Sum x <> Sum y = Sum (x+y)

instance Num a => Monoid (Sum a) where

  mempty = Sum 0



instance Num a => Semigroup (Product a) where

  (Product x) <> (Product y) = Product (x * y)

instance Num a => Monoid (Product a) where

  mempty = Product 1



instance Ord a => Semigroup (Min a) where

  (Min x) <> (Min y) = Min (min x y)

instance (Ord a,Bounded a) => Monoid (Min a) where

  mempty = Min maxBound



instance (Ord a) => Semigroup (Max a) where

  (Max x) <> (Max y) = Max (max x y)

instance (Ord a, Bounded a) => Monoid (Max a) where

  mempty = Max minBound



instance Semigroup (Endo a) where

  (Endo f) <> (Endo g) = Endo (f . g)

instance Monoid (Endo a) where

  mempty = Endo id



instance Semigroup All where

  (All b1) <> (All b2) = All (b1 && b2)

instance Monoid All where

  mempty = All True



instance Semigroup Any where

  (Any b1) <> (Any b2) = Any (b1 || b2)

instance Monoid Any where

  mempty = Any False

  

instance Semigroup (Last a) where

  _ <> b = b

instance Monoid (Last (Maybe a)) where

  mempty = Last Nothing



-- Konstrukcje monoidow

instance (Semigroup a, Semigroup b) => Semigroup (a,b) where

  (a,b) <> (a',b') =(a<>a', b<>b') 

instance (Monoid a, Monoid b) => Monoid (a,b) where

  mempty = (mempty,mempty) 



newtype Dual a = Dual { getDual :: a }

        deriving ( Eq, Ord, Read, Show, Bounded)        

instance Semigroup a => Semigroup (Dual a) where

  Dual a <> Dual b = Dual (b <> a)

instance Monoid a => Monoid (Dual a) where

  mempty = Dual mempty

Klasa Foldable

Robimy z funktora SompleTree instancję klasy foldable:


module W8b where



import W8a

import Data.Monoid

import Data.Foldable





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

-- foldMap :: Monoid m => (a -> m) -> f a -> m 

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



instance Foldable SimpleTree  where

  foldMap f (Leaf x) = f x

  foldMap f (Node t1 t2) = 

    (foldMap f t1) <> (foldMap f t2)



-- toList

-- length

-- maximum

-- minimum

-- sum

-- product 

-- mconcat :: Monoid a => [a] ->a

-- foldr

---- foldr (\x acc -> show(x)++" |"++acc) "]" tree3



-- UWAGA: wyjatek treminologiczny: appEndo



filterMB :: (a->Bool) -> a -> Maybe a

filterMB p x = if p x then (Just x) else Nothing



findLast p xs =  getLast $ foldMap (Last) $ fmap (filterMB p) xs



{-

-- instance Foldable SimpleTree where

foldr :: (a->b->b) -> b -> SimpleTree a -> b

foldr f z (Leaf x) = f x z

foldr f z (Node t1 t2) = let fdr = foldr f z t2 in

                         foldr f fdr t1

-}

W9 (06.05.2025): Transformacje naturalne

Przykłady transformacji naturalnych


module W9a where



import Data.Monoid



newtype V2 a = V2 (a,a) deriving (Eq, Show)

instance Functor V2  where

  fmap f (V2 (x1, x2)) = V2 (f x1, f x2)



{-- Transformacje naturalne --}



-- V2

idToV2 :: a -> V2 a

idToV2 x = V2 (x, x)



v2First :: V2 a -> a

v2First (V2 (x, _)) = x



v2Second :: V2 a -> a

v2Second (V2 (_, y)) = y



v2Flip :: V2 a -> V2 a

v2Flip (V2 (x, y)) = V2 (y, x)



v2ToV2a :: V2 a -> V2 a 

v2ToV2a (V2 (x, _)) = V2 (x, x)



v2ToV2b :: V2 a -> V2 a 

v2ToV2b (V2 (_,y)) = V2 (y,y)



-- Włożenia: Id -> List; Maybe

idToList :: a -> [a]

idToList x = [x]



idToMaybe :: a -> Maybe a

idToMaybe  = Just 



-- Maybe -- List

maybeToList :: Maybe a -> [a]

maybeToList (Just x) = [x]

maybeToList Nothing = []



listToMaybe :: [a] -> Maybe a

listToMaybe [] = Nothing

listToMaybe (x:_) = Just x



-- Writer

data MyWriter m a = (Monoid m) => W {runWriter:: (a, m)}



instance Functor (MyWriter m) where

  fmap f (W (x,y)) = W (f x, y)



idToWriter :: (Monoid m) => a -> MyWriter m a

idToWriter x = W (x,mempty)  



-- iloczyny kartezjanskie



--alpha:: ((a,b),c) -> (a,(b,c))

alpha ((x,y),z) = (x,(y,z))

alpha' (x,(y,z)) = ((x,y),z)



--lambda :: ((),a) -> a

lambda ((),x) = x

lambda' x = ((),x)



--rho :: (a,()) -> a

rho (x,()) = x

rho' x = (x,())



-- TEGO NIE BYŁO NA WYKŁADZIE (ale będzie)

-- Złożenie pionowe transformacji naturalnych

--   v2First   :: V2 -> Id

--   idToMaybe :: Id -> Maybe



v2ToMb :: V2 a -> Maybe a

v2ToMb = idToMaybe . v2First



-- Złożenie poziome transformacji naturalnych

--   idToMaybe :: Id -> Maybe

--   idToV2    :: Id -> V2



idToV2MB :: a -> V2 (Maybe a)

idToV2MB = idToV2 . idToMaybe

Funktory monoidalne


module W9b where

 

class Functor f => Monoidal f where

  unit :: f ()

  (<:>) :: f a -> f b -> f (a,b)

-- wymagania

-- 1.  unit <:> fa ≅ fa  /via fmap lambda

-- 2.  fa <:> unit ≅ fa  /via fmap rho

-- 3.  (fa <:> fb) <:> fc ≅ fa <:> (fb <:> fc)

-- 4.  (fmap φ fa) <:> (fmap ψ fb) = 

--       fmap (φ x ψ) (fa <:> fb)

-- gdzie (φ x ψ)(x,y) = (φ x, ψ y)

Jacek Cichoń

2024/25 (lato): Programowanie Funkcyjne

Literatura

Zasady zaliczania kursu

Zagadnienia omówione na wykładzie

W1 (04.03.2025): GHCI i funkcje

W2 (11.03.2025): Podstawowe typy

W3 (18.03.2025): Sortowania; zip'y; foldy

W4 (25.03.2025): Foldy, strumienie, wstęp do typów

Zastosowania foldów i strumienie

Konstrukcja "type"

Konstrukcja "data" - wstęp

W5 (01.04.2025): Typy, wstęp do funktorów

Zastosowania foldów i strumienie

W6 (08.04.2025): Elementy Teorii Kategorii; wstęp do funktorów

W7 (15.04.2025): Wstęp do funktorów

Quick Check

Podstawowe konstruktory danych

W7 (15.04.2025): Wstęp do funktorów

Rekursja na drzewach

Semigrupy i monoidy

Klasa Foldable

W9 (06.05.2025): Transformacje naturalne

Przykłady transformacji naturalnych

Funktory monoidalne