import Data.Char
import Data.List hiding (foldr, foldl, foldr1, foldl1)
import Data.List.Split
import Data.Ord
import Data.Maybe
import Data.Functor
import Data.Foldable hiding (concat, elem)
import Prelude hiding (foldr,foldl,foldr1, foldl1, concat)
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Tree as T
-- Sandro Gržičić
-- Haskell FER DZ07
-- 2011-12
-- === PUH-LEKCIJA-10 =================================================================
-- 1.
data Sex = Male | Female deriving (Show,Read,Eq,Ord)
data Person = Unknown | Person {
idNumber :: String,
forename :: String,
surname :: String,
sex :: Sex,
mother :: Person,
father :: Person,
age :: Int,
partner :: Maybe Person,
children :: [Person]
} deriving Read
instance Eq Person where
Unknown == Unknown = False
Unknown == _ = False
_ == Unknown = False
p1 == p2 = idNumber p1 == idNumber p2
instance Ord Person where
compare Unknown Unknown = EQ
compare Unknown _ = LT
compare _ Unknown = GT
compare p1 p2
| surname p1 < surname p2 = LT
| surname p1 > surname p2 = GT
| forename p1 < forename p2 = LT
| forename p1 > forename p2 = GT
| otherwise = EQ
-- 1.1.
partnersMother :: Person -> Maybe Person
partnersMother Unknown = Nothing
partnersMother p
| partner p == Nothing = Nothing
| mother (fromJust $ partner p) == Unknown = Nothing
| otherwise = Just $ mother $ fromJust $ partner p
-- 1.2.
parentCheck :: Person -> Bool
parentCheck Unknown = False
parentCheck p = inMothersChildren || inFathersChildren
where
inMothersChildren = mother p /= Unknown && elem p (children $ mother p)
inFathersChildren = father p /= Unknown && elem p (children $ father p)
-- 1.3.
sister :: Person -> [Person]
sister Unknown = []
sister p = femaleChildren $ bothParentsChildren p
where
femaleChildren = filter (\p -> sex p == Female)
parentsChildren :: (Person -> Person) -> Person -> [Person]
parentsChildren parentFunc p = if parentFunc p /= Unknown then children $ parentFunc p else []
bothParentsChildren :: Person -> [Person]
bothParentsChildren p = nub $ (parentsChildren mother p ++ parentsChildren father p)
-- 1.4.
descendant :: Person -> [Person]
descendant Unknown = []
descendant p = concat $ map descendant (bothParentsChildren p)
-- 2.
data MyList a = Empty | Cons a (MyList a) deriving (Show,Read,Ord)
-- 2.1
listHead :: MyList a -> Maybe a
listHead Empty = Nothing
listHead (Cons a _) = Just a
-- 2.2.
listMap :: (a -> b) -> MyList a -> MyList b
listMap _ Empty = Empty
listMap f (Cons a xs) = Cons (f a) (listMap f xs)
-- 3.
data Tree a = Null | Node a (Tree a) (Tree a) deriving Show
t = Node 0 (Node 1 (Node 2 Null Null) (Node 3 Null Null)) (Node 4 Null (Node 5 (Node 6 Null Null) Null))
-- 3.1.
treeMax :: Ord a => Tree a -> a
treeMax Null = error "Prazno stablo!"
treeMax (Node m l r) = max (treeMax' m l) (treeMax' m r)
where
treeMax' :: Ord a => a -> Tree a -> a
treeMax' m Null = m
treeMax' m (Node e l r) = max m (max (treeMax' e l) (treeMax' e r))
-- 3.2.
-- jako kratka neakumulatorska verzija.
treeElems :: Tree a -> [a]
treeElems Null = []
treeElems (Node e l r) = treeElems l ++ [e] ++ treeElems r
-- 3.3.
levelCut :: Int -> Tree a -> Tree a
levelCut _ Null = Null
levelCut cut t
| cut < 0 = error "Razina mora biti >= 0!"
| otherwise = levelCut' cut t
where
levelCut' :: Int -> Tree a -> Tree a
levelCut' _ Null = Null
levelCut' 0 (Node e l r) = Node e Null Null
levelCut' lvl (Node e l r) = Node e (levelCut' (lvl - 1) l) (levelCut' (lvl - 1) r)
-- 4.
treeInsert :: Ord a => a -> Tree a -> Tree a
treeInsert x Null = Node x Null Null
treeInsert x t@(Node y l r)
| x < y = Node y (treeInsert x l) r
| x > y = Node y l (treeInsert x r)
| otherwise = t
-- 4.1.
listToTree :: Ord a => [a] -> Tree a
listToTree [] = Null
listToTree ls = listToTree' ls Null
where
listToTree' [] t = t
listToTree' (x:xs) t = listToTree' xs (treeInsert x t)
-- 4.2.
treeToList :: Tree a -> [a]
treeToList = treeElems
-- 4.3.
sortAndNub :: Ord a => [a] -> [a]
sortAndNub = treeToList . listToTree
-- 5.
data Weekday =
Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
deriving (Show,Enum)
-- 5.1.
instance Eq Weekday where
Monday == Monday = True
Tuesday == Tuesday = True
Wednesday == Wednesday = True
Thursday == Thursday = True
Friday == Friday = False
Saturday == Saturday = True
Sunday == Sunday = True
_ == _ = False
-- 5.2.
instance Show Person where
show Unknown = "Unknown"
show (Person idNumber' forename' surname' sex' mother' father' age' partner' children') =
idNumber' ++ " " ++ forename' ++ " " ++ surname' ++ " " ++ show sex' ++ " " ++
name mother' ++ " " ++ name father' ++ " " ++ show age' ++ " " ++ show (fromMaybe Unknown partner') ++ " " ++ show children'
where
name Unknown = "Unknown"
name p = (forename p) ++ " " ++ (surname p)
-- 6.
-- 6.1.
instance Eq a => Eq (MyList a) where -- hvala Siniši! :)
l1 == l2 = listHead l1 == listHead l2
-- 6.2.
instance Ord a => Eq (Tree a) where -- hvala Siniši! :)
Null == Null = False
Null == _ = False
_ == Null = False
t1 == t2 = (sortAndNub . treeToList) t1 == (sortAndNub . treeToList) t2 -- uspoređivanje listi
-- === PUH-LEKCIJA-11 =================================================================
class Ageing a where
currentAge :: a -> Int
maxAge :: a -> Int
makeOlder :: a -> a
instance Ageing Person where
currentAge = age
makeOlder p = p { age = age p + 1 }
maxAge _ = 123
data Breed = Beagle | Husky | Pekingese deriving (Eq, Ord, Show, Read)
data Dog = Dog {
dogName :: String,
dogBreed :: Breed,
dogAge :: Int
} deriving (Eq, Ord, Show, Read)
instance Ageing Dog where
currentAge = dogAge
makeOlder d = d {dogAge = dogAge d + 1}
maxAge d = case dogBreed d of
Husky -> 29
_ -> 20
-- 1.1.
compareRelativeAge :: (Ageing a, Ageing b) => a -> b -> Ordering
compareRelativeAge a b | ages a < ages b = LT
| ages a > ages b = GT
| otherwise = EQ
where
ages x = currentAge x * maxAge x
-- 1.2.
class Nameable a where
name :: a -> String
instance Nameable Person where
name a = forename a ++ " " ++ surname a
instance Nameable Dog where
name a = dogName a ++ " The Dog"
-- 2.
class Pushable t where
push :: a -> t a -> t a
peek :: t a -> a
pop :: t a -> t a
instance Pushable [] where
push x xs = x : xs
peek (x:_) = x
peek [] = error "Empty List"
pop (_:xs) = xs
instance Pushable MyList where
push x xs = x `Cons` xs
peek (x `Cons` _) = x
peek Empty = error "Empty List"
pop (_ `Cons` xs) = xs
instance Pushable Tree where
push x t = Node x t Null
pop (Node _ t _) = t
peek (Node x _ _ ) = x
peek Null = error "Empty Tree"
-- 2.1.
stablo = Node 0 (Node 1 Null Null) (Node 2 (Node 3 (Node 4 Null Null) (Node 5 Null Null)) (Node 9 Null Null))
class Takeable t where
takeSome :: Int -> t a -> [a]
instance Takeable Tree where
takeSome n Null = []
takeSome (-1) _ = []
takeSome 0 _ = []
takeSome n (Node e l r) = take n $ (takeSome (n `div` 2) l) ++ [e] ++ (takeSome ((n `div` 2)) r)
instance Takeable [] where
takeSome = take
-- 2.2.
class Headed t where
headOf :: t a -> a
headOff :: t a -> t a
instance Headed [] where
headOf l = head l
headOff l = tail l
instance Headed Tree where
headOf (Node x _ _) = x
headOff (Node _ a Null) = a
headOff (Node _ Null b) = b
headOff (Node _ a b) = undefined -- ??? ovo nema smisla.. (kako ukloniti glavu stablu i vratiti samo jednu granu? random? :D)
instance Headed Maybe where
headOf Nothing = error "nema glave"
headOf (Just a) = a
headOff _ = Nothing
-- 3.
treeMap :: (a -> b) -> Tree a -> Tree b
treeMap _ Null = Null
treeMap f (Node x l r) = Node (f x) (treeMap f l) (treeMap f r)
maybeMap :: (a -> b) -> Maybe a -> Maybe b
maybeMap _ Nothing = Nothing
maybeMap f (Just x) = Just $ f x
instance Functor Tree where
fmap _ Null = Null
fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)
-- 3.1.
mapOnTreeMaybe _ Null = Null
mapOnTreeMaybe f (Node (Just x) l r) = Node (Just (f x)) (mapOnTreeMaybe f l) (mapOnTreeMaybe f r)
mapOnTreeMaybe f (Node Nothing l r) = Node Nothing (mapOnTreeMaybe f l) (mapOnTreeMaybe f r)
stablo' = Node (Just 5) (Node (Just 5) Null Null) (Node (Just 5) (Node (Just 2) (Node (Just 2) Null Null) (Node (Just 1) Null Null)) (Node (Just 8) Null Null))
-- 3.2.
data RoseTree a = RoseEmpty | RoseTree a [RoseTree a] deriving (Show,Read,Eq,Ord)
instance Functor RoseTree where
fmap _ RoseEmpty = RoseEmpty
fmap f (RoseTree a xs) = RoseTree (f a) (map (fmap f) xs)
ruza = RoseTree 1 [RoseTree 2 [], RoseTree 3 [], RoseTree 4 [RoseTree 4 [], RoseTree 9 []]]
-- 4.
instance Foldable Tree where
foldr f z Null = z
foldr f z (Node e l r) = f e (foldr f (foldr f z r) l)
-- 4.1 -- thx Siniša!
sumPositive :: (Foldable t, Num a) => t a -> a -- općenitiji a umjesto Int
sumPositive = foldr (\e s -> if signum e /= -1 then e + s else s) 0
-- 4.2 - kul stvarčica :)
size :: Foldable t => t a -> Int
size = foldr (\e s -> s + 1) 0
-- 4.3 - yay foldanje! :)
eqElems :: (Foldable t, Eq a) => t a -> Bool
eqElems str = length (eqElemsFold str) < 2
where
eqElemsFold = foldr eqElems'[]
eqElems' :: Eq a => a -> [a] -> [a]
eqElems' e a@[_, _] = a -- ništa novo: nisu jednaki, nastavi foldati
eqElems' e a
| a == [] = [e] -- prvi korak
| [e] == a = [e] -- jednaki elementi
| otherwise = (e:a) -- nađen različit element
-- 4.4
instance Foldable RoseTree where
foldr f z RoseEmpty = z
foldr f z (RoseTree e []) = f e (foldr f z RoseEmpty)
--foldr f z (RoseTree e (x:xs)) = f z (foldr f e (foldr f x xs)) -- ne radi.. možda treba umjesto zadnjeg F.folda onaj obični?
-- 5.
-- 5.1
-- 5.2
-- === DZ ============================================================================