Demo.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

module Data.Aviation.Stratux.Demo where

import Control.Applicative(pure, (<*>), (<**>))
import Control.Category((.))
import Control.Concurrent(threadDelay)
import Control.Lens((^.), makeClassy)
import Control.Monad(forever, join)
import Control.Monad.IO.Class(MonadIO(liftIO))
import Control.Monad.Trans.Except(runExceptT)
import Data.Aviation.Stratux
import Data.Bool(Bool, bool)
import Data.Either(either)
import Data.String(String)
import Data.Eq(Eq((==)))
import Data.Function(($))
import Data.Functor((<$>))
import Data.Int(Int)
import Data.List((++))
import Data.Maybe(Maybe(Just, Nothing))
import Data.Ord(Ord)
import Data.Semigroup((<>))
import Data.Text(Text)
import Network.URI(URIAuth(URIAuth))
import Prelude(Show(show))
import System.IO(IO, putStrLn)
import Text.Printf(printf)
import Options.Applicative(Parser, execParser, info, helper, fullDesc, header, option, maybeReader, short, long, value, help, strOption, switch, metavar, auto, showDefault)

hdr ::
  Bool
  -> String
  -> String
hdr nc s =
  bool
    (join ["\ESC[92m\ESC[42m", s, "\ESC[m"])
    s
    nc

val ::
  Bool
  -> String
  -> String
val nc s =
  bool
    (join ["\ESC[38m\ESC[41m", s, "\ESC[m"])
    s
    nc

----

demoSituation ::
  HasSituation s =>
  Bool
  -> s
  -> String
demoSituation nc = 
  let hdr' = hdr nc
      val' = val nc
  in  do  pa <- (^. pressureAlt)
          pc <- (^. pitch)
          rl <- (^. roll)
          hd <- (^. gyroHeading)
          lt <- (^. lat)
          ln <- (^. lon)
          vs <- (^. gpsVertVel)
          ht <- (^. heightAboveEllipsoid)
          cs <- (^. trueCourse)
          gs <- (^. groundSpeed)
          pure (join  [
                  hdr' "p.alt: "
                , val' (printf "%*.2fft" (8 :: Int) pa)
                , hdr' " pitch: "
                , val' (printf "%*.2fdeg" (7 :: Int) pc)
                , hdr' " roll: "
                , val' (printf "%*.2fdeg" (7 :: Int) rl)
                , hdr' " hdg: "
                , val' (printf "%*.2fdeg" (7 :: Int) hd)
                , hdr' " lat: "             
                , val' (printf "%*.4f" (8 :: Int) lt)
                , hdr' " lon: "
                , val' (printf "%*.4f" (9 :: Int) ln)
                , hdr' " v.speed: "
                , val' (printf "%*.2fft/min" (9 :: Int) vs)
                , hdr' " hgt: "
                , val' (printf "%*.2fft" (8 :: Int) ht)
                , hdr' " tr: "
                , val' (printf "%*.2fdeg" (6 :: Int) cs)
                , hdr' " g.speed: "
                , val' (printf "%*dkt" (3 :: Int) gs)                
                ])
         
printloop ::
  MonadIO f =>
  Int
  -> f String
  -> f ()
printloop d x =
  forever $
    do  a <- x
        liftIO (putStrLn a)
        liftIO (threadDelay d)

----

demoAirTraffic ::
  HasTraffic s =>
  Bool
  -> s
  -> String
demoAirTraffic nc =
  let hdr' = hdr nc
      val' = val nc
  in  do  t <- (^. tail)
          s <- (^. signalLevel)
          l <- (^. latitude)
          g <- (^. longitude)
          a <- (^. altitude)
          p <- (^. speed)
          v <- (^. verticalVelocity)
          x <- (^. timestamp)
          pure (join  [
                        hdr' "flight: "
                      , val' (printf "%*s" (6 :: Int) t)
                      , hdr' " power: "
                      , val' (printf "%*.2f dB" (6 :: Int) s)
                      , hdr' " lat: "             
                      , val' (printf "%*.4f" (8 :: Int) l)
                      , hdr' " lon: "
                      , val' (printf "%*.4f" (9 :: Int) g)
                      , hdr' " alt: "
                      , val' (printf "%*dft" (5 :: Int) a)
                      , hdr' " velocity: "
                      , val' (printf "%*dkt" (3 :: Int) p)
                      , hdr' " v/velocity: "
                      , val' (printf "%*dft/min" (6 :: Int) v)
                      , hdr' " time: "
                      , val' (printf "%*s" (27 :: Int) (show x))
                      ])

data DemoType =
  SituationDemo
  | TrafficDemo
  deriving (Eq, Ord)

instance Show DemoType where
  show SituationDemo =
    "situation"
  show TrafficDemo =
    "traffic"

data StratuxConfig =
  StratuxConfig {
    _demohost ::
      String
  , _demoport ::
      Int
  , _delay ::
      Int
  , _dtype ::
      DemoType
  , _nocolours ::
      Bool
  } deriving (Eq, Ord, Show)

parserDemoType ::
  Parser DemoType
parserDemoType =
  option
    (
      maybeReader
        (\s ->
          bool
            (
              bool
                Nothing
                (Just TrafficDemo)
                (s == "traffic")
            )
            (Just SituationDemo)
            (s == "situation")
        )
    )
    (
      short 'm' <>
      long "demo" <>
      value SituationDemo <>
      showDefault <>
      help "which demo" <>
      metavar "<situation|traffic>"
    )

parserStratuxConfig ::
  Parser StratuxConfig
parserStratuxConfig =
  StratuxConfig <$>
    strOption
      (
        short 'h' <>
        long "host" <>
        help "the host name" <>
        metavar "HOSTNAME"
      ) <*>
    option auto
      ( 
        short 'p' <>
        long "port" <>
        help "The host port" <>
        showDefault <>
        value 80 <>
        metavar "INT"
      ) <*>
    option auto
      ( 
        short 'd' <>
        long "delay" <>
        help "The delay between reading from the stratux device (milliseconds)" <>
        showDefault <>
        value 4000 <>
        metavar "INT"
      ) <*>
    parserDemoType <*>
    switch
      (
        short 'c' <>
        long "no-colours" <>
        help "terminal colours off"
      )

makeClassy ''StratuxConfig

run ::
  IO ()
run =
  let execopts =
        execParser
          (info (parserStratuxConfig <**> helper) (
            fullDesc <>
            header ("stratux-demo " <> VERSION_stratux_demo <> "demonstrates situation and traffic given by stratux <https://stratux.me/>")
          )
        )
  in  do  c <- execopts
          case c ^. dtype of
            SituationDemo ->
                printloop
                  (c ^. delay)
                  (either ("Error: " ++) (demoSituation (c ^. nocolours)) <$> runExceptT (getSituation (URIAuth (c ^. demohost) "" (':' : show (c ^. demoport))) "" ""))
            TrafficDemo ->
                trafficApp
                  (c ^. demohost)
                  (c ^. demoport) (
                    either
                      (\e ->
                          putStrLn ("Error: " ++ e))
                      (putStrLn . demoAirTraffic (c ^. nocolours))
                    )
                  ("" :: Text)