Vector.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

module Data.Aviation.Navigation.Vector(
  Vector(..)
, Vector'
, vectorDegrees
, HasVector(..)
) where

import Control.Category ( Category(id, (.)) )
import Control.Lens ( view, Lens' )
import Data.Eq ( Eq )
import Data.Functor ( Functor(fmap) )
import Data.Monoid ( Monoid(mempty) )
import Data.Ord ( Ord )
import Data.Radian ( fromRadians )
import Data.Semigroup ( Semigroup((<>)) )
import GHC.Float ( Floating(cos, sqrt, pi, atan, sin), Double )
import GHC.Show(Show)
import Prelude(Num((*), (-), (+)), Fractional((/)))

data Vector a =
  Vector a a
  deriving (Eq, Ord, Show)

type Vector' =
  Vector Double

vectorDegrees ::
  Double
  -> Double
  -> Vector'
vectorDegrees =
  Vector . view fromRadians

instance Floating a => Semigroup (Vector a) where
  Vector aa am <> Vector ba bm =
    let square x = x * x
        t = aa - ba
        mag = sqrt (square am + square bm - 2 * am * bm * cos (pi - t))
        ang = atan (bm * sin t / (am + bm * cos t))
    in  Vector (aa - ang) mag

instance Floating a => Monoid (Vector a) where
  mempty =
    Vector 0 0

class HasVector a c | a -> c where
  vector ::
    Lens' a (Vector c)
  {-# INLINE angle #-}
  angle ::
    Lens' a c
  angle =
    vector . angle
  {-# INLINE magnitude #-}
  magnitude ::
    Lens' a c
  magnitude =
    vector . magnitude

instance HasVector (Vector a) a where
  vector = id
  {-# INLINE angle #-}
  angle f (Vector x y) =
    fmap (`Vector` y) (f x)
  {-# INLINE magnitude #-}
  magnitude f (Vector a y) =
    fmap (Vector a) (f y)