Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Jan 8th, 2012  |  syntax: Haskell  |  size: 10.39 KB  |  views: 96  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. import Data.Char
  2. import Data.List hiding (foldr, foldl, foldr1, foldl1)
  3. import Data.List.Split
  4. import Data.Ord
  5. import Data.Maybe
  6. import Data.Functor
  7. import Data.Foldable hiding (concat, elem)
  8. import Prelude hiding (foldr,foldl,foldr1, foldl1, concat)
  9. import qualified Data.Set as S
  10. import qualified Data.Map as M
  11. import qualified Data.Tree as T
  12.  
  13.  
  14. -- Sandro Gržičić
  15. -- Haskell FER DZ07
  16. -- 2011-12
  17.  
  18. -- === PUH-LEKCIJA-10 =================================================================
  19.  
  20. -- 1.
  21. data Sex = Male | Female deriving (Show,Read,Eq,Ord)
  22.  
  23. data Person = Unknown | Person {
  24.    idNumber :: String,
  25.    forename :: String,
  26.    surname  :: String,
  27.    sex      :: Sex,
  28.    mother   :: Person,
  29.    father   :: Person,
  30.    age      :: Int,
  31.    partner  :: Maybe Person,
  32.    children :: [Person]
  33. } deriving Read
  34.  
  35. instance Eq Person where
  36.   Unknown == Unknown = False
  37.   Unknown == _       = False
  38.   _       == Unknown = False
  39.   p1      == p2      = idNumber p1 == idNumber p2
  40.  
  41. instance Ord Person where
  42.   compare Unknown Unknown        = EQ
  43.   compare Unknown _              = LT
  44.   compare _       Unknown        = GT
  45.   compare p1     p2
  46.     | surname p1 < surname p2    = LT
  47.     | surname p1 > surname p2    = GT
  48.     | forename p1 < forename p2  = LT
  49.     | forename p1 > forename p2  = GT
  50.     | otherwise                  = EQ  
  51.  
  52. -- 1.1.
  53. partnersMother :: Person -> Maybe Person
  54. partnersMother Unknown = Nothing
  55. partnersMother p      
  56.   | partner p == Nothing                     = Nothing
  57.   | mother (fromJust $ partner p) == Unknown = Nothing
  58.   | otherwise                                = Just $ mother $ fromJust $ partner p
  59.  
  60. -- 1.2.
  61. parentCheck :: Person -> Bool
  62. parentCheck Unknown = False
  63. parentCheck p = inMothersChildren || inFathersChildren
  64.   where
  65.     inMothersChildren = mother p /= Unknown && elem p (children $ mother p)
  66.     inFathersChildren = father p /= Unknown && elem p (children $ father p)
  67.  
  68. -- 1.3.
  69. sister :: Person -> [Person]
  70. sister Unknown = []
  71. sister p = femaleChildren $ bothParentsChildren p
  72.   where
  73.     femaleChildren = filter (\p -> sex p == Female)  
  74.  
  75. parentsChildren :: (Person -> Person) -> Person -> [Person]
  76. parentsChildren parentFunc p = if parentFunc p /= Unknown then children $ parentFunc p else []
  77.  
  78. bothParentsChildren :: Person -> [Person]
  79. bothParentsChildren p = nub $ (parentsChildren mother p ++ parentsChildren father p)
  80.      
  81. -- 1.4.
  82. descendant :: Person -> [Person]
  83. descendant Unknown = []
  84. descendant p = concat $ map descendant (bothParentsChildren p)
  85.  
  86. -- 2.
  87. data MyList a = Empty | Cons a (MyList a) deriving (Show,Read,Ord)
  88.  
  89. -- 2.1
  90. listHead :: MyList a -> Maybe a
  91. listHead Empty = Nothing
  92. listHead (Cons a _) = Just a
  93.  
  94. -- 2.2.
  95. listMap :: (a -> b) -> MyList a -> MyList b
  96. listMap _ Empty = Empty
  97. listMap f (Cons a xs) = Cons (f a) (listMap f xs)
  98.  
  99. -- 3.
  100. data Tree a = Null | Node a (Tree a) (Tree a) deriving Show
  101.  
  102. t = Node 0 (Node 1 (Node 2 Null Null) (Node 3 Null Null)) (Node 4 Null (Node 5 (Node 6 Null Null) Null))
  103.  
  104. -- 3.1.
  105. treeMax :: Ord a => Tree a -> a
  106. treeMax Null = error "Prazno stablo!"
  107. treeMax (Node m l r) = max (treeMax' m l) (treeMax' m r)  
  108.   where
  109.     treeMax' :: Ord a => a -> Tree a -> a
  110.     treeMax' m Null = m
  111.     treeMax' m (Node e l r) = max m (max (treeMax' e l) (treeMax' e r))    
  112.    
  113. -- 3.2.
  114. -- jako kratka neakumulatorska verzija.
  115. treeElems :: Tree a -> [a]
  116. treeElems Null = []
  117. treeElems (Node e l r) = treeElems l ++ [e] ++ treeElems r
  118.  
  119. -- 3.3.
  120. levelCut :: Int -> Tree a -> Tree a
  121. levelCut _ Null = Null
  122. levelCut cut t
  123.   | cut < 0 = error "Razina mora biti >= 0!"
  124.   | otherwise = levelCut' cut t
  125.   where
  126.     levelCut' :: Int -> Tree a -> Tree a
  127.     levelCut' _ Null = Null
  128.     levelCut' 0 (Node e l r) = Node e Null Null
  129.     levelCut' lvl (Node e l r) = Node e (levelCut' (lvl - 1) l) (levelCut' (lvl - 1) r)
  130.  
  131. -- 4.
  132. treeInsert :: Ord a => a -> Tree a -> Tree a
  133. treeInsert x Null = Node x Null Null
  134. treeInsert x t@(Node y l r)
  135.   | x < y     = Node y (treeInsert x l) r
  136.   | x > y     = Node y l (treeInsert x r)
  137.   | otherwise = t
  138.  
  139.  
  140. -- 4.1.
  141. listToTree :: Ord a => [a] -> Tree a
  142. listToTree [] = Null
  143. listToTree ls = listToTree' ls Null
  144.   where
  145.     listToTree' [] t = t
  146.     listToTree' (x:xs) t = listToTree' xs (treeInsert x t)    
  147.  
  148. -- 4.2.
  149. treeToList :: Tree a -> [a]
  150. treeToList = treeElems
  151.  
  152. -- 4.3.
  153. sortAndNub :: Ord a => [a] -> [a]
  154. sortAndNub = treeToList . listToTree
  155.  
  156. -- 5.
  157. data Weekday =
  158.   Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
  159.   deriving (Show,Enum)
  160.  
  161. -- 5.1.
  162. instance Eq Weekday where
  163.   Monday    == Monday    = True
  164.   Tuesday   == Tuesday   = True
  165.   Wednesday == Wednesday = True
  166.   Thursday  == Thursday  = True
  167.   Friday    == Friday    = False
  168.   Saturday  == Saturday  = True
  169.   Sunday    == Sunday    = True
  170.   _         == _         = False
  171.  
  172. -- 5.2.
  173. instance Show Person where
  174.   show Unknown = "Unknown"
  175.   show (Person idNumber' forename' surname' sex' mother' father' age' partner' children') =
  176.     idNumber' ++ " " ++ forename' ++ " " ++ surname' ++ " " ++ show sex' ++ " " ++
  177.     name mother' ++ " " ++ name father' ++ " " ++ show age' ++ " " ++ show (fromMaybe Unknown partner') ++ " " ++ show children'
  178.    where
  179.      name Unknown = "Unknown"
  180.      name p = (forename p) ++ " " ++ (surname p)
  181.  
  182. -- 6.
  183.  
  184. -- 6.1.
  185. instance Eq a => Eq (MyList a) where -- hvala Siniši! :)
  186.   l1 == l2 = listHead l1 == listHead l2
  187.  
  188. -- 6.2.
  189. instance Ord a => Eq (Tree a) where -- hvala Siniši! :)
  190.   Null == Null = False
  191.   Null == _    = False
  192.   _    == Null = False
  193.   t1   == t2   = (sortAndNub . treeToList) t1 == (sortAndNub . treeToList) t2 -- uspoređivanje listi
  194.  
  195. -- === PUH-LEKCIJA-11 =================================================================
  196.  
  197. class Ageing a where
  198.   currentAge :: a -> Int
  199.   maxAge :: a -> Int
  200.   makeOlder :: a -> a
  201.  
  202. instance Ageing Person where
  203.   currentAge = age
  204.   makeOlder p = p { age = age p + 1 }
  205.   maxAge _ = 123
  206.  
  207. data Breed = Beagle | Husky | Pekingese deriving (Eq, Ord, Show, Read)
  208.  
  209. data Dog = Dog {
  210.   dogName :: String,
  211.   dogBreed :: Breed,
  212.   dogAge :: Int
  213. } deriving (Eq, Ord, Show, Read)
  214.  
  215. instance Ageing Dog where
  216.   currentAge = dogAge
  217.   makeOlder d = d {dogAge = dogAge d + 1}
  218.   maxAge d = case dogBreed d of
  219.     Husky -> 29
  220.     _     -> 20
  221.  
  222. -- 1.1.
  223. compareRelativeAge :: (Ageing a, Ageing b) => a -> b -> Ordering
  224. compareRelativeAge a b | ages a < ages b = LT
  225.                        | ages a > ages b = GT
  226.                        | otherwise = EQ
  227.   where
  228.     ages x = currentAge x * maxAge x
  229.  
  230. -- 1.2.
  231. class Nameable a where
  232.   name :: a -> String
  233.  
  234. instance Nameable Person where
  235.   name a = forename a ++ " " ++ surname a
  236.  
  237. instance Nameable Dog where
  238.   name a = dogName a ++ " The Dog"
  239.  
  240. -- 2.
  241. class Pushable t where
  242.   push :: a -> t a -> t a
  243.   peek :: t a -> a
  244.   pop :: t a -> t a
  245.  
  246. instance Pushable [] where
  247.   push x xs = x : xs
  248.   peek (x:_) = x
  249.   peek [] = error "Empty List"
  250.   pop (_:xs) = xs
  251.  
  252. instance Pushable MyList where
  253.   push x xs = x `Cons` xs
  254.   peek (x `Cons` _) = x
  255.   peek Empty = error "Empty List"
  256.   pop (_ `Cons` xs) = xs
  257.  
  258. instance Pushable Tree where
  259.   push x t = Node x t Null
  260.   pop (Node _ t _) = t
  261.   peek (Node x _ _ ) = x
  262.   peek Null = error "Empty Tree"
  263.  
  264. -- 2.1.
  265. stablo = Node 0 (Node 1 Null Null) (Node 2 (Node 3 (Node 4 Null Null) (Node 5 Null Null)) (Node 9 Null Null))
  266.  
  267. class Takeable t where
  268.   takeSome :: Int -> t a -> [a]
  269.  
  270. instance Takeable Tree where
  271.   takeSome n Null = []
  272.   takeSome (-1) _ = []
  273.   takeSome 0 _ = []
  274.   takeSome n (Node e l r) = take n $ (takeSome (n `div` 2) l) ++ [e] ++ (takeSome ((n `div` 2)) r)
  275.  
  276. instance Takeable [] where
  277.   takeSome = take
  278.  
  279. -- 2.2.
  280. class Headed t where
  281.   headOf :: t a -> a
  282.   headOff :: t a -> t a
  283.  
  284. instance Headed [] where
  285.   headOf l = head l
  286.   headOff l = tail l
  287.  
  288. instance Headed Tree where
  289.   headOf (Node x _ _) = x
  290.   headOff (Node _ a Null) = a
  291.   headOff (Node _ Null b) = b
  292.   headOff (Node _ a b) = undefined -- ??? ovo nema smisla.. (kako ukloniti glavu stablu i vratiti samo jednu granu? random? :D)
  293.  
  294. instance Headed Maybe where
  295.   headOf Nothing = error "nema glave"
  296.   headOf (Just a) = a
  297.   headOff _ = Nothing
  298.  
  299. -- 3.
  300. treeMap :: (a -> b) -> Tree a -> Tree b
  301. treeMap _ Null = Null
  302. treeMap f (Node x l r) = Node (f x) (treeMap f l) (treeMap f r)
  303.  
  304. maybeMap :: (a -> b) -> Maybe a -> Maybe b
  305. maybeMap _ Nothing = Nothing
  306. maybeMap f (Just x) = Just $ f x
  307.  
  308. instance Functor Tree where
  309.   fmap _ Null = Null
  310.   fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)
  311.  
  312. -- 3.1.
  313. mapOnTreeMaybe _ Null = Null
  314. mapOnTreeMaybe f (Node (Just x) l r) = Node (Just (f x)) (mapOnTreeMaybe f l) (mapOnTreeMaybe f r)
  315. mapOnTreeMaybe f (Node Nothing l r) = Node Nothing (mapOnTreeMaybe f l) (mapOnTreeMaybe f r)
  316.  
  317. 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))
  318.  
  319. -- 3.2.
  320. data RoseTree a = RoseEmpty | RoseTree a [RoseTree a] deriving (Show,Read,Eq,Ord)
  321.  
  322. instance Functor RoseTree where
  323.   fmap _ RoseEmpty = RoseEmpty
  324.   fmap f (RoseTree a xs) = RoseTree (f a) (map (fmap f) xs)
  325.  
  326. ruza = RoseTree 1 [RoseTree 2 [], RoseTree 3 [], RoseTree 4 [RoseTree 4 [], RoseTree 9 []]]
  327.  
  328. -- 4.
  329. instance Foldable Tree where
  330.   foldr f z Null = z
  331.   foldr f z (Node e l r) = f e (foldr f (foldr f z r) l)
  332.  
  333. -- 4.1 -- thx Siniša!
  334. sumPositive :: (Foldable t, Num a) => t a -> a -- općenitiji a umjesto Int
  335. sumPositive = foldr (\e s -> if signum e /= -1 then e + s else s) 0
  336.  
  337. -- 4.2 - kul stvarčica :)
  338. size :: Foldable t => t a -> Int
  339. size = foldr (\e s -> s + 1) 0
  340.  
  341. -- 4.3 - yay foldanje! :)
  342. eqElems :: (Foldable t, Eq a) => t a -> Bool
  343. eqElems str = length (eqElemsFold str) < 2
  344.   where
  345.     eqElemsFold = foldr eqElems'[]
  346.     eqElems' :: Eq a => a -> [a] -> [a]
  347.     eqElems' e a@[_, _] = a -- ništa novo: nisu jednaki, nastavi foldati
  348.     eqElems' e a
  349.       | a == []   = [e]     -- prvi korak
  350.       | [e] == a  = [e]     -- jednaki elementi
  351.       | otherwise = (e:a)   -- nađen različit element
  352.  
  353. -- 4.4      
  354. instance Foldable RoseTree where
  355.   foldr f z RoseEmpty       = z
  356.   foldr f z (RoseTree e []) = f e (foldr f z RoseEmpty)
  357.   --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?    
  358.    
  359. -- 5.
  360.  
  361. -- 5.1
  362.  
  363. -- 5.2
  364. -- === DZ ============================================================================
clone this paste RAW Paste Data