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