Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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 ============================================================================
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement