Internal.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | This module defines the internals of a line.  You probably won't
-- need this module when using the geomtry libary.

module Geom2d.Line.Internal where

import Test.QuickCheck
import Data.Maybe
import Data.AEq
import Geom2d.Point
import Geom2d.Translate
import Geom2d.Distance
import Control.Monad

-- | This type modells a infinite line.
data InfLine p a = InfLine (p a) (p a) deriving (Show, Read)

-- | `InfLine` is a `Functor` where the function is mapped over both
-- points which define the `InfLine`.
instance Functor p => Functor (InfLine p) where
  fmap f (InfLine a b) = InfLine (fmap f a) (fmap f b)

-- | This `Arbitrary` instance should only produce valid `InfLine`s.
instance (Eq (p a), Arbitrary (p a)) => Arbitrary (InfLine p a) where
  arbitrary = do p1 <- arbitrary
                 p2 <- arbitrary `suchThat` (/= p1)
                 return $ InfLine p1 p2

-- | Two lines are equal when they have the same root and the same
-- slope.  If the two lines do not have a root, that means that the
-- lines are parallel to the x-axis.  In this case we compare their
-- y-value.
instance (Eq (p a), Eq a, RealFloat a, Num (p a), Point p) =>
         Eq (InfLine p a) where
  a@(InfLine a1 _) == b@(InfLine b1 _)
      -- If the slopes of the lines are not equal they cannot be the
      -- equal themselves
      | slope a /= slope b = False
      -- When the slopes are vertical they should have the same x
      -- component
      | isNothing (slope a) = x a1 == x b1
      | otherwise = case root a of
                      Just _ -> fromMaybe False ( (==) <$> root a <*> root b )
                      Nothing -> y a1 == y b1
      where slope (InfLine m n) | x (n - m) == 0 = Nothing
                                | otherwise = Just $ y (n - m) / x (n - m)
            root l@(InfLine p q) | y p == y q = Nothing
                                 | otherwise = 
                                     (do dy <- slope l
                                         return (x q - (y q / dy))) `mplus`
                                     Just (x p)

-- | Translate a line by a given vector.
instance Translate p => Translate (InfLine p) where
  translate m (InfLine p q) = InfLine (m `translate` p) (m `translate` q)

-- | Modells a finite line stretching between two points.
data FinLine p a = -- | We expect the two points to be different
                   FinLine (p a) (p a) deriving (Show,Read)

-- | Two lines are equal if their end points are equal.
--
-- prop> FinLine a b == FinLine b a
instance (Eq (p a)) => Eq (FinLine p a) where
  (FinLine a1 b1) == (FinLine a2 b2) =
    (a1 == a2 && b1 == b2) ||
    (a1 == b2 && b1 == a2)

-- | This `Arbitrary` instance should only produce valid `FinLine`s.
instance (Eq (p a), Arbitrary (p a)) => Arbitrary (FinLine p a) where
  arbitrary = do p1 <- arbitrary
                 p2 <- arbitrary `suchThat` (/= p1)
                 return $ FinLine p1 p2

-- | Translate a `FinLine` by a fiven vector
instance Translate p => Translate (FinLine p) where
  translate v (FinLine p q) = FinLine (v `translate` p) (v `translate` q)

-- | Two lines are almost equal if their ending points are almost
-- equal.
instance AEq (p a) => AEq (FinLine p a) where
  (FinLine a1 b1) ~== (FinLine a2 b2) =
    (a1 ~== a2 && b1 ~== b2) ||
    (a1 ~== b2 && b1 ~== a2)

instance (Point p) =>
         Distance (FinLine p) p where
  distance (FinLine a b) p =
    sqrt (dx*dx + dy*dy)
    where dx = ax + (u * qx) - px
          dy = ay + (u * qy) - py
          qx = bx - ax
          qy = by - ay
          s = qx^(2::Int) + qy^(2::Int)
          u' = ((px - ax)*qx + (py - ay)*qy)/s
          u | u' > 1    = 1
            | u' < 0    = 0
            | otherwise = u'
          py = y p
          px = x p
          ax = x a
          ay = y a
          bx = x b
          by = y b

instance (Point p) =>
         Distance p (FinLine p) where
  distance = flip distance