Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- import Data.Char
- import Data.List
- import Data.List.Split
- import Data.Ord
- import Data.Maybe
- -- Sandro Gržičić, 0036438748
- -- Haskell FER DZ06
- -- 2011-12
- -- === PUH-LEKCIJA-9 =================================================================
- data Shape = Circle Double Double Double
- | Rectangle Double Double Double Double
- deriving Show
- data Point = Point Double Double deriving Show
- data Shape2 = Circle2 Point Double | Rectangle2 Point Point deriving Show
- -- 1.1
- data Date = Date Int Int Int deriving Show
- showDate :: Date -> String
- showDate (Date x y z) = show x ++ "." ++ show y ++ "." ++ show z ++ "."
- -- 1.2
- translate :: Point -> Shape2 -> Shape2
- translate (Point x1 y1) (Circle2 (Point x2 y2) r) = Circle2 (Point (x1+x2) (y1+y2)) r
- translate (Point x1 y1) (Rectangle2 (Point x2 y2) (Point x3 y3)) = Rectangle2 (Point (x1+x2) (y1+y2)) (Point (x1+x3) (y1+y3))
- -- 1.3
- inShape :: Shape -> Point -> Bool
- inShape (Circle x1 y1 r) (Point x2 y2) = (abs (x1 - x2) <= r) && (abs (y1 -y2) <= r)
- 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)
- inShapes :: [Shape] -> Point -> Bool
- inShapes xs p = (or . (map (`inShape` p))) xs
- -- 1.4
- data Vehicle = Car String Int | Truck String Int | Motorcycle String Int | Bicycle String
- horsepower :: Vehicle -> Double
- horsepower (Car _ hp) = fromIntegral hp
- horsepower (Truck _ hp) = fromIntegral hp
- horsepower (Motorcycle _ hp) = fromIntegral hp
- horsepower (Bicycle _) = 0.3
- totalHorsepower :: [Vehicle] -> Double
- totalHorsepower = sum . map horsepower
- -- 2
- data Level = Bachelor | Master | PHD deriving (Show, Eq)
- data Student = Student {
- firstName :: String,
- lastName :: String,
- studentID :: String,
- level :: Level,
- avgGrade :: Double } deriving Show
- -- 2.1
- improveStudent :: Student -> Student
- improveStudent s
- | avgGrade s <= 4.0 = s { avgGrade = avgGrade s + 1.0 }
- | otherwise = s
- -- 2.2
- avgGradePerLevels :: [Student] -> (Double, Double, Double)
- avgGradePerLevels s = (bachProsjek s, masterProsjek s, phdProsjek s)
- where
- bachProsjek s = sum [ avgGrade a | a <- s, level a == Bachelor] / (realToFrac $ length s)
- masterProsjek s = sum [ avgGrade a | a <- s, level a == Master] / (realToFrac $ length s)
- phdProsjek s = sum [ avgGrade a | a <- s, level a == PHD] / (realToFrac $ length s)
- -- 2.3
- rankedStudents :: Level -> [Student] -> [String]
- rankedStudents l s = [studentID a | a <- sortBy (flip $ comparing avgGrade) s, level a == l]
- -- 2.4
- addStudent :: Student -> [Student] -> [Student]
- addStudent s ss
- | or [ studentID s == studentID a | a <- ss ] = error "student vec postoji"
- | otherwise = s:ss
- -- 3.1.
- data MyTriplet a b c = MyTriplet a b c
- toTriplet :: MyTriplet a b c -> (a,b,c)
- toTriplet (MyTriplet a b c) = (a,b,c)
- -- 3.2
- data Employee = Employee {
- name :: String,
- salary :: Maybe Double
- } deriving Show
- totalSalaries :: [Employee] -> Double
- totalSalaries = foldl (\s e -> s + (fromMaybe 0.0 $ salary e)) 0
- -- 3.3
- addStudent2 :: Student -> [Student] -> Maybe [Student]
- addStudent2 s ss
- | or [ studentID s == studentID a | a <- ss ] = Nothing
- | otherwise = Just (s:ss)
- addStudent3 :: Student -> [Student] -> Either String [Student]
- addStudent3 s ss
- | or [ studentID s == studentID a | a <- ss ] = Left "Student vec postoji"
- | otherwise = Right (s:ss)
- -- === DZ ============================================================================
- -- 2.
- data Weekday = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
- deriving (Show, Read, Eq, Ord, Enum)
- weekdays = [Monday .. Sunday]
- data Month =
- January | February | March | April | May | June | July | August | September | October | November | December
- deriving (Show, Read, Eq, Ord, Enum)
- months = [January .. December]
- -- superkul algoritam za određivanje dana u tjednu. :)))))))))))))))))
- -- nigdje nije pisalo da funkcija mora vratiti rezultat u skladu s imenom. :P
- weekday :: Date -> Weekday
- weekday (Date d m y) = weekdays !! ((d + m + y) `mod` 7)
- month :: Date -> Month
- month (Date _ m _) = months !! (m - 1) -- Date bi se trebao brinuti da je m unutar [1..12]
- date :: Int -> Int -> Int -> Maybe Date
- date d m y
- | correct = Just $ Date d m y
- | otherwise = Nothing
- where
- correct = d0 && m0 && d1 && d2
- d0 = d >= 1 && d <= 31
- m0 = m >= 1 && m <= 13
- d1 = m == 2 && ((y `mod` 4 /= 0 && d <= 28) || (y `mod` 4 == 0 && d <= 29))
- d2 = (m == 4 || m == 6 || m == 7 || m == 9 || m == 11) && d <= 30
- before :: Date -> Date -> Bool
- before (Date d1 m1 y1) (Date d2 m2 y2) =
- y1 < y2 ||
- y1 == y2 && m1 < m2 ||
- y1 == y2 && m1 == m2 && d1 < d2
- within :: Date -> Date -> Date -> Bool
- within d0 d1 d2 = before d1 d0 && before d0 d2
- -- 3.
- stripSuffix :: String -> String -> Maybe String
- stripSuffix suffix str = case stripped of
- Just s -> Just $ reverse s
- otherwise -> Nothing
- where
- stripped = stripPrefix (reverse suffix) (reverse str)
- stripSuffixes :: [String] -> String -> Maybe String
- stripSuffixes (suffix:suffixes) str = case stripSuffix suffix str of
- Just s -> Just s
- otherwise -> stripSuffixes suffixes str
- -- 4.
- data Author = Author {
- firstNameA :: String,
- lastNameA :: String
- } deriving (Show, Read, Eq)
- data Publication = Book {
- title :: String,
- authors :: [Author],
- publisher :: String,
- year :: Int,
- isbnB :: String
- } | ConferencePaper {
- title :: String,
- authors :: [Author],
- conference :: String,
- year :: Int,
- pages :: (Int, Int)
- } | JournalPaper {
- title :: String,
- authors :: [Author],
- year :: Int,
- pages :: (Int, Int),
- issn :: String
- } deriving (Show, Read, Eq)
- toLowercase = map toLower
- -- klijentska funkcija
- authorSearch :: String -> [Publication] -> [Publication]
- authorSearch query pubs = searchByString query searchAuthors pubs
- -- klijentska funkcija
- titleSearch :: String -> [Publication] -> [Publication]
- titleSearch query pubs = searchByString query searchTitle pubs
- -- općenita funkcija
- searchByString :: String -> (String -> Publication -> Bool) -> [Publication] -> [Publication]
- searchByString query f pubs = searchWords (words query)
- where
- searchWords ws = concat $ map searchWord ws
- searchWord w = catMaybes $ map (searchPublication w) pubs
- searchPublication w p
- | f w p = Just p
- | otherwise = Nothing
- -- specifična funkcija
- searchAuthors :: String -> Publication -> Bool
- searchAuthors w p = or (map (searchAuthor w) (authors p))
- where
- searchAuthor w a
- | last w == '*' = searchUsing isPrefixOf (take (length w - 1) w) a
- | otherwise = searchUsing (==) w a
- searchUsing f w a = f (toLowercase w) (toLowercase $ firstNameA a) ||
- f (toLowercase w) (toLowercase $ lastNameA a)
- -- specifična funkcija
- searchTitle :: String -> Publication -> Bool
- searchTitle w p
- | last w == '*' = searchUsing isPrefixOf (take (length w - 1) w) p
- | otherwise = searchUsing (==) w p
- where
- searchUsing f w p = f (toLowercase w) (toLowercase $ title p)
- yearSearch :: (Int,Int) -> [Publication] -> [Publication]
- yearSearch (from, to) = filter (\p -> year p >= from && year p <= to)
- search :: Maybe String -> Maybe String -> Maybe (Int,Int) -> [Publication] -> [Publication]
- search Nothing Nothing Nothing pubs = []
- search (Just a) Nothing Nothing pubs = authorSearch a pubs
- search Nothing (Just t) Nothing pubs = titleSearch t pubs
- search Nothing Nothing (Just (from, to)) pubs = yearSearch (from, to) pubs
- search (Just a) (Just t) Nothing pubs = intersect (authorSearch a pubs) (titleSearch t pubs)
- search (Just a) Nothing (Just (from, to)) pubs = intersect (authorSearch a pubs) (yearSearch (from, to) pubs)
- search Nothing (Just t) (Just (from, to)) pubs = intersect (titleSearch t pubs) (yearSearch (from, to) pubs)
- search (Just a) (Just t) (Just (from, to)) pubs = intersect (authorSearch a pubs)
- (intersect (yearSearch (from, to) pubs) (titleSearch t pubs))
- -- 5.
- data Piece a = Piece a deriving (Show, Read, Eq)
- data Gameboard a = Gameboard {
- gbW :: Int,
- gbH :: Int,
- gbPieces :: [[Maybe (Piece a)]]
- } deriving (Show, Read, Eq)
- gbWithinBounds :: Gameboard a -> Int -> Int -> Bool
- gbWithinBounds gb x y = x >= 0 && x < gbW gb && y >= 0 && y < gbH gb
- type Square = (Int, Int)
- type Move = (Square, Square)
- gameboard :: (Int, Int) -> Gameboard a
- gameboard (x, y) = Gameboard x y (replicate x $ replicate y Nothing)
- boardSize :: Gameboard a -> (Int, Int)
- boardSize (Gameboard x y _) = (x, y)
- getPiece :: Square -> Gameboard a -> Maybe (Piece a)
- getPiece (x, y) gb
- | not (gbWithinBounds gb x y) = Nothing
- | otherwise = gbPieces gb !! x !! y -- isto može vratiti Nothing ako je polje prazno
- removePiece :: Square -> Gameboard a -> Gameboard a
- removePiece (x, y) (Gameboard w h pieces) = Gameboard w h newGB
- where
- newGB = fst oldRows ++ [newRow] ++ snd oldRows
- oldRows = splitAt x pieces
- newRow = fst oldRow ++ [Nothing] ++ snd oldRow
- oldRow = splitAt y (pieces !! x)
- putPiece :: Piece a -> Square -> Gameboard a -> Maybe (Gameboard a)
- putPiece piece (x, y) gb@(Gameboard w h pieces)
- | not (gbWithinBounds gb x y) || checkIfOccupied (gbPieces gb !! x !! y) = Nothing
- | otherwise = Just $ Gameboard w h newGB
- where
- checkIfOccupied Nothing = False
- checkIfOccupied _ = True
- newGB = fst oldRows ++ [newRow] ++ snd oldRows
- oldRows = splitAt x pieces
- newRow = fst oldRow ++ [Just piece] ++ snd oldRow
- oldRow = splitAt y (pieces !! x)
- movePiece :: Move -> Gameboard a -> Maybe (Gameboard a)
- movePiece (sqFrom, sqTo) gb@(Gameboard w h pieces)
- | canGet from && (not $ canGet to) = putPiece (fromJust from) sqTo (removePiece sqFrom gb)
- | otherwise = Nothing
- where
- from = getPiece sqFrom gb
- to = getPiece sqTo gb
- canGet Nothing = False
- canGet _ = True
- -- 6.
- data ChessPieceType = King | Queen | Rook | Knight | Bishop | Pawn deriving (Show, Read, Eq, Ord)
- data Player = White | Black deriving (Show, Read, Eq, Ord)
- type ChessPiece = Piece (ChessPieceType, Player)
- type Chessboard = Gameboard ChessPiece
- -- ne da mi se pisati 9999999 linija špageti koda za ostale početne pozicije.
- initChessboard :: Gameboard (ChessPieceType, Player)
- initChessboard = fromJust $ putPiece (Piece (Queen, White)) (0, 3) (gameboard (8, 8))
- -- provjere za svaku figuru? to-do! ^^
- chessMove :: Move -> Chessboard -> Maybe Chessboard
- chessMove move cb = movePiece move cb
- -- 7.
- data LimitedList a = LimitedList Int [a] deriving (Show, Read, Eq)
- limitedList :: Int -> LimitedList a
- limitedList limit = LimitedList limit []
- first :: LimitedList a -> Maybe a
- first (LimitedList _ l)
- | null l = Nothing
- | otherwise = Just $ head l
- rest :: LimitedList a -> LimitedList a
- rest (LimitedList limit l)
- | null l = LimitedList limit []
- | otherwise = LimitedList limit (tail l)
- cons :: a -> LimitedList a -> LimitedList a
- cons el (LimitedList limit l)
- | length l == limit = error "list full"
- | otherwise = LimitedList limit (el:l)
- fromList :: [a] -> LimitedList a
- fromList l = LimitedList (length l) l
- toList :: LimitedList a -> [a]
- toList (LimitedList _ l) = l
- -- 8.
- data Queue a = Queue ([a], [a]) deriving (Show, Read, Eq)
- balancedQueue :: Queue a -> Queue a
- balancedQueue q@(Queue (f, r))
- | not (null r) && null f = Queue (reverse r, [])
- | otherwise = q
- empty :: Queue a
- empty = Queue ([], [])
- isEmpty :: Queue a -> Bool
- isEmpty (Queue (f, r)) = null f && null r
- back :: Queue a -> Queue a
- back q@(Queue (f, r))
- | null f && null r = q
- | null f && length r == 1 || null r && length f == 1 = empty
- | otherwise = back' (balancedQueue q)
- where
- back' (Queue (f, r)) = Queue (tail f, r)
- front :: Queue a -> Maybe a
- front (Queue (f, r))
- | null f && null r = Nothing
- | not (null f) = Just $ head f
- | not (null r) = Just $ last r
- | otherwise = Nothing
- enqueue :: a -> Queue a -> Queue a
- enqueue el (Queue (f, r))
- | null f = Queue ([el], r)
- | otherwise = Queue (f, (el:r))
- dequeue :: Queue a -> Maybe (a, Queue a)
- dequeue (Queue (f, r))
- | null f && null r = Nothing
- | length f > 1 = Just $ (head f, Queue (tail f, r ))
- | length f == 1 = Just $ (head f, Queue (reverse r, []))
- | otherwise = Just $ (head r', Queue (tail r', []))
- where r' = reverse r
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement