-- University of Zagreb
-- Faculty of Electrical Engineering and Computing
--
-- PROGRAMMING IN HASKELL
--
-- Academic Year 2013/2014

-- The following are some *example* solutions to the 2nd homework
-- assignment. You were not required to write them out exactly like
-- this. They also contain syntax which we haven't covered in class up
-- to the time the homework was due. Note: some of the functions are
-- explicitly recursive, though they don't need to be. Versions that
-- don't explicitly use recursion are also possible, but were ommited
-- here for clarity.
--
-- If you spot an error somewhere, please notify us. Thanks!

module Homework where

import Data.List
import Data.Char

crossOne :: Int -> [a] -> [a] -> ([a], [a])
crossOne i xs ys = (take i ys ++ drop i xs, take i xs ++ drop i ys)

crossMany :: [Int] -> [a] -> [a] -> ([a], [a])
crossMany is xs ys =
  unzip [if i `elem` is then (y,x) else (x,y) | (i,x,y) <- zip3 [0..] xs ys]

interlace :: [a] -> [a] -> [a]
interlace xs ys = concat [[x,y] | (x,y) <- zip xs ys]

indices :: [a] -> [Int]
indices xs = [i | (i,_) <- zip [0..] xs]

suffixes :: [a] -> [[a]]
suffixes xs = [drop n xs | n <- indices xs] ++ [[]]

prefix :: Eq a => [a] -> [a] -> Bool
prefix [] _  = True
prefix _  [] = False
prefix (x:xs) (y:ys) = x == y && prefix xs ys

contains :: Eq a => [a] -> [a] -> Bool
contains _  [] = True
contains [] _  = False
contains xs ys = or [prefix ys s | s <- suffixes xs]

type Dict k v = [(k, v)]

exists :: Eq k => k -> Dict k v -> Bool
exists x d = or [x == k | (k,_) <- d]

get :: (Show k, Eq k) => Dict k v -> k -> v
get d x = head $ [v | (k,v) <- d, x == k] ++ [error msg]
  where
    msg = "key " ++ show x ++ " not found"

delete' :: Eq k => k -> Dict k v -> Dict k v
delete' k d = [i | i <- d, k /= fst i]

insert' :: Eq k => k -> v -> Dict k v -> Dict k v
insert' x v d
  | not $ exists x d = (x,v) : d
  | otherwise        = insert' x v $ delete' x d

sumNumbers :: String -> Int
sumNumbers s = sum [read w | w <- words s, digits w]
  where
    digits w = and [isDigit c | c <- w]

type Point = (Double, Double)
type Polygon = [Point]

dist :: Point -> Point -> Double
dist (x, y) (a, b) = sqrt $ (x-a)**2 + (y-b)**2

onLineSegment :: Point -> Point -> Point -> Bool
onLineSegment x a b = abs (dist x a + dist x b - dist a b) <= precision
  where
    precision = 0.00001

isValid :: Polygon -> Bool
isValid p = case p of
  (_:_:_:_) -> True
  _         -> False

links :: Polygon -> [(Point, Point)]
links ps = (last ps, head ps) : zip ps (tail ps)

perimeter :: Polygon -> Double
perimeter p
  | not $ isValid p = error "Not a valid polygon"
  | otherwise = sum [dist x y | (x,y) <- links p]

onPolygonBorder :: Point -> Polygon -> Bool
onPolygonBorder p ps
  | not $ isValid ps = error "Not a valid polygon"
  | otherwise = or [onLineSegment p x y | (x,y) <- links ps]

areAdjacent :: Polygon -> Polygon -> Bool
areAdjacent p q
  | not (isValid p) || not (isValid q) = error "Not a valid polygon"
  | otherwise = or [dist a b < 1 | a <- p, b <- q]

getAdjacent :: [Polygon] -> [(Int, Int)]
getAdjacent ps
  | any (not.isValid) ps = error "Not a valid polygon"
  | otherwise = [(i,j) | (i,p) <- zip [0..] ps,
                         (j,q) <- zip [i+1..] (drop (i+1) ps),
                         areAdjacent p q]

partition' :: [a -> Bool] -> [a] -> [[a]]
partition' ps as = [[a | a <- as, p a] | p <- ps]

swapAdjacent :: String -> String
swapAdjacent s = unwords $ swap $ words s
  where
    swap (x:y:zs) = y:x:swap zs
    swap _ = []

type Alphabet = String

alphabetSort :: String -> Alphabet -> String
alphabetSort cs as
  | or [toLower c `notElem` as' | c <- cs] = error "incomplete alphabet"
  | length as /= length as' = error "invalid alphabet"
  | otherwise = concat [sort [c | c <- cs, toLower c == a] | a <- as']
  where
    as' = nub [a | a <- as, isLower a]

funEq :: Eq b => [a] -> (a -> b) -> (a -> b) -> Bool
funEq xs p q = map' p xs == map' q xs
  where
    map' f as = [f a | a <- as]

funEq2 :: Eq c => [a] -> [b] -> (a -> b -> c) -> (a -> b -> c) -> Bool
funEq2 xs ys p q = and [p x y == q x y | x <- xs, y <- ys]

tabulate :: [a] -> (a -> b) -> [(a, b)]
tabulate xs p = zip xs [p x | x <- xs]

injective :: Eq b => [a] -> (a -> b) -> Bool
injective xs p = length xs == length (nub [p x | x <- xs])

totalInv :: Eq b => [a] -> (a -> b) -> b -> [a]
totalInv xs f y = [x | x <- xs, f x == y]

inv :: Eq b => [a] -> (a -> b) -> b -> a
inv xs f y
  | null ims  = error "no image"
  | otherwise = head ims
  where
    ims = totalInv xs f y