Pastebin launched a little side project called HostCabi.net, check it out ;-)Don't like ads? PRO users don't see any ads ;-)
Guest

Untitled

By: a guest on Jan 8th, 2012  |  syntax: Haskell  |  size: 12.54 KB  |  hits: 80  |  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
  3. import Data.List.Split
  4. import Data.Ord
  5. import Data.Maybe
  6.  
  7. -- Sandro Gržičić, 0036438748
  8. -- Haskell FER DZ06
  9. -- 2011-12
  10.  
  11. -- === PUH-LEKCIJA-9 =================================================================
  12.  
  13. data Shape = Circle Double Double Double
  14.            | Rectangle Double Double Double Double
  15.              deriving Show
  16.  
  17. data Point = Point Double Double deriving Show
  18. data Shape2 = Circle2 Point Double | Rectangle2 Point Point deriving Show
  19.  
  20. -- 1.1
  21. data Date = Date Int Int Int deriving Show
  22.  
  23. showDate :: Date -> String
  24. showDate (Date x y z) = show x ++ "." ++ show y ++ "." ++ show z ++ "."
  25.  
  26. -- 1.2
  27.  
  28. translate :: Point -> Shape2 -> Shape2
  29. translate (Point x1 y1) (Circle2 (Point x2 y2) r) =  Circle2 (Point (x1+x2) (y1+y2)) r
  30. translate (Point x1 y1) (Rectangle2 (Point x2 y2) (Point x3 y3)) = Rectangle2 (Point (x1+x2) (y1+y2)) (Point (x1+x3) (y1+y3))
  31.  
  32. -- 1.3
  33. inShape :: Shape -> Point -> Bool
  34. inShape (Circle x1 y1 r) (Point x2 y2) = (abs (x1 - x2) <= r) && (abs (y1 -y2) <= r)
  35. inShape (Rectangle x1 y1 x2 y2) (Point x3 y3) = (x3 <= max x1 x2) && (x3 >= min x1 x2) && (y3 <= max y1 y2) && (y3 >= min y1 y2)
  36.  
  37. inShapes :: [Shape] -> Point -> Bool
  38. inShapes xs p = (or . (map (`inShape` p))) xs
  39.  
  40. -- 1.4
  41. data Vehicle = Car String Int | Truck String Int | Motorcycle String Int | Bicycle String
  42.  
  43. horsepower :: Vehicle -> Double
  44. horsepower (Car _ hp) = fromIntegral hp
  45. horsepower (Truck _ hp) = fromIntegral hp
  46. horsepower (Motorcycle _ hp) = fromIntegral hp
  47. horsepower (Bicycle _) = 0.3
  48.  
  49. totalHorsepower :: [Vehicle] -> Double
  50. totalHorsepower = sum . map horsepower
  51.  
  52.  
  53. -- 2
  54. data Level = Bachelor | Master | PHD deriving (Show, Eq)
  55.  
  56. data Student = Student {
  57.     firstName :: String,
  58.     lastName  :: String,
  59.     studentID :: String,
  60.     level     :: Level,
  61.     avgGrade  :: Double } deriving Show
  62.  
  63. -- 2.1
  64. improveStudent :: Student -> Student
  65. improveStudent s
  66.   | avgGrade s <= 4.0 = s { avgGrade = avgGrade s + 1.0 }
  67.   | otherwise         = s
  68.  
  69. -- 2.2
  70. avgGradePerLevels :: [Student] -> (Double, Double, Double)
  71. avgGradePerLevels s = (bachProsjek s, masterProsjek s, phdProsjek s)
  72.   where
  73.     bachProsjek s   = sum [ avgGrade a | a <- s, level a == Bachelor] / (realToFrac $ length s)
  74.     masterProsjek s = sum [ avgGrade a | a <- s, level a == Master]   / (realToFrac $ length s)
  75.     phdProsjek s    = sum [ avgGrade a | a <- s, level a == PHD]      / (realToFrac $ length s)
  76.  
  77. -- 2.3
  78. rankedStudents :: Level -> [Student] -> [String]
  79. rankedStudents l s = [studentID a | a <- sortBy (flip $ comparing avgGrade) s, level a == l]
  80.  
  81. -- 2.4
  82. addStudent :: Student -> [Student] -> [Student]
  83. addStudent s ss
  84.   | or [ studentID s == studentID a | a <- ss ] = error "student vec postoji"
  85.   | otherwise = s:ss
  86.  
  87. -- 3.1.
  88. data MyTriplet a b c = MyTriplet a b c
  89.  
  90. toTriplet :: MyTriplet a b c -> (a,b,c)
  91. toTriplet (MyTriplet a b c) = (a,b,c)
  92.  
  93. -- 3.2
  94. data Employee = Employee {
  95.   name :: String,
  96.   salary :: Maybe Double
  97. } deriving Show
  98.  
  99. totalSalaries :: [Employee] -> Double
  100. totalSalaries = foldl (\s e -> s + (fromMaybe 0.0 $ salary e)) 0
  101.  
  102. -- 3.3
  103. addStudent2 :: Student -> [Student] -> Maybe [Student]
  104. addStudent2 s ss
  105.   | or [ studentID s == studentID a | a <- ss ] = Nothing
  106.   | otherwise = Just (s:ss)
  107.  
  108. addStudent3 :: Student -> [Student] -> Either String [Student]
  109. addStudent3 s ss
  110.   | or [ studentID s == studentID a | a <- ss ] = Left "Student vec postoji"
  111.   | otherwise = Right (s:ss)
  112.  
  113. -- === DZ ============================================================================
  114.  
  115. -- 2.
  116. data Weekday = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
  117.  deriving (Show, Read, Eq, Ord, Enum)
  118. weekdays = [Monday .. Sunday]
  119.  
  120. data Month =
  121.   January | February | March | April | May | June | July | August | September | October | November | December
  122.   deriving (Show, Read, Eq, Ord, Enum)
  123. months = [January .. December]  
  124.  
  125. -- superkul algoritam za određivanje dana u tjednu. :)))))))))))))))))
  126. -- nigdje nije pisalo da funkcija mora vratiti rezultat u skladu s imenom. :P
  127. weekday :: Date -> Weekday
  128. weekday (Date d m y) = weekdays !! ((d + m + y) `mod` 7)  
  129.  
  130. month :: Date -> Month
  131. month (Date _ m _) = months !! (m - 1) -- Date bi se trebao brinuti da je m unutar [1..12]
  132.  
  133. date :: Int -> Int -> Int -> Maybe Date
  134. date d m y
  135.   | correct = Just $ Date d m y
  136.   | otherwise = Nothing
  137.   where
  138.     correct = d0 && m0 && d1 && d2
  139.     d0 = d >= 1 && d <= 31
  140.     m0 = m >= 1 && m <= 13
  141.     d1 = m == 2 && ((y `mod` 4 /= 0 && d <= 28) || (y `mod` 4 == 0 && d <= 29))  
  142.     d2 = (m == 4 || m == 6 || m == 7 || m == 9 || m == 11) && d <= 30
  143.  
  144. before :: Date -> Date -> Bool
  145. before (Date d1 m1 y1) (Date d2 m2 y2) =
  146.   y1 < y2 ||
  147.   y1 == y2 && m1 < m2 ||
  148.   y1 == y2 && m1 == m2 && d1 < d2
  149.  
  150. within :: Date -> Date -> Date -> Bool
  151. within d0 d1 d2 = before d1 d0 && before d0 d2
  152.  
  153. -- 3.
  154. stripSuffix :: String -> String -> Maybe String
  155. stripSuffix suffix str = case stripped of
  156.   Just s -> Just $ reverse s
  157.   otherwise -> Nothing
  158.   where
  159.     stripped = stripPrefix (reverse suffix) (reverse str)
  160.    
  161. stripSuffixes :: [String] -> String -> Maybe String
  162. stripSuffixes (suffix:suffixes) str = case stripSuffix suffix str of
  163.   Just s -> Just s
  164.   otherwise -> stripSuffixes suffixes str
  165.  
  166. -- 4.
  167. data Author = Author {
  168.   firstNameA :: String,
  169.   lastNameA :: String
  170. } deriving (Show, Read, Eq)
  171.  
  172. data Publication = Book {
  173.   title :: String,
  174.   authors :: [Author],
  175.   publisher :: String,
  176.   year :: Int,
  177.   isbnB :: String
  178. } | ConferencePaper {
  179.   title :: String,
  180.   authors :: [Author],
  181.   conference :: String,
  182.   year :: Int,
  183.   pages :: (Int, Int)
  184. } | JournalPaper {
  185.   title :: String,
  186.   authors :: [Author],
  187.   year :: Int,
  188.   pages :: (Int, Int),
  189.   issn :: String
  190. } deriving (Show, Read, Eq)
  191.  
  192. toLowercase = map toLower
  193.  
  194. -- klijentska funkcija
  195. authorSearch :: String -> [Publication] -> [Publication]
  196. authorSearch query pubs = searchByString query searchAuthors pubs
  197.  
  198. -- klijentska funkcija
  199. titleSearch :: String -> [Publication] -> [Publication]
  200. titleSearch query pubs = searchByString query searchTitle pubs  
  201.  
  202. -- općenita funkcija
  203. searchByString :: String -> (String -> Publication -> Bool) -> [Publication] -> [Publication]
  204. searchByString query f pubs = searchWords (words query)
  205.   where
  206.     searchWords ws = concat $ map searchWord ws
  207.     searchWord w = catMaybes $ map (searchPublication w) pubs
  208.     searchPublication w p
  209.       | f w p = Just p
  210.       | otherwise = Nothing
  211.  
  212. -- specifična funkcija
  213. searchAuthors :: String -> Publication -> Bool
  214. searchAuthors w p = or (map (searchAuthor w) (authors p))
  215.   where
  216.     searchAuthor w a
  217.       | last w == '*' = searchUsing isPrefixOf (take (length w - 1) w) a
  218.       | otherwise = searchUsing (==) w a
  219.     searchUsing f w a = f (toLowercase w) (toLowercase $ firstNameA a) ||
  220.                         f (toLowercase w) (toLowercase $ lastNameA a)    
  221. -- specifična funkcija
  222. searchTitle :: String -> Publication -> Bool
  223. searchTitle w p
  224.    | last w == '*' = searchUsing isPrefixOf (take (length w - 1) w) p
  225.    | otherwise = searchUsing (==) w p
  226.   where
  227.     searchUsing f w p = f (toLowercase w) (toLowercase $ title p)
  228.  
  229. yearSearch :: (Int,Int) -> [Publication] -> [Publication]
  230. yearSearch (from, to) = filter (\p -> year p >= from && year p <= to)
  231.  
  232. search :: Maybe String -> Maybe String -> Maybe (Int,Int) -> [Publication] -> [Publication]
  233. search Nothing Nothing Nothing pubs = []
  234.  
  235. search (Just a) Nothing  Nothing           pubs = authorSearch a pubs
  236. search Nothing  (Just t) Nothing           pubs = titleSearch t pubs
  237. search Nothing  Nothing  (Just (from, to)) pubs = yearSearch (from, to) pubs
  238. search (Just a) (Just t) Nothing           pubs = intersect (authorSearch a pubs) (titleSearch t pubs)
  239. search (Just a) Nothing  (Just (from, to)) pubs = intersect (authorSearch a pubs) (yearSearch (from, to) pubs)
  240. search Nothing (Just t)  (Just (from, to)) pubs = intersect (titleSearch t pubs)  (yearSearch (from, to) pubs)
  241. search (Just a) (Just t) (Just (from, to)) pubs = intersect (authorSearch a pubs)
  242.                                                     (intersect (yearSearch (from, to) pubs) (titleSearch t pubs))
  243.  
  244. -- 5.
  245. data Piece a = Piece a deriving (Show, Read, Eq)
  246. data Gameboard a = Gameboard {
  247.   gbW :: Int,
  248.   gbH :: Int,
  249.   gbPieces :: [[Maybe (Piece a)]]
  250. } deriving (Show, Read, Eq)
  251.  
  252. gbWithinBounds :: Gameboard a -> Int -> Int -> Bool
  253. gbWithinBounds gb x y = x >= 0 && x < gbW gb && y >= 0 && y < gbH gb
  254.  
  255. type Square = (Int, Int)
  256. type Move = (Square, Square)
  257.  
  258. gameboard :: (Int, Int) -> Gameboard a
  259. gameboard (x, y) = Gameboard x y (replicate x $ replicate y Nothing)
  260.  
  261. boardSize :: Gameboard a -> (Int, Int)
  262. boardSize (Gameboard x y _) = (x, y)
  263.  
  264. getPiece :: Square -> Gameboard a -> Maybe (Piece a)
  265. getPiece (x, y) gb
  266.   | not (gbWithinBounds gb x y) = Nothing
  267.   | otherwise = gbPieces gb !! x !! y -- isto može vratiti Nothing ako je polje prazno
  268.  
  269. removePiece :: Square -> Gameboard a -> Gameboard a
  270. removePiece (x, y) (Gameboard w h pieces) = Gameboard w h newGB
  271.   where
  272.     newGB = fst oldRows ++ [newRow] ++ snd oldRows
  273.     oldRows = splitAt x pieces
  274.     newRow = fst oldRow ++ [Nothing] ++ snd oldRow
  275.     oldRow = splitAt y (pieces !! x)
  276.    
  277. putPiece :: Piece a -> Square -> Gameboard a -> Maybe (Gameboard a)
  278. putPiece piece (x, y) gb@(Gameboard w h pieces)
  279.   | not (gbWithinBounds gb x y) || checkIfOccupied (gbPieces gb !! x !! y)  = Nothing
  280.   | otherwise = Just $ Gameboard w h newGB
  281.   where
  282.     checkIfOccupied Nothing = False
  283.     checkIfOccupied _ = True
  284.     newGB = fst oldRows ++ [newRow] ++ snd oldRows
  285.     oldRows = splitAt x pieces
  286.     newRow = fst oldRow ++ [Just piece] ++ snd oldRow
  287.     oldRow = splitAt y (pieces !! x)
  288.    
  289. movePiece :: Move -> Gameboard a -> Maybe (Gameboard a)
  290. movePiece (sqFrom, sqTo) gb@(Gameboard w h pieces)
  291.   | canGet from && (not $ canGet to) = putPiece (fromJust from) sqTo (removePiece sqFrom gb)
  292.   | otherwise = Nothing  
  293.   where
  294.     from = getPiece sqFrom gb
  295.     to = getPiece sqTo gb
  296.     canGet Nothing = False
  297.     canGet _ = True
  298.      
  299. -- 6.
  300. data ChessPieceType = King | Queen | Rook | Knight | Bishop | Pawn deriving (Show, Read, Eq, Ord)
  301. data Player = White | Black deriving (Show, Read, Eq, Ord)
  302.  
  303. type ChessPiece = Piece (ChessPieceType, Player)
  304. type Chessboard = Gameboard ChessPiece
  305.  
  306. -- ne da mi se pisati 9999999 linija špageti koda za ostale početne pozicije.
  307. initChessboard :: Gameboard (ChessPieceType, Player)
  308. initChessboard = fromJust $ putPiece (Piece (Queen, White)) (0, 3) (gameboard (8, 8))
  309.  
  310. -- provjere za svaku figuru? to-do! ^^
  311. chessMove :: Move -> Chessboard -> Maybe Chessboard
  312. chessMove move cb = movePiece move cb  
  313.  
  314. -- 7.
  315. data LimitedList a = LimitedList Int [a] deriving (Show, Read, Eq)  
  316.  
  317. limitedList :: Int -> LimitedList a
  318. limitedList limit = LimitedList limit []
  319.  
  320. first :: LimitedList a -> Maybe a
  321. first (LimitedList _ l)
  322.   | null l = Nothing
  323.   | otherwise = Just $ head l
  324.  
  325. rest :: LimitedList a -> LimitedList a
  326. rest (LimitedList limit l)
  327.   | null l    = LimitedList limit []
  328.   | otherwise = LimitedList limit (tail l)
  329.  
  330. cons :: a -> LimitedList a -> LimitedList a
  331. cons el (LimitedList limit l)
  332.   | length l == limit = error "list full"
  333.   | otherwise = LimitedList limit (el:l)
  334.  
  335. fromList :: [a] -> LimitedList a
  336. fromList l = LimitedList (length l) l
  337.  
  338. toList :: LimitedList a -> [a]
  339. toList (LimitedList _ l) = l
  340.  
  341. -- 8.
  342. data Queue a = Queue ([a], [a]) deriving (Show, Read, Eq)
  343.  
  344. balancedQueue :: Queue a -> Queue a
  345. balancedQueue q@(Queue (f, r))
  346.   | not (null r) && null f = Queue (reverse r, [])  
  347.   | otherwise = q
  348.  
  349. empty :: Queue a
  350. empty = Queue ([], [])
  351.  
  352. isEmpty :: Queue a -> Bool
  353. isEmpty (Queue (f, r)) = null f && null r
  354.  
  355. back :: Queue a -> Queue a
  356. back q@(Queue (f, r))
  357.   | null f && null r = q
  358.   | null f && length r == 1 || null r && length f == 1 = empty
  359.   | otherwise = back' (balancedQueue q)  
  360.   where
  361.     back' (Queue (f, r)) = Queue (tail f, r)
  362.  
  363. front :: Queue a -> Maybe a
  364. front (Queue (f, r))
  365.   | null f && null r = Nothing
  366.   | not (null f) = Just $ head f
  367.   | not (null r) = Just $ last r
  368.   | otherwise = Nothing
  369.  
  370. enqueue :: a -> Queue a -> Queue a
  371. enqueue el (Queue (f, r))
  372.   | null f = Queue ([el], r)
  373.   | otherwise = Queue (f, (el:r))
  374.  
  375. dequeue :: Queue a -> Maybe (a, Queue a)
  376. dequeue (Queue (f, r))
  377.   | null f && null r = Nothing
  378.   | length f > 1     = Just $ (head f,  Queue (tail f,    r ))
  379.   | length f == 1    = Just $ (head f,  Queue (reverse r, []))
  380.   | otherwise        = Just $ (head r', Queue (tail r',   []))
  381.   where r' = reverse r