module Exercise_7_Sol where

import Data.Bits ((.&.), (.|.), complement)
import Data.Function (on)
import Data.List
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import Data.Ratio (numerator, denominator)
import Test.QuickCheck (Arbitrary, arbitrary, suchThat, (==>))

{- Library DO NOT CHANGE -}
toBinary :: Integral a => a -> String
toBinary 0 = "0"
toBinary x = reverse (aux x)
  where aux 0 = []
        aux x = (if x `mod` 2 == 0 then '0' else '1') : aux (x `div` 2)
        
instance Show IntegerBitSet where
  show (IntegerBitSet s) = "IntegerBitSet " ++ toBinary s
{- End Library -}

{-G7.1-}

data Fraction = Over Integer Integer

instance Show Fraction where
  show (a `Over` b) =
    if a == 0 then
      "0"
    else
      minus ++ show (abs a) ++ "/" ++ show (abs b)
    where minus = if (a < 0) /= (b < 0) then "-" else ""

-- also possible:
-- data Fraction = Over Integer Integer deriving Show

norm :: Fraction -> Fraction
norm (Over a b) = (a `div` c) `Over` (b `div` c)
  where c = gcd a b * (if b < 0 then -1 else 1)

instance Num Fraction where
  (a1 `Over` b1) + (a2 `Over` b2) = norm $ (a1*b2 + a2*b1) `Over` (b1 * b2)
  (a1 `Over` b1) - (a2 `Over` b2) = norm $ (a1*b2 - a2*b1) `Over` (b1 * b2)
  (a1 `Over` b1) * (a2 `Over` b2) = norm $ (a1 * a2) `Over` (b1 * b2)
  negate (a `Over` b) = negate a `Over` b
  fromInteger n = n `Over` 1
  abs (a `Over` b) = abs a `Over` abs b
  signum (a `Over` b) = (signum a * signum b) `Over` 1

instance Eq Fraction where
  (a1 `Over` b1) == (a2 `Over` b2) = a1*b2 == a2*b1

instance Fractional Fraction where
  recip (a `Over` b) = (b `Over` a)
  fromRational r = numerator r `Over` denominator r

-- Tests

prop_abs_signum x y = y /= 0 ==>
  abs frac * signum frac == frac
  where frac = Over x y

-- We can also define an instance of `Arbitrary`

instance Arbitrary Fraction where
  arbitrary = do
    num <- arbitrary
    den <- arbitrary `suchThat` (/= 0)
    return $ num `Over` den

prop_abs_signum' frac =
  abs frac * signum frac == (frac :: Fraction)

prop_minus_consistent frac1 frac2 =
  frac1 - frac2 == frac1 + (negate frac2 :: Fraction)

prop_plus_comm frac1 frac2 =
  frac1 + frac2 == frac2 + (frac1 :: Fraction)

prop_times_comm frac1 frac2 =
  frac1 * frac2 == frac2 * (frac1 :: Fraction)

-- ... and countless other (ring) laws


{-G7.2-}

f1 xs = map (\x -> x + 1) xs
f2 xs = map (\x -> 2 * x) (map (\x -> x + 1) xs)
f3 xs = filter (\x -> x > 1) (map (\x -> x + 1) xs)
f4 f g x = f (g x)
f5 f g x y = f (g x y)
f6 f g x y z = f (g x y z)
f7 f g h x = g (h (f x))

f1' = map (+1)

f2' = map (2*) . map (+1)
f2'' = map ((2*) . (+1))

f3' = filter (>1) . map (+1)

f4' f g = f . g
f4'' f = (.) f
f4''' = (.)

f5' f g x = f . g x
f5'' f g = ((.).(.)) f g
f5''' f = ((.).(.)) f
f5'''' = (.).(.)  -- vgl. "oo"

f6' f g x y = f . g x y
f6'' f g x = (.) f . g x
f6''' f g = ((.).(.)) f . g
f6'''' f g = ((.).(.).(.)) f g
f6''''' f = ((.).(.).(.)) f
f6'''''' = (.).(.).(.)


f7' f g h = g . h . f
-- So weit, so gut. Vernünftigerweise hört man hier wohl auf. Das heißt aber
-- nicht, dass man das nicht noch weiter treiben kann ...
f7_2 f g h = (.) (g . h) f
f7_3 f g h = flip (.) f (g . h)
f7_4 f g h = flip (.) f ((.) g h)
f7_5 f = flip (.) f `oo` (.)
  where oo = (.).(.)
f7_6 f = ((.).(.)) (flip (.) f) (.)
f7_7 f = flip ((.).(.)) (.) (flip (.) f)
f7_8 = flip ((.).(.)) (.) . flip (.)
-- Jetzt haben wir alle Parameter eliminiert. Ein solcher Ausdruck
-- heißt 'point-free' (da keine expliziten "Punkte" (== Werte) mehr
-- vorkommen). Solche extremen Anwendungen werden in der Haskell-Welt
-- auch gerne mal als 'pointless' bezeichnet ...
--
-- Wer noch nicht genug hat, darf jetzt überlegen, warum wir die
-- Definition noch zu Folgendem vereinfachen dürfen:
f7_9 = flip ((.).(.)) . flip (.)

-- f7_9 f g h x
-- = (flip oo . flip (.)) f g h x
-- = (flip oo (flip (.) f)) g h x
-- = flip oo (. f) g h x
-- = (\y -> oo y (. f)) g h x
-- = oo g (. f) h x
-- = (\a b c d -> a (b c d)) g (. f) h x
-- = g ((. f) h x)
-- = g ((h . f) x)
-- = g (h (f x))

-- f7_8 f g h x
-- = (flip oo (.) . flip (.)) f g h x
-- = flip oo (.) (flip (.) f) g h x
-- = flip oo (.) (. f) g h x
-- = (\y z -> oo z y) (.) (. f) g h x
-- = oo (. f) (.) g h x
-- = (\a b c d -> a (b c d)) (. f) (.) g h x
-- = (. f) ((.)g h) x
-- = (. f) (g . h) x
-- = (g . h . f) x
-- = g (h (f x))


{-G7.3-}

data Shape =
  Circle Integer |
  Rectangle Integer Integer
  deriving (Show, Eq)

isValid :: Shape -> Bool
isValid (Circle r) = r >= 0
isValid (Rectangle h w) = h >= 0 && w >= 0

scale :: Integer -> Shape -> Shape
scale n (Circle r) = Circle (r * n)
scale n (Rectangle h w) = Rectangle (h * n) (w * n)

-- We represent triangles via the lengths of all sides.
-- There are other ways though, e.g. the lengths of two sides and
-- the angle between them. For other representations, `isValid` and
-- `scale` look differently.

data Shape' =
  Circle' Integer |
  Rectangle' Integer Integer |
  Triangle' Integer Integer Integer
  deriving (Show, Eq)

isValid' :: Shape' -> Bool
isValid' (Circle' r) = r >= 0
isValid' (Rectangle' h w) = h >= 0 && w >= 0
isValid' (Triangle' a b c) = a >= 0 && b >= 0 && c >= 0 && a + b >= c && a + c >= b && b + c >= a

scale' :: Integer -> Shape' -> Shape'
scale' n (Circle' r) = Circle' (r * n)
scale' n (Rectangle' h w) = Rectangle' (h * n) (w * n)
scale' n (Triangle' a b c) = Triangle' (a * n) (b * n) (c * n)


{-H7.1-}

class BitSet a where
  empty    :: a
  getBit   :: Int -> a -> Bool
  setBit   :: Int -> a -> a
  unsetBit :: Int -> a -> a

data BoolListBitSet = BoolListBitSet [Bool] deriving Show
  
instance BitSet BoolListBitSet where
  empty = BoolListBitSet []
  getBit i (BoolListBitSet xs) = i < length xs && xs !! i
  setBit i (BoolListBitSet xs) = case splitAt i xs of
                                   (xs1, [])    -> BoolListBitSet (xs1 ++ replicate (i - length xs1) False ++ [True])
                                   (xs1, _:xs2) -> BoolListBitSet (xs1 ++ [True] ++ xs2)
  unsetBit i (BoolListBitSet xs) = case splitAt i xs of
                                     (xs1, [])    -> BoolListBitSet xs1
                                     (xs1, _:xs2) -> BoolListBitSet (xs1 ++ [False] ++ xs2)

data IntegerBitSet = IntegerBitSet Integer

instance BitSet IntegerBitSet where
  empty = IntegerBitSet 0
  getBit i (IntegerBitSet s) = s .&. (2^i) /= 0
  setBit i (IntegerBitSet s) = IntegerBitSet (s .|. (2^i))
  unsetBit i (IntegerBitSet s) = IntegerBitSet (s .&. complement (2^i))

fromList :: BitSet a => [Int] -> a
fromList = foldl (\s i -> setBit i s) empty


{-H7.2-}

type Point3 = (Integer, Integer, Integer)

data Shape3 = Cuboid Point3 Point3 | Sphere Point3 Integer
  deriving (Show, Eq)

makeCuboid :: Point3 -> Point3 -> Shape3
makeCuboid = Cuboid

makeSphere :: Point3 -> Integer -> Shape3
makeSphere = Sphere

boundingBox :: Shape3 -> (Point3, Point3)
boundingBox (Cuboid (x1, y1, z1) (x2, y2, z2)) = ((min x1 x2, min y1 y2, min z1 z2), (max x1 x2, max y1 y2, max z1 z2))
boundingBox (Sphere (x, y, z) r) = ((x - r', y - r', z - r'), (x + r', y + r', z + r'))
  where r' = abs r

overlapping :: Shape3 -> Shape3 -> Bool
overlapping s1 s2 =
  max minX1 minX2 <= min maxX1 maxX2 &&
  max minY1 minY2 <= min maxY1 maxY2 &&
  max minZ1 minZ2 <= min maxZ1 maxZ2
  where ((minX1,minY1,minZ1), (maxX1,maxY1,maxZ1)) = boundingBox s1
        ((minX2,minY2,minZ2), (maxX2,maxY2,maxZ2)) = boundingBox s2

{-H7.3-}

data Line a = Line (a,a) a
    deriving Show

lineX :: Line a -> a
lineX (Line (x,_) _) = x

lineY :: Line a -> a
lineY (Line (_,y) _) = y

-- Kombiniert alle überlappenden Linien einer Schicht.
-- Annahme: alle Linien in der Eingabe haben das gleiche y und die Liste ist nach aufsteigenden x sortiert
mergeLayer :: (Num a, Ord a) => [Line a] -> [Line a]
mergeLayer (l1@(Line (x1,y) w1) : l2@(Line (x2,_) w2) : ls)
  | x2 <= x1 + w1 = mergeLayer (Line (x1,y) w12 : ls) -- Linien überlappen - müssen kombiniert werden
  | otherwise     = l1 : mergeLayer (l2 : ls)         -- Linien überlappen nicht - unverändert übernehmen
  where w12 = max w1 (x2 - x1 + w2)                   -- Breite der kombinierten Linie
mergeLayer ls = ls

longestLines :: (Num a, Ord a) => [Line a] -> [Line a]
longestLines = concat . mergeLayers . groupLines
  where -- Fasse jeweils alle Linien mit gleichem y zu einer "Schicht" zusammen
        groupLines = groupBy ((==) `on` lineY) . sortBy (comparing lineY)
        -- Kombiniere alle überlappenden Linien einer Schicht
        mergeLayers = map (mergeLayer . sortBy (compare `on` lineX))


{-H7.4-}

type Point = (Integer, Integer)

allPairs :: [a] -> [(a, [a])]
allPairs [] = []
allPairs (x : xs) = (x, xs) : map (\(y, ys) -> (y, x : ys)) (allPairs xs)

manhattanDistance :: Point -> Point -> Integer
manhattanDistance (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)

manhattanCompareWrt :: Point -> Point -> Point -> Ordering
manhattanCompareWrt a b c =
  compare (manhattanDistance a b) (manhattanDistance a c)

nearestNeighbors :: [Point] -> [(Point, Point)]
nearestNeighbors = map nearestNeighbor . allPairs
  where nearestNeighbor (a, as) = (a, minimumBy (manhattanCompareWrt a) as)