$
\def\RR{\mathbb{R}}
\def\QQ{\mathbb{Q}}
\def\ZZ{\mathbb{Z}}
\def\CC{\mathbb{C}}
\def\NN{\mathbb{N}}
\def\IFF{\leftrightarrow}
\newcommand{\span}[1]{\mathrm{span}(#1)}
\newcommand{\IS}[2]{\langle\,#1,#2\rangle}
\newcommand{\sgn}[1]{\mathrm{sgn}(#1)}
$
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)
W10 (13.05.2025): Funktory monoidalne i aplikatywne
Funktory monoidalne
module W10a where
import Data.Monoid
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 ψ)(a,b) = (φ a, ψ b)
-- V2
newtype V2 a = V2 (a,a) deriving (Eq, Show)
instance Functor V2 where
fmap f (V2 (x1, x2)) = V2 (f x1, f x2)
instance Monoidal V2 where
unit = V2 ((),())
(V2 (x1,x2)) <:> (V2 (y1,y2)) =
V2 ((x1,y1),(x2,y2))
-- MAYBE
instance Monoidal Maybe where
unit = Just ()
mbx <:> mby = case (mbx,mby) of
(Just x, Just y) -> Just (x,y)
otherwise -> Nothing
-- LISTY
instance Monoidal [] where
unit = [()]
[] <:> _ = []
(x:xs) <:> y = (map (\t->(x,t)) y ) ++ (xs<:>y)
-- ZIP LISTY
newtype ZipList a = ZL [a] deriving (Eq,Show)
instance Functor ZipList where
fmap f (ZL xs) = ZL (fmap f xs)
instance Monoidal ZipList where
unit = ZL (repeat ())
(ZL xs) <:> (ZL ys) = ZL (zip xs ys)
-- WRITER
data MyWriter m a = MyWriter{ getWriter:: (a,m)}
instance Functor (MyWriter m) where
fmap f (MyWriter (x,t)) = MyWriter (f x, t)
instance (Monoid m) => Monoidal (MyWriter m) where
unit = MyWriter ((),mempty)
(MyWriter (x,m)) <:> (MyWriter (y,n)) =
MyWriter ((x,y), m <> n)
-- STATE
data MyState s a = ST {getState:: s->(a,s)}
instance Functor (MyState s) where
fmap f (ST φ) = ST(\s -> let (x,t) = φ s in (f x, t))
instance Monoidal (MyState s) where
unit = ST(\t-> ((),t))
(ST φ) <:> (ST ψ) =
ST(\t -> let (x,r) = φ t
(y,u) = ψ r in
((x,y),u)
)
-- ITD ...
data CONT a = CONT (a -> Int) deriving (Functor)
Funktory aplikatywne
module W10b where
import Data.Monoid
import Control.Applicative
import Data.Foldable
-- class Functor f => Applicative f where
-- pure :: a -> f a
-- (<*>) :: f (a ->b) -> f a -> f b
-- wymagania
-- 1. pure id <*> u = u
-- 2. pure f <*> pure x = pure (f x)
-- 3. u <*> pure y = pure ($ y) <*> u
-- 4. pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
-- <*> : infixl 4
-- liftA2 :: (a -> b -> c) -> f a -> f b -> f c
-- liftA2 op x y = (pure op) <*> x <*> y =
-- (fmap op x) <*> y
newtype MyList a = L [a] deriving (Eq, Show)
instance Functor MyList where
fmap f (L xs) = L (f <$> xs)
instance Applicative MyList where
pure x = L [x]
(L fs) <*> (L xs) = L [f x | f<- fs, x <- xs]
-- (L []) <*> _ = L []
-- (L (f:fs)) <*> (L xs) = let L ys = (L fs) <*> (L xs) in
-- L ((f <$> xs)++ys)
newtype MyZL a = ZL [a] deriving (Eq, Show)
instance Functor MyZL where
fmap f (ZL xs) = ZL (f <$> xs)
instance Applicative MyZL where
pure x = ZL (repeat x)
(ZL fs) <*> (ZL xs) = ZL (zipWith (\f x-> f x) fs xs)
-- V3
newtype V3 a = V3 (a,a,a) deriving (Eq, Show)
instance Functor V3 where
fmap f (V3 (x1, x2, x3)) = V3 (f x1, f x2, f x3)
instance Foldable V3 where
foldMap f (V3 (x,y,z)) = mconcat (f <$> [x,y,z])
instance Applicative V3 where
pure x = V3 (x, x, x)
(V3 (f, g, h)) <*> (V3 (x, y, z)) = V3 (f x, g y, h z)
-- WRITER
newtype MyWriter m a = MyWriter{ getWriter:: (a,m)}
instance Functor (MyWriter m) where
fmap f (MyWriter (x,t)) = MyWriter (f x, t)
instance (Monoid m) => Applicative (MyWriter m) where
pure x = MyWriter (x,mempty)
(MyWriter (f, m)) <*> (MyWriter (x, n)) =
MyWriter (f x , m <> n)
-- STATE
newtype MyState s a = ST {getState:: s->(a,s)}
instance Functor (MyState s) where
fmap f (ST φ) = ST(\s -> let (x,t) = φ s in (f x, t))
instance Applicative (MyState s) where
pure x = ST(\t-> (x, t))
(ST f) <*> (ST σ) =
ST(\t -> let (φ, r) = f t
(x, u) = σ r in
(φ x ,u)
)
-- ITD ...
addMaybe :: Maybe Int -> Maybe Int -> Maybe Int
addMaybe = liftA2 (+)
addV3 :: V3 Double -> V3 Double -> V3 Double
substrV3 :: V3 Double -> V3 Double -> V3 Double
normV3 :: V3 Double -> Double
odlV3 :: V3 Double -> V3 Double -> Double
addV3 = liftA2 (+)
substrV3 = liftA2 (-)
normV3 v2 = sqrt.sum $ (^2) <$> v2
odlV3 v w = normV3 $ substrV3 v w
colors = ["red", "blue"]
objects = ["dom","samochod"]
-- combinations = (,) <$> colors<*>objects
combinations = liftA2 (,) colors objects
Ewaluator - I
module W9a where
import Data.Monoid
import Data.Foldable
import Data.Functor.Identity
import Control.Applicative
data Lang a = L a |
S (Lang a) | -- sqrt
P (Lang a) (Lang a)| -- plus
M (Lang a) (Lang a)| -- multiply
D (Lang a) (Lang a) -- divide
deriving (Eq, Functor)
instance Show a => Show (Lang a) where
show (L a) = show a
show (S t) = "√("++show t ++")"
show (P t1 t2) = "" ++show t1++"+"++show t2++""
show (M t1 t2) = "("++show t1++"*"++show t2++")"
show (D t1 t2) = "("++show t1++"/"++show t2++")"
{-
instance Functor Lang where
fmap f (L x) = L (f x)
fmap f (S t) = S (fmap f t)
fmap f (P t1 t2) = P (fmap f t1) (fmap f t2)
fmap f (M t1 t2) = M (fmap f t1) (fmap f t2)
fmap f (D t1 t2) = D (fmap f t1) (fmap f t2)
-}
term x y = D (S( P (L x) (L y))) (M (L y) (L x))
-- TRYWIAŁ
eval0 :: Lang Double -> Double
eval0 (L x) = x
eval0 (S t) = sqrt (eval0 t)
eval0 (P t1 t2) = (eval0 t1) + (eval0 t2)
eval0 (M t1 t2) = (eval0 t1) * (eval0 t2)
eval0 (D t1 t2) = (eval0 t1) / (eval0 t2)
-- ZACZYNAMY WYKORZYSTYWAĆ SIŁĘ FUNKTORÓW APLIKATYWNYCH
eval :: (Applicative f) => Lang (f Double) -> f Double
eval (L x) = x
eval (S t) = fmap sqrt (eval t)
eval (P t1 t2) = liftA2 (+) (eval t1) (eval t2)
eval (M t1 t2) = liftA2 (*) (eval t1) (eval t2)
eval (D t1 t2) = liftA2 (/) (eval t1) (eval t2)
W11 (20.05.2025): Funktory aplikatywne i wstęp do monad
Funktory aplikatywne
module W11aa where
import Data.Functor.Identity
import Control.Applicative
-- LIFTUJEMY DZIAŁANIA DO Maybe Double
mbSqrt:: Maybe Double -> Maybe Double
mbSqrt (Just x) = if x<0 then Nothing else pure (sqrt x)
mbSqrt Nothing = Nothing
mbDiv :: Maybe Double -> Maybe Double -> Maybe Double
mbDiv mbx mby = if mby == Just 0 then Nothing
else liftA2 (/) mbx mby
data Term a = LL a |
VAR String |
SQRT (Term a) |
PLUS (Term a) (Term a) |
MULT (Term a) (Term a) |
DIV (Term a) (Term a)
deriving (Eq, Show, Functor)
-- Budujemy ewaluator evalTerm
evalTerm :: (Applicative f) =>
Term (f (Maybe Double)) ->
(String -> f (Maybe Double)) ->
f (Maybe Double)
evalTerm (LL x) env = x
evalTerm (VAR v) env = env v
evalTerm (SQRT t) env = fmap mbSqrt (evalTerm t env)
evalTerm (PLUS t1 t2) env = liftA2 (liftA2 (+)) (evalTerm t1 env) (evalTerm t2 env)
evalTerm (MULT t1 t2) env = liftA2 (liftA2 (*)) (evalTerm t1 env) (evalTerm t2 env)
evalTerm (DIV t1 t2) env = liftA2 mbDiv (evalTerm t1 env) (evalTerm t2 env)
-- Obsługa list zmiennych
newtype ListaVar f = LV { getListVar :: [(String, f (Maybe Double))] }
getVar ::(Applicative f) =>
ListaVar f -> String -> f (Maybe Double)
getVar (LV []) _ = pure Nothing
getVar (LV ((x,v):ls)) var = if x==var then v
else getVar (LV ls) var
runTerm :: (Applicative f) =>
Term (f (Maybe Double)) -> ListaVar f -> f (Maybe Double)
runTerm term subst = evalTerm term (getVar subst)
---- Fukktor f = Identity
term01 :: Term (Identity (Maybe Double))
--term01 = PLUS (SQRT (PLUS (VAR "x") (VAR "y"))) (LL (Identity (Just 100)))
term01 = PLUS (SQRT (PLUS (VAR "x") (VAR "y"))) (LL ((pure.pure) 100))
substId :: ListaVar Identity
substId = LV [("x",Identity (Just 2)),
("y",Identity (Just 2))]
-- runIdentity $ runTerm term01 subst
---- f = []
term02 :: Term [Maybe Double]
term02 = PLUS (VAR "x") (VAR "y")
substL :: ListaVar []
substL = LV [("x", [Just 1,Just 5]),
("y",[Just 100, Just 200])]
-- FUNKTORY Z KTÓREGO NIE MOŻNA ZROBIĆ APPLICATIVE
newtype PP a = PP ((a->Int)-> Maybe a)
instance Functor PP where
fmap f (PP phi) =
PP (\alpha -> fmap f (phi (alpha . f)))
-- Trochę mniej trywialna sprawa
-- ROBIMY APPLICATIVE Z SIMPLE TREE
data ST a = V a | N (ST a) (ST a) deriving (Eq, Functor)
instance Show a => Show (ST a) where
show (V a) = show a
show (N t1 t2) = "("++show t1++"⋏"++show t2++")"
instance Applicative ST where
pure = V
(V f) <*> (V x) = V (f x)
(V f) <*> (N t1 t2) = N ( V f <*> t1) (V f <*> t2)
(N t1 t2) <*> t = N (t1 <*> t) (t2 <*> t)
-- Przykłady "prostych drzew"
st1 = N (N (V 1) (V 2)) (V 3)
st2 = N (V 10) (V 20)
-- operacja monoidalna
(<:>) :: ST a -> ST b -> ST (a,b)
t1 <:> t2 = liftA2 (,) t1 t2
-- testy:
-- st1 <:> st2
-- st2 <:> st1
Zaczynamy monady
module W11b where
import Data.Monoid
import Data.Foldable
import Data.Functor.Identity
import Control.Applicative
import Control.Monad
data MyMaybe a = Nic | OK a deriving (Eq, Show, Functor)
instance Applicative MyMaybe where
pure x = OK x
(OK f) <*> (OK x) = OK (f x)
_ <*> _ = Nic
-- CEL: wzmocnienie Maybe o operację >>= typu
-- (>>=) :: m a -> (a -> m b) -> m b
instance Monad MyMaybe where
return = pure
(OK x) >>= f = f x
Nic >>= _ = Nic
-- derived :
-- (>>) :: m a -> m b -> mb
-- mx >> my = mx >>= (\_ -> my)
-- Kleisli composition; FISH
-- (>=>):: (a-> m b) -> (b -> mc) -> (a -> mc)
-- f >=> g = (\x -> (f x)>>= g)
-- mx >>= f = (id >=> f) mx
mbSqr, mbScc, mbLog :: (Floating a, Ord a) =>
a -> Maybe a
mbSqr x = Just (x*x)
mbScc x = Just (x+1)
mbLog x = if x<0 then Nothing else Just (log x)
-- Just 1 >>= mbLog >>= mbScc
{--
ROBIMY TERAZ TAKIE ZADANIE :
INPUT : listy xs, ys
OUTPUT : (head xs, head ys)
--}
safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead (x:_) = Just x
-- rozwiązanie "ręczne"
h0 xs ys = let hx = safeHead xs
hy = safeHead ys
in case (hx, hy) of
(Just s, Just t) -> Just (s,t)
_ -> Nothing
-- składamy za pomocą >>=
h1 xs ys = safeHead xs >>=
(\s -> (safeHead ys)>>=
(\t -> Just (s,t))
)
-- h1 inaczej zapisane
h2 xs ys = safeHead xs >>= \s ->
safeHead ys >>= \t ->
return (s,t)
-- h2 za pomocą notacji do
h xs ys = do
s <- safeHead xs
t <- safeHead ys
return (t,s)
-- WYMAGANIE STAWIANE MONADOM
-- Zgodność z Applicative
-- mfxy <*> mx = do f <- mfxy
-- x <- mx
-- return (f x)
-- CZYLI
-- mfxy<*>mx = mfxy >>= (\f->mx >>= (\x -> return (f x)))
-- ORAZ KILKA INNYCH : to omówimy później
newtype MyList a = L{getList:: [a]} deriving (Eq,Show, Ord, Functor)
instance Applicative MyList where
pure x = L [x]
(L fxy) <*> (L lx) = L [f x | f<-fxy, x<-lx]
instance Monad MyList where
-- return = pure
(L xs) >>= f = L (concat $ map (\x -> getList (f x)) xs)
W12 (27.05.2025): Monada Writer
Desugaryzacja notacji do
do mx ===> mx
do {mx; stmts} ===> mx >> (do stmts)
do {x<- mx; stmts} ===> mx >>= (\x -> (do stmts})
do {let decl;stmts} ===> let decl in (do stmts)
Równoważna implementacja monady Writer
{-# LANGUAGE FunctionalDependencies #-}
{--
Implementujemy swoją
wersję monady Writer, która jest funkcjonalnie
rownoważnana implementacji w biliotekach Haskell'a
--}
module W12a where
import Data.Monoid
import Data.Semigroup
import Data.Foldable
-- CIEKAWOSTKA:
-- monotonic sublists
msublists [] = [[]]
msublists (x:xs) = do
t <- [False,True]
y <- msublists xs
return (if t then x:y else y)
-- MONADA Writer
newtype MyWriter m a
= W {runW :: (a,m)}
deriving (Eq,Show,Functor)
instance (Monoid m) => Applicative (MyWriter m) where
pure x = W (x,mempty)
(W (f,m)) <*> (W (x,n)) = W (f x, m <> n)
instance (Monoid m) => Monad (MyWriter m) where
return = pure
(W (x,s)) >>= f = let W (y,t) = f x in
W (y, s <> t)
trSin x = W (sin x, "sin;")
trSqr x = W (x^2 , "sqr;")
trScc x = W (x+1 , "scc;")
instance Foldable (MyWriter m) where
foldMap f (W wx ) = (f.fst) wx
-- liczmy (>>) :: m a -> m b -> m b
-- wx >> wy = wx >>= (\_ -> wy)
--
-- W (x,m) >> W (y,n) =
-- W (x,m) >>= (\_ -> W(y,n))) =
-- let W (z,w) = (\_-> W(y,n)) x in
-- W (z, m <> w)
-- = let W (z,w) = W (y,n) in W (z, m <> w)
-- = W (y, m <> n)
plusInDo mx my =
do {x<-mx;y<-my;return (x+y)}
{-- FUNKCJA COLLATZ'a --}
collatz :: Int -> MyWriter [Int] Int
collatz 1 = W (1,[1])
collatz n = W (0,[n]) >>
if even n then collatz (n `div` 2)
else collatz (3*n+1)
{- Obudowujemy Monadę MyWriter -}
class (Monoid w, Monad m) => MyMonadWriter w m | m -> w where
writer :: (a,w) -> m a
tell :: w -> m ()
listen :: m a -> m (a, w)
pass :: m (a, w->w) -> m a
instance (Monoid m) => MyMonadWriter m (MyWriter m) where
writer (x, w) = W (x, w)
tell w = W ((),w)
listen (W (x,w)) = W ((x,w),w)
pass (W ((x,f),w)) = W (x, f w)
Korzystanie z monady Writer
{--
Korzystamy z systemowej implementacji
monady Writer
--}
module W12b where
import Data.Monoid
import Data.Semigroup
import Control.Monad.Writer
import Data.List
traceSin,traceSqr, traceInc :: Double -> Writer String Double
traceSin x = writer (sin x, "sin;")
traceSqr x = writer (x^2 , "sqr;")
traceInc x = writer (x+1 , "inc;")
{-- FUNKCJA COLLATZ'a --}
collatz :: Int -> Writer [Int] Int
collatz 1 = writer (1,[1])
collatz n = tell [n] >> if even n then
collatz (n `div` 2)
else
collatz (3*n+1)
coll :: Int -> Writer ([Int], Sum Int, Max Int) Int
coll n
| n <= 1 = do {tell ([1], Sum 1, Max 1); return 1}
| even n = do {tell ([n], Sum 1, Max n); coll (n `div` 2)}
| otherwise = do {tell ([n], Sum 1, Max n); coll (3*n+1)}
{-- GCD --}
myGCD :: Int -> Int -> Writer [String] Int
myGCD a b
| b == 0 = do tell [show a]
return a
| otherwise = do tell [show (a,b)]
myGCD b (a `mod` b)
{-- WSPOŁCZYNNIKI NEWTONA --}
{--uwaga nie sprawdzam warunku k<0 lub k>n --}
{-- zakładamy, że n>=0 --}
binom :: Int -> Int -> Writer (Dual String) Int
binom n k = if k==0 || k==n then
writer (1, Dual "")
else
do t <- binom (n-1) (k-1);
tell (Dual (mconcat ["(",show n,"/",show k,")*"]))
return ((n * t) `div` k)
{-- LICZBY STRILINGA --}
st n k | n < k = 0
| n == k = 1
| k == 0 = 0
| n == 0 = 0
| otherwise = k * (st (n-1) k) + (st (n-1) (k-1))
stir :: Integer -> Integer -> Writer String Integer
stir n k
| n < k = tell (show (n,k)) >> return 0
| n == k = tell (show (n,k)) >> return 1
| n == 0 = tell (show (n,k)) >> return 0
| k == 0 = tell (show (n,k)) >> return 0
| otherwise = do
tell (show (n,k))
sn1 <- stir (n-1) k
sn2 <- stir (n-1) (k-1)
return (k * sn1 + sn2 )
stirling :: Integer -> Integer -> Writer String Integer
stirling n k
| n < k = tell (show (n,k)) >> return 0
| n == k = tell (show (n,k)) >> return 1
| n == 0 = tell (show (n,k)) >> return 0
| k == 0 = tell (show (n,k)) >> return 0
| k == 1 = tell (show (n,k)) >> return 1
| k == n-1 = tell (show (n,k)) >> return (n*(n-1) `div` 2)
| k == 2 = tell (show (n,k)) >> return (2^(n-1) - 1)
| otherwise = do
tell (show (n,k)++">")
sn1 <- stirling (n-1) k
sn2 <- stirling (n-1) (k-1)
return (k * sn1 + sn2 )
{--
COŚ W RODZAJU TYPOWEGO
PROBLEMU KORPORACYJNEG
--}
type Stream = [(Int,[Int])]
badStream = [(1,[5,3]), (2,[4,2,1]), (3,[2,2])
, (4,[1]), (5,[])] :: Stream
goodStream = [(1,[4,3]), (2,[3,2,1]), (3,[2,2])
, (4,[1]), (5,[])] :: Stream
check01 :: Stream -> Bool
check01 [] = True
check01 ((x,li):ls) = all (<=length ls) li && check01 ls
-- testy : :set +s
check02 :: Stream -> Bool
check02 ls = check03 (length ls) ls
where check03 _ [] = True
check03 n ((x,li):ls) =
if all (<n) li then
check03 (n-1) ls
else
False
{-- niespodzianka: dodatkowa funkcjonalność --}
type Graph = [(Int,Int)]
checkW :: Stream -> Writer Graph Bool
checkW ls = checkW01 (length ls) ls
where
checkW01 :: Int -> Stream -> Writer Graph Bool
checkW01 _ [] = return True
checkW01 n ((x,li):ls) = do
tell [(x,i)| i <- li]
if all (< n) li then
checkW01 (n-1) ls
else
return False
W13 (03.06.2025): Monada State
Prawa monad
(A1) (mx >>= return) = mx
(A2) ((return x) >>= f) = f x
(A3) ((mx >>= f) >>= g) = (mx >>= (\x -> (f x) >>= g))
(A4) (mf <*> mx) = do {f<- mf; x<- mx; return (f x)}
Złożenie kleisli'ego
(>=>) :: (a -> m b) -> (b-> m c) -> (a -> mc)
f >=> g = (\x -> (f x) >>= g))
Prawa monad wyrażone w języku złożenia Kleisliego
(A1) (f >=> return) = f
(A2) (return >=> f) = f
(A3) ((f >=> g) >>= h) = (f >>= (g -> h))
Implementacja monady State i przyklady wykorzystania
{-# LANGUAGE FlexibleInstances #-}
{--
Implementujemy swoją wersję monady Writer, która jest funkcjonalnie
rownoważnana implementacji w biliotekach Haskell'a
--}
module W13a where
import Control.Monad.State
import Data.List
import Data.Char
import qualified Data.Map as Map
data MyState s a = ST (s -> (a,s))
instance Functor (MyState s) where
fmap f (ST( phi)) = ST (\s-> let (x,t) = phi s in (f x, t))
instance Applicative (MyState s) where
pure x = ST (\s -> (x,s))
(ST phi) <*> (ST st) =
ST (\s -> let (f,t) = phi s; (z,r) = st t in (f z, r))
instance Monad (MyState s) where
(ST st) >>= f =
ST (\s -> let (x,t) = st s
ST phi = f x
in phi t)
-- class Monad m => MonadState s m| m -> s where
-- get :: m s -- | Return the state from the internals of the monad.
-- put :: s -> m () -- | Replace the state inside the monad.
-- state :: (s->(a,s)) -> m a
instance MonadState s (MyState s) where
get = ST (\s -> (s,s))
put s = ST (\_ -> ((),s))
state f = ST f
---------------------------------------
-- OD TEJ PORY POSLUGUJEMY SIĘ WBUDOWANĄ
-- MONADA State
---------------------------------------
type Stos = [Int]
push :: Int -> State Stos ()
push n = state (\s -> ((),n:s))
pop :: State Stos Int
pop = state (\s -> (head s,tail s))
top :: State Stos Int
top = state (\s -> (head s,s))
plus :: State Stos ()
plus = do x <- pop
y <- pop
push (x + y)
mult :: State Stos ()
mult = do x <- pop
y <- pop
push (x * y)
prog = do push 2
push 5
push 8
x<- pop
y<- pop
push (x - y)
mult
pop
-- > (runState prog) []
-----------------------------------
data Tree a = Leaf a | Node (Tree a) (Tree a)
deriving (Show)
labelTree :: Tree a -> State Int (Tree (a, Int))
labelTree (Leaf x) = do
n <- get
put (n + 1)
return (Leaf (x, n))
labelTree (Node l r) = do
l' <- labelTree l
r' <- labelTree r
return (Node l' r')
testTree = Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c'))
-- > fst $ runState (labelTree testTree) 0
{- Liniowy kongruencyjny generator liczb pseudo-losowych --}
type Seed = Int
nextInt :: State Seed Int
nextInt = do
seed <- get -- Pobierz aktualne ziarno
let newSeed = (a * seed + b) `mod` m -- Oblicz nowe ziarno (a, c, m to stałe)
put newSeed -- Zaktualizuj stan na nowe ziarno
return newSeed -- Zwróć wygenerowaną liczbę (w tym przypadku jest to nowe ziarno, ale można zwrócić coś innego)
-- Przykładowe stałe dla generatora
a = 1664525 :: Int
b = 1013904223 :: Int
m = 2^32 :: Int
initSeed = 42 :: Int
-- Generowanie jednej liczby
generateOne :: Seed -> (Int, Seed)
generateOne initialSeed = runState nextInt initialSeed
-- > fst $ generateOne initSeed
-- Generowanie wielu liczb
genMany :: Int -> State Seed [Int]
genMany 0 = return []
genMany n = do
res <- nextInt
rest<- genMany (n-1)
return (res:rest)
-- przykład użycia:
-- > (runState $ genMany 5) initSeed
-------------------------------------------
{-- Maszyna Turinga --}
type Tape = (String, Char, String) -- (lewa strona, aktualny znak, prawa strona)
data Direction = L | R deriving (Show)
type StateName = String
type Transition = ((StateName, Char), (StateName, Char, Direction))
type Program = Map.Map (StateName, Char) (StateName, Char, Direction) -- hash table
data TMState = TMState {
tape :: Tape,
currentState :: StateName
} deriving (Show)
oneStep :: Program -> State TMState Bool
oneStep prog = do
TMState (ls, ch, rs) stan <- get
case Map.lookup (stan, ch) prog of
Nothing -> return False -- brak przejścia: zatrzymaj się
Just (newState, newSym, dir) -> do
let newTape = case dir of
L -> case ls of
[] -> ([], '_', newSym:rs)
(l:ls) -> (ls, l, newSym:rs)
R -> case rs of
[] -> (ls ++ [newSym], '_', [])
(r:rs) -> (ls ++ [newSym], r, rs)
put $ TMState newTape newState
return True
runTM :: Program -> State TMState ()
runTM prog = do
continue <- oneStep prog
if continue then
runTM prog
else
return ()
simpleProgram :: Program
simpleProgram = Map.fromList [
(("start", '0'), ("start", '1', R)),
(("start", '1'), ("start", '0', R)),
(("start", '_'), ("halt", '_', R))
]
initTape :: Tape
initTape = ([], '1', "0101_") -- '_' oznacza koniec taśmy
initState :: TMState
initState =
TMState initTape "start"
--runTuring :: Program -> TMState
runTuring prog = snd $ runState (runTM prog) initState
-- > runTuring simpleProgram
--------------------------------------------
{-- Prosty model monady ograniczony tylko
do kanałow stdin i stdout
MyIO
--}
type World = ([Char],[Char]) -- (input,output)
-- podstawowe operacje wyjścia
myPutChar :: Char -> State World ()
myPutChar ch =
state ( \(inp,out) -> ((),(inp,ch:out)) )
myPutStr :: String -> State World ()
myPutStr [] = return ()
myPutStr (c:cs) = myPutChar c >> myPutStr cs
myPutStrLn cs = myPutStr cs >> myPutChar '\n'
myPrint :: Show a => a -> State World ()
myPrint x = myPutStrLn (show x)
-- podstawowe operacje wejścia
myGetChar :: State World Char
myGetChar =
state $ \(inp,out) -> if inp=="" then
('\n',("",out))
else
(head inp, (tail inp, out))
myGetLine :: State World String
myGetLine = do
c <- myGetChar
if c =='\n' then return ""
else do
str<- myGetLine
return (c:str)
myIOProg = do
myPutStr "Jak ci na imie ?"
txt <- myGetLine
myPutStrLn $ "Hello " ++ txt
-- > (runState myIOProg) ("Jacek\nCichon","")
W14 (10.06.2025): Monada IO
Uwaga: w kodach dzisiaj przedstawionych jest sporo "nieporadności".
Zostawiłem je aby ułatwić interpretację. Na ostatnim wykładzie omówimy kilka metod ulepszenia tych kodów poprzez stosowanie bardziej abstrakcyjnych konstrukcji.
Podstawowe metody korzystania z monady IO
{-# LANGUAGE FlexibleInstances #-}
module W13b where
import Text.Read (readMaybe)
import Data.List
import Data.Char
import System.Random
import System.IO (hFlush, stdout)
import Data.List.Split
import System.Console.ANSI
--------------------------------
-- getChar :: IO Char
-- getLine :: IO String
-- putChar :: Char -> IO ()
-- putStr :: String -> IO ()
-- putStrLn :: String -> IO ()
-- print :: Show a => a -> IO ()
--------------------------------
hello0 :: String -> String
hello0 str = "Hello " ++ str
hello1 :: String -> IO ()
hello1 = putStrLn . hello0
main1 :: IO ()
main1 = getLine >>= hello1
main2 = do
txt<- getLine
hello1 txt
main3 = do
name <- getLine
putStrLn ("Hello " ++ name)
main4 = do
putStr "Jak ci na imię ? "
name <- getLine
putStrLn $ "Hello " ++ name
------------------------------
lataToSec :: Int -> Integer
lataToSec x = ((36525 * 24 * 60 * 60) `div` 100) * (toInteger x)
ppInt :: Integer -> String
ppInt x = let rev = chunksOf 3 (reverse (show x)) in
reverse (intercalate " " rev)
wiekInfo :: Int -> String
wiekInfo x =
concat ["Żyjesz już około ", (ppInt.lataToSec) x, " sekund."]
main10 = do
putStrLn "Ile masz lat ? "
str <- getLine
let lata = read str :: Int
putStrLn $ wiekInfo lata
-- Robimy to samo, ale bezpieczniej
-- readMaybe:: Read a => String -> Maybe a
main11 = do
putStrLn "Ile masz lat ? "
str <- getLine
let lata = readMaybe str :: Maybe Int
case lata of
Nothing -> zlaLiczba
(Just x) -> putStrLn $ wiekInfo x
-----------------------------------------
czytajLiczby :: IO [Double]
czytajLiczby = do
putStr "? "
str <- getLine
if str == "" then
return []
else do
let x = read str :: Double
reszta <- czytajLiczby
return (x:reszta)
main12 = do
putStrLn "Podaj ciąg liczb, a ja obliczę Ci ich sumę"
xs <- czytajLiczby
putStrLn ("Ich suma to " ++ (show $ sum xs))
-- print ( sum xs)
-----------------------------------------
-- gra "Zgadnij Liczbę"
-- CZYSTY KOD
data WynikGry = FAIL | SUCCESS | TooSmall | TooLarge
maxDlugoscGry = 10
oneStep :: (Int,Int,Int) -> (WynikGry,Int,String)
oneStep (sekret,guess, ileprob) =
if ileprob > maxDlugoscGry then
(FAIL, ileprob, "Przegrałeś.\nZa duża liczba kroków")
else if sekret == guess then
(SUCCESS, ileprob, "Wygrałeś !!!\nGratuluję.")
else if sekret < guess then
(TooLarge, ileprob+1, "Za duża liczba.")
else
(TooSmall, ileprob+1, "Za mała liczba.")
-- ZANURZMY CZYSTY KOD w MONADZIE IO
grajDLL :: Int -> Int -> IO ()
grajDLL sekret liczbaProb = do
putStr "? "
hFlush stdout
input <- getLine
let guess = read input :: Int
let (res, lp, info) = oneStep (sekret,guess,liczbaProb)
putStrLn info
case res of
FAIL -> return ()
SUCCESS -> return ()
TooSmall -> grajDLL sekret lp
TooLarge -> grajDLL sekret lp
mainDLL :: IO ()
mainDLL = do
putStrLn "Sprobuj odgadnać liczbę ze zbioru {0, 1, ... , 123}"
sekret <- randomRIO (0, 123)
grajDLL sekret 0
-------------------------------------
grajSafe :: Int -> Int -> IO ()
grajSafe sekret liczbaProb = do
putStr $ "Próba nr " ++ (show (liczbaProb+1)) ++ ": "
-- putStr "? "
hFlush stdout
input <- getLine
let guess = readMaybe input :: Maybe Int
case guess of
Nothing -> do setSGR [SetColor Foreground Vivid Yellow]
putStrLn "Przegrałeś; podałeś złą liczbę"
setSGR [Reset]
return ()
(Just x)-> do
let (res, lp, str) = oneStep (sekret,x,liczbaProb)
putStrLn str
case res of
FAIL -> return ()
SUCCESS -> return ()
TooSmall -> grajSafe sekret lp
TooLarge -> grajSafe sekret lp
mainSafe :: IO ()
mainSafe = do
putStrLn "Sprobuj odgadnać liczbę ze zbioru {0, 1, ... , 123}"
sekret <- randomRIO (0, 123)
grajSafe sekret 0
zlyFormatLiczby = "Nie wprowadziłeś liczby całkowitej !!!\n" ++
"Nigdy nie żartuj z komputerów !!!!!!!!!!!!!\n" ++
"Pamiętamy wszystko.\n"++
"Nie obiecujemy, że będzimy pobłażliwi w przyszłości."
zlaLiczba = do
setSGR [SetColor Foreground Vivid Red]
putStrLn zlyFormatLiczby
setSGR [Reset]
Konstrukcja Parsera
Nazwy w przedstawionych kodach są podobne do nazw z modułów Parsec oraz MegaParsec.
module Parser where
import Data.Char
import Control.Applicative
import Control.Monad.Writer
{--
type Parser :: String -> Tree
type Parser :: String -> (Tree, String)
type Parser :: String -> [(Tree,String)]
type Parser a = String -> [(a,String)]
--}
data PP a = PP{ runPP :: String->[(a,String)]}
instance Functor PP where
fmap f (PP φ) =
PP (\str -> (\(t, s)->(f t, s)) <$> (φ str)) -- PP ( fmap (\(t, s)->(f t, s)) . φ )
parsePP :: PP a -> String -> [(a,String)]
parsePP = runPP
instance Applicative PP where
pure x = PP (\str -> [(x, str)])
(PP φ) <*> (PP ψ) =
PP(\inp -> [(f x,t)| (f,s)<- φ inp, (x,t)<- ψ s])
instance Monad PP where
return = pure
(PP φ) >>= f =
PP( \inp -> concat [runPP (f x) s | (x,s) <- φ inp])
instance Alternative PP where
empty = PP(\inp -> [])
φ <|> ψ =
PP(\inp -> case parsePP φ inp of
[] -> parsePP ψ inp
[(v,out)] -> [(v,out)]
)
-- WLASNOSCI
-- empty <|> x = x
-- x <|> empty = x
-- (x<|>y)<|>z = x<|>(y<|>z)
instance MonadPlus PP where
mzero = empty
mplus φ ψ = φ <|> ψ
{-- BERZEMY SIE DO ROBOTY --}
failurePP :: PP a
failurePP = PP(\inp -> [])
itemPP :: PP Char
itemPP = PP (\str -> if str=="" then [] else [(head str,tail str)])
testPP :: PP (Char,Char)
testPP = do
x<- itemPP
itemPP
y<- itemPP
return (x,y)
{- Testowanie jednego znaku -}
satisfy :: (Char -> Bool ) -> PP Char
satisfy p = do
x <- itemPP
if p x then
return x
else empty
-- parsePP (satisfy (`elem` "abc")) "ala na kota"
digit :: PP Char
digit = satisfy isDigit
lower :: PP Char
lower = satisfy isLower
upper :: PP Char
upper = satisfy isUpper
letter :: PP Char
letter = satisfy isAlpha
alphanum :: PP Char
alphanum = satisfy isAlphaNum
char :: Char -> PP Char
char x = satisfy (== x )
-- string "ALA" :: testujemy, czy zaczna się od "ALA"
string :: String -> PP String
string [] = return []
string (x : xs) = do char x
string xs
return (x : xs)
-- przykład
var :: PP String
var = do
fc <- firstChar
rest <- many nonFirstChar
return (fc:rest)
where
firstChar = satisfy (\a -> isLetter a || a == '_')
nonFirstChar = satisfy (\a -> isDigit a || isLetter a || a == '_')
varExamples :: [(String,String)]
varExamples = [("test", "test")
,("_stuff", "_stuff")
,("_1234", "_1234")]
-- manyPP digit ==> wyciągnij wszystkie cyfry
-- z przodu łańcucha
-- np. (parsePP (manyPP digit)) "123aaa"
manyPP :: PP a -> PP [a]
manyPP p = manyPP1 p <|> return []
manyPP1 :: PP a -> PP [a]
manyPP1 p = do v <- p
vs <- manyPP p
return (v : vs)
-- czy zaczynam się od identyfikatora
identifierQ :: PP String
identifierQ = do x <- lower
xs <- manyPP alphanum
return (x : xs)
-- czy zaczynam się od liczby naturalnej
naturalQ :: PP Integer
naturalQ = do xs <- manyPP1 digit
return (read xs)
{- Teraz zajmujemy sie spacjami -}
-- czy zacznam się od spacji
spaceQ :: PP ()
spaceQ = do manyPP (satisfy isSpace)
return ()
token :: PP a -> PP a
token p = do spaceQ
v <- p
spaceQ
return v
jestemIdentyfikatorem :: PP String
jestemIdentyfikatorem = token identifierQ
natural :: PP Integer
natural = token naturalQ
symbol :: String -> PP String
symbol xs = token (string xs)
-- example : parser ciagu liczb
pseqInt :: PP [Integer]
pseqInt = do symbol "["
n <- natural
ns<- manyPP (do symbol ","; natural)
symbol "]"
return (n:ns)
----------------------------------------------
{-- WYRAŻENIA ARYTMETYCZNE -}
-- Backus–Naur form
-- expr ::= term | term + expr
-- term ::= factor | factor * term
-- factor ::= (expr) | nat
-- nat ::= 0|1|2|3 ...
-- EWALUATOR
expr :: PP Integer
expr = do
t <- term
(do symbol "+"
e <- expr;
return (t + e)
)
<|> return t
term :: PP Integer
term = do
f <- factor
(do symbol "*"
t <- term;
return (f * t)
)
<|> (return f)
factor :: PP Integer
factor = do symbol "("
e <- expr
symbol ")"
return e
<|> natural
eval :: String -> Integer
eval xs = case parsePP expr xs of
[(n, [ ])] -> n
[(_, out)] -> error ("nonconsumed input: " ++ out)
[] -> error "złe wejście"
data Type = NAT Integer
| PLUS Type Type
| MULT Type Type deriving (Eq)
instance Show Type where
show (NAT n) = show n
show (PLUS x y) = concat ["{(+) ",show x, " ",show y, "} "]
show (MULT x y) = concat ["[(*) ",show x, " ",show y, "] "]
exprT :: PP Type
exprT = do
t <- termT
(do symbol "+"
e <- exprT;
return (PLUS t e)
)
<|> return t
termT :: PP Type
termT = do
f <- factorT
(do symbol "*"
t <- termT;
return (MULT f t)
)
<|> return f
factorT :: PP Type
factorT = (do symbol "("
e <- exprT
symbol ")"
return e
)
<|>
(do n <- natural
return (NAT n)
)
evalT :: String -> Type
evalT xs = case parsePP exprT xs of
[(term, [ ])] -> term
[(_, out)] -> error ("nie skonsumowane wejście: " ++ out)
[] -> error "błąd syntaktyczny"
-------------------------------------------------------
-- Wczytujemy surowe dane liczbowe
-- liczby są postaci:
-- "123" lub
-- "-23" lub "+32"
-- "123.11" lub
-- "23e+2" lub
-- "-1.2E-34"
-- chcemy je przekształcić w Double
isEXP = (char 'E') <|> (char 'e')
isSIGN = (char '+') <|> (char '-')
isDEC = char '.'
-- zaczynamy od Integer
isINT = do{s<-isSIGN; d<-manyPP (digit); return (s,d)}
<|>
do{d<-manyPP (digit);return ('+',d)}
isINTEGER = do
(c,d) <- isINT
let val = read d::Integer
if c=='-' then return (-val)
else return val
isIntegerDOUBLE = do
int <- isINTEGER
return (fromIntegral int :: Double)
-- teraz obsługujemy Double bez E
isDOUBLE = do
d <- isINTEGER
isDEC
e <- manyPP (digit)
let val = read ((show d)++"."++e)::Double
return (val)
-- teraz obslugujemy liczby z E
isSCIENCE = do
d <- isDOUBLE <|> isIntegerDOUBLE
isEXP
exp <- isINTEGER
let mult = (10.0) ** fromIntegral (exp) :: Double
return (d * mult)
isNUMBER = isSCIENCE <|> isDOUBLE <|> isIntegerDOUBLE
-- Zastosowanie
-- obsługujemy ciągi postaci
-- [12, -23.1, +45e-2, +15]
seqNUMB :: PP [Double]
seqNUMB = do
symbol "["
n <- isNUMBER
ns<- manyPP (do symbol ","; isNUMBER)
symbol "]"
return (n:ns)
getSeqNumb str = let res = parsePP seqNUMB str in
if null res then
[]
else
fst $ head res
liczby = "[12, 23.2, 55.12e-1, 11, 255]"
mainRD = do
text <- readFile "liczby-in.txt"
let bs = lines text
cs = show.getSeqNumb <$> bs
writeFile "liczby-out.txt" (unlines cs)
W15 (17.06.2025): Własności monad i monada Reader
- (fmap f mx) = (mx >>= return.f)
- Def. (join mmx) = (mmx >>= id)
- Tw. (mx >>= f) = (join . fmap f) mx
Kategoria ENDO(SET)
- Obiekty: endofunktory SET
- Morfizmy: natualne transformacje między funktorami
- Odpowiednik iloczynu kartezjańskiego: $F \otimes G = F \circ G$
- Odpowiednik produktu odwzorowań naturalnych: dla $\alpha:G\dot{\to} G'$ i $\beta: F\dot{\to} F'$ definiujemy
$$\beta \otimes \alpha = (\beta_{G'(X)} \circ F(\alpha_X))_{X\in SET}$$
Mamy $\beta\otimes \alpha: F\otimes G \dot{\to} F'\otimes G$.
(Mac Lane)
Monada = monoid w kategorii endofunktorów
Samodzielna implementacje kilku pożytecznych funkcji i przykład
wykorzystania monady Reader
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
module W15a where
import Control.Monad
import Control.Monad.Reader
import Data.List.Split
import Data.Char
import Data.List
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Control.Applicative (empty)
-- liftM jest wyspecjalizowaną wesją fmap do monad
-- fmap :: (a -> b) -> f a -> f b
-- liftM :: (Monad m) => (a -> b) -> m a -> m b
-- sequence :: (Monad m) => [ m a] -> m [a]
-- sequence_ :: (Monad m) => [ m a] -> m ()
-- mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
-- mapM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
-- join :: (Monad m) => m m a -> m a
-- when :: (Applicative f) => Boole -> f () -> f ()
-- when p s = if p then s else pure ()
mySequence :: (Monad m) => [m a] -> m [a]
mySequence [] = return []
mySequence (mx:mxs) = do {x<-mx; xs <- mySequence mxs; return (x:xs)}
mySequence_ :: (Monad m) => [m a] -> m ()
mySequence_ [] = return ()
mySequence_ (mx:mxs) = do {mx; mySequence mxs; return ()}
myMapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
myMapM f xs = mySequence (fmap f xs)
myMapM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
myMapM_ f xs = mySequence_ (fmap f xs)
myJoin xs = xs >>= id
myBind :: (Monad m) => m a -> (a -> m b) -> m b
myBind mx f = join (fmap f mx)
-- TW !!!! myBind == (>>=)
liczby = [1,2,3,4,5]
main01 = do
mapM print liczby
main02 = do
mapM_ print liczby
main03 = do
print $ sequence [Just 3, Nothing, Just 1]
-----------------------------------------------------
-- Reader Monad
-- data Reader a x = Reader{ runReader :: a -> x}
-- fmap f (Reader φ) = Reader (f.φ)
-- pure x = Reader (const x)
-- (Reader φ) <:> (Reader ψ) = Reader (\x -> (φ x, ψ x))
-- (Reader φ) >>= f = Reader (\x -> (f (φ x)) x)
-- Funkcja pomocnicza
-- ask :: Reader a x -> Reader a a
-- ask = Reader id
data Config = Config{txt :: String
,sw :: String
,ile :: Int}
onlyAlpha ch = if isAlpha ch then ch else ' '
part1 :: Reader Config [String]
part1 = do
cnf <- ask
return $ words $ map (onlyAlpha.toLower) (txt cnf)
part2 :: [String] -> Reader Config [String]
part2 tekst = do
cnf <- ask
let stopWords = words (sw cnf)
return $ filter (`notElem` stopWords) tekst
part3 :: [String] -> Reader Config [(String,Int)]
part3 slowa =
return $ map (\gr -> (head gr, length gr)) (group (sort slowa))
part4 :: [(String,Int)] -> Reader Config [(String,Int)]
part4 lista = do
cnf <- ask
let sorted = sortBy (\(a,k) (b,l) -> compare l k) lista
return $ take (ile cnf) sorted
frequentWords =
part1 >>= part2 >>= part3 >>= part4
main04 = do
book <- readFile "hamlet.txt"
slowa <- re adFile "stop_words_english.txt"
let cfg = Config{txt = book, sw = slowa, ile = 15}
let res = runReader frequentWords cfg
mapM_ print res
{-- TEGO NIE ZDARZYLISMY OMOWIC !!!!!! --}
{-- Maybe TRANSFORMER --}
newtype MyMaybeT m a = MyMaybeT { runMyMaybeT :: m (Maybe a) }
mapMyMaybeT :: (m (Maybe a) -> n (Maybe b)) ->
MyMaybeT m a -> MyMaybeT n b
mapMyMaybeT f = MyMaybeT . f . runMyMaybeT
instance (Functor m) => Functor (MyMaybeT m) where
fmap f = mapMyMaybeT (fmap (fmap f))
instance (Functor m, Monad m) => Applicative (MyMaybeT m) where
pure = MyMaybeT . return . Just
mf <*> mx = MyMaybeT $ do
mb_f <- runMyMaybeT mf
case mb_f of
Nothing -> return Nothing
Just f -> do
mb_x <- runMyMaybeT mx
case mb_x of
Nothing -> return Nothing
Just x -> return (Just (f x))
instance (Monad m) => Monad (MyMaybeT m) where
x >>= f = MyMaybeT $ do
v <- runMyMaybeT x
case v of
Nothing -> return Nothing
Just y -> runMyMaybeT (f y)
newtype Compose f g a = Compose { getCompose :: f (g a) }
instance (Functor f, Functor g) => Functor (Compose f g) where
fmap h (Compose x) = Compose (fmap (fmap h) x)
--ZASTOSOWANIE
isValid str = length str > 8
getPass :: MaybeT IO String
getPass = do s<- lift getLine
if isValid s
then return s
else empty
-- getPass = do s <- lift getLine
-- guard (isValid s)
-- return s
askP :: MaybeT IO ()
askP = do lift $ putStrLn "Podaj nowe hasło:"
value <- getPass
lift $ putStrLn "Zapisuję do bazy..."
-- runMaybeT askP
main10 :: IO ()
main10 = do
maybeResult <- runMaybeT askP
-- Sprawdzamy, czy operacja się udała (Just) czy nie (Nothing)
case maybeResult of
Just () -> putStrLn "Operacja zakończona sukcesem. Hasło zapisane."
Nothing -> putStrLn "BŁĄD: Hasło było za krótkie. Spróbuj ponownie."
Zastąpienie list ich odpowiednikiem z modułu Data.Text
module W15b where
{-- Korzystamy z modułu Data.Text --}
import Data.Char (isAlpha, toLower)
import Data.List (sort, group, sortBy)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Control.Monad.Reader
data Config = Config {
txt :: Text
, sw :: Text
, ile :: Int
}
-- Replaced String with Text and used T.singleton for single characters
onlyAlpha :: Char -> Char
onlyAlpha ch = if isAlpha ch then ch else ' '
part1 :: Reader Config [Text]
part1 = do
cnf <- ask
-- Used T.words, T.map, and T.toLower for Text operations
return $ T.words $ T.map (onlyAlpha . toLower) (txt cnf)
part2 :: [Text] -> Reader Config [Text]
part2 tekst = do
cnf <- ask
-- Used T.words for stopWords and T.notElem for efficiency
let stopWords = T.words (sw cnf)
return $ filter (\w -> notElem w stopWords) tekst
part3 :: [Text] -> Reader Config [(Text, Int)]
part3 slowa =
-- Used T.pack and T.unpack if conversion was needed, but here direct Text works
return $ map (\gr -> (head gr, length gr)) (group (sort slowa))
part4 :: [(Text, Int)] -> Reader Config [(Text, Int)]
part4 lista = do
cnf <- ask
let sorted = sortBy (\(_, k) (_, l) -> compare l k) lista
return $ take (ile cnf) sorted
frequentWords =
part1 >>= part2 >>= part3 >>= part4
main04 :: IO ()
main04 = do
-- Used TIO.readFile for efficient reading of Text
book <- TIO.readFile "hamlet.txt"
slowa <- TIO.readFile "stop_words_english.txt"
let cfg = Config{txt = book, sw = slowa, ile = 15}
let res = runReader frequentWords cfg
mapM_ print res
TO JUŻ KONIEC
Jak sobie założycie koło naukowe języka Haskell, to mogę Wam trochę poopowiadać o Haskelu na waszych spotkaniach.