WindCorrection.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Aviation.Navigation.WindCorrection(
  WindCorrection(..)
, HasWindCorrection(..)
, calculateWindCorrection
, printWindCorrection
, run
) where

import Control.Category ( Category(id, (.)) )
import Control.Lens ( view, Lens' )
import Options.Applicative
    ( (<**>), fullDesc, header, info, execParser, helper )
import Text.Printf ( PrintfArg, printf, PrintfType )
import Data.String ( IsString, String )
import Data.Radian ( toRadians )
import Data.Aviation.Navigation.Vector
    ( Vector(..), Vector', HasVector(..) )
import Data.Aviation.Navigation.WindComponent
    ( WindComponent, HasWindComponent(windComponent, headwind, crosswind), calculateWindComponent )
import Data.Aviation.Navigation.WindParameters
    ( HasWindParameters(trackTAS), optWindParametersVersion )
import Data.Eq ( Eq )
import Data.Function(($))
import Data.Functor ( Functor(fmap) )
import Data.Maybe ( Maybe(Just, Nothing) )
import Data.Ord ( Ord )
import Data.Semigroup ( Semigroup((<>)) )
import GHC.Float ( Floating(sqrt), Double )
import GHC.Show(Show)
import Prelude(Num((-), (+), (*)), Fractional((/)))
import System.IO ( IO, putStrLn )

data WindCorrection =
  WindCorrection
    WindComponent -- crosswind/headwind
    Double -- TAS
    Vector' -- heading/ground speed
  deriving (Eq, Ord, Show)

calculateWindCorrection ::
  HasWindParameters a Double =>
  a
  -> WindCorrection
calculateWindCorrection wp =
  let square x = x * x
      pythagoras a b = sqrt (square a + square b)
      tas' = view (trackTAS . magnitude) wp
      wc = calculateWindComponent wp
      hdg = view (trackTAS . angle) wp + view crosswind wc / tas'
      emag = pythagoras tas' (view crosswind wc)
      etas = square tas' / emag
      gs = etas - view headwind wc
  in  WindCorrection wc etas (Vector hdg gs)

printWindCorrection ::
  (PrintfType a, IsString a, Semigroup a, HasWindCorrection s, HasWindComponent s, PrintfArg x, Floating x, HasVector s x) =>
  s
  -> a
printWindCorrection r =
  "Effective TAS  " <> printf "% 6.2f" (view tas r) <> "KT\n" <>
  "Ground Speed   " <> printf "% 6.2f" (view magnitude r) <> "KT\n" <>
  "Heading        " <> printf "% 6.2f" (view (angle . toRadians) r) <> "°\n" <>
  "Crosswind      " <> printf "% 6.2f" (view crosswind r) <> "KT\n" <>
  "Headwind       " <> printf "% 6.2f" (view headwind r) <> "KT"

run ::
  String
  -> IO ()
run v =
  let desc =
        "Aviation Navigation wind-correction (" <> v <> ")"
      execopts =
        execParser
          (info (optWindParametersVersion <**> helper) (
            fullDesc <>
            header desc
          )
        )
  in  do  conf' <- execopts
          putStrLn $
            case conf' of
              Nothing ->
                desc
              Just wp ->
                printWindCorrection (calculateWindCorrection wp)

class HasWindCorrection a where
  windCorrection ::
    Lens' a WindCorrection
  {-# INLINE tas #-}
  tas ::
    Lens' a Double
  tas =
    windCorrection . tas

instance HasWindCorrection WindCorrection where
  windCorrection =
    id
  {-# INLINE tas #-}
  tas f (WindCorrection wc etas hdg) =
    fmap (\etas' -> WindCorrection wc etas' hdg) (f etas)

instance HasWindComponent WindCorrection where
  {-# INLINE windComponent #-}
  windComponent f (WindCorrection wc etas hdg) =
    fmap (\wc' -> WindCorrection wc' etas hdg) (f wc)

instance HasVector WindCorrection Double where
  {-# INLINE vector #-}
  vector f (WindCorrection wc etas hdg) =
    fmap (WindCorrection wc etas) (f hdg)