module Sol_Exercise_7 where

import Control.Applicative
import Data.List as List
import Data.Maybe
import Data.Ratio
import Test.QuickCheck

{- G1 -}

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

{- G2 -}

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
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))

{- G3 -}

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 + 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)

{- H1 -}

area :: Shape -> Maybe Integer
area (Circle r) = Nothing
area (Rectangle h w) = Just (h * w)

rectArea :: [Shape] -> Integer
rectArea = sum . mapMaybe area

data PosShape = At Shape (Integer, Integer)

scale'' :: Integer -> PosShape -> PosShape
scale'' n (shape `At` coords) = scale n shape `At` coords

move :: (Integer, Integer) -> PosShape -> PosShape
move (a, b) (shape `At` (x, y)) = shape `At` (x + a, y + b)

{- H2 -}

data Colour =
  RGB Float Float Float |
  YUV Float Float Float
  deriving (Show, Eq)

inRange :: Ord a => a -> a -> a -> Bool
inRange l h x = l <= x && x <= h

uMax :: Float
uMax = 0.436

vMax :: Float
vMax = 0.615

isColourValid :: Colour -> Bool
isColourValid (RGB r g b) =
  inRange 0 1 r &&
  inRange 0 1 g &&
  inRange 0 1 b
isColourValid (YUV y u v) =
  inRange 0 1 y &&
  inRange (-uMax) uMax u &&
  inRange (-vMax) vMax v

setRange :: Ord a => a -> a -> a -> a
setRange l h x =
  if x < l then
    l
  else if x > h then
    h
  else
    x

colourToRGB :: Colour -> (Float, Float, Float)
colourToRGB (RGB r g b) = (r, g, b)
colourToRGB (YUV y u v) = (r', g', b')
  where wr = 0.299
        wg = 0.587
        wb = 0.114
        r = y + v * (1 - wr) / vMax
        g = y - u * wb * (1 - wb) / (uMax * wg) - v * wr * (1 - wr) / (vMax * wg)
        b = y + u * (1 - wb) / uMax
        r' = setRange 0 1 r
        g' = setRange 0 1 g
        b' = setRange 0 1 b

redComponent :: Colour -> Float
redComponent c = let (r, _, _) = colourToRGB c in r

greenComponent :: Colour -> Float
greenComponent c = let (_, g, _) = colourToRGB c in g

blueComponent :: Colour -> Float
blueComponent c = let (_, _, b) = colourToRGB c in b

{- Internal stuff, ignore -}

rgbGen = RGB <$> choose (0, 1) <*> choose (0, 1) <*> choose (0, 1)
yuvGen = YUV <$> choose (0, 1) <*> choose (-uMax, uMax) <*> choose (-vMax, vMax)

instance Arbitrary Colour where
  arbitrary = oneof [rgbGen, yuvGen]

prop_conv_valid c =
  isColourValid $ RGB r g b
  where (r, g, b) = colourToRGB c

{- End internal stuff -}


{- H3 -}

{-WETT-}
quasiIdentical :: String -> String -> Bool
quasiIdentical [] [] = True
quasiIdentical (c : cs) (d : ds) = (c == d && quasiIdentical cs ds) || cs == ds
quasiIdentical _ _ = False

fixTypo :: [String] -> String -> String
fixTypo vocabs word =
  if length quasis == 1 then head quasis else word
  where quasis = List.nub (List.filter (quasiIdentical word) vocabs)

fixTypos :: [String] -> [String] -> [String]
fixTypos = map . fixTypo
{-TTEW-}