{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{- |
Module      : Graphics.V4L2.VideoStandard.Internal
Maintainer  : claude@mathr.co.uk
Stability   : no
Portability : no
-}
module Graphics.V4L2.VideoStandard.Internal
  ( VideoStandardID()
  , VideoStandardInfo(..)
  , videoStandards
  , getVideoStandard
  , setVideoStandard
  , detectVideoStandard
  -- predefined standards
  , VideoStandard
  , VideoStandardType(..)
  , videoStandardPalB 
  , videoStandardPalB1
  , videoStandardPalG 
  , videoStandardPalH 
  , videoStandardPalI 
  , videoStandardPalD 
  , videoStandardPalD1
  , videoStandardPalK 
  , videoStandardPalM 
  , videoStandardPalN 
  , videoStandardPalNc
  , videoStandardPal60
  , videoStandardNtscM   
  , videoStandardNtscM_JP
  , videoStandardNtsc443 
  , videoStandardNtscM_KR
  , videoStandardSecamB 
  , videoStandardSecamD 
  , videoStandardSecamG 
  , videoStandardSecamH 
  , videoStandardSecamK 
  , videoStandardSecamK1
  , videoStandardSecamL 
  , videoStandardSecamLC
  , videoStandardAtsc8Vsb 
  , videoStandardAtsc16Vsb
  , videoStandardMn     
  , videoStandardB      
  , videoStandardGh     
  , videoStandardDk     
  , videoStandardPalBg  
  , videoStandardPalDk  
  , videoStandardPal    
  , videoStandardNtsc   
  , videoStandardSecamDk
  , videoStandardSecam  
  , videoStandard525_60 
  , videoStandard625_50 
  , videoStandardAtsc   
  , videoStandardUnknown
  , videoStandardAll
  --
  , fromVideoStandard
  ) where

import Control.Exception as E (catch, throwIO)
import Data.Data (Data)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Typeable (Typeable)
import Data.Word (Word64)
import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)

import Bindings.Linux.VideoDev2

import Foreign.Extra.BitSet (fromBitSet, toBitSet)
import Foreign.Extra.String (fromString)
import Graphics.V4L2.Device (Device)
import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero)
import Graphics.V4L2.Types (Fraction)
import Graphics.V4L2.Types.Internal (fromFraction)

{- |  Video standard. -}
type VideoStandard = Set VideoStandardType

{- |  Elementary video standard flags. -}
data VideoStandardType
  = StdPalB
  | StdPalB1
  | StdPalG
  | StdPalH
  | StdPalI
  | StdPalD
  | StdPalD1
  | StdPalK
  | StdPalM
  | StdPalN
  | StdPalNc
  | StdPal60
  | StdNtscM
  | StdNtscMJp
  | StdNtsc443
  | StdNtscMKr
  | StdSecamB
  | StdSecamD
  | StdSecamG
  | StdSecamH
  | StdSecamK
  | StdSecamK1
  | StdSecamL
  | StdSecamLC
  | StdAtsc8Vsb
  | StdAtsc16Vsb
  | StdUnknown Word64
  deriving (Eq, Ord, Read, Show, Data, Typeable)

{- |  internal -}
fromVideoStandard :: Word64 -> VideoStandard
{- |  internal -}
toVideoStandard :: VideoStandard -> Word64
(fromVideoStandard, toVideoStandard) = (fromBitSet spec StdUnknown, toBitSet spec isStdUnknown unStdUnknown) where
  spec =
    [ ( StdPalB      , c'V4L2_STD_PAL_B       )
    , ( StdPalB1     , c'V4L2_STD_PAL_B1      )
    , ( StdPalG      , c'V4L2_STD_PAL_G       )
    , ( StdPalH      , c'V4L2_STD_PAL_H       )
    , ( StdPalI      , c'V4L2_STD_PAL_I       )
    , ( StdPalD      , c'V4L2_STD_PAL_D       )
    , ( StdPalD1     , c'V4L2_STD_PAL_D1      )
    , ( StdPalK      , c'V4L2_STD_PAL_K       )
    , ( StdPalM      , c'V4L2_STD_PAL_M       )
    , ( StdPalN      , c'V4L2_STD_PAL_N       )
    , ( StdPalNc     , c'V4L2_STD_PAL_Nc      )
    , ( StdPal60     , c'V4L2_STD_PAL_60      )
    , ( StdNtscM     , c'V4L2_STD_NTSC_M      )
    , ( StdNtscMJp   , c'V4L2_STD_NTSC_M_JP   )
    , ( StdNtsc443   , c'V4L2_STD_NTSC_443    )
    , ( StdNtscMKr   , c'V4L2_STD_NTSC_M_KR   )
    , ( StdSecamB    , c'V4L2_STD_SECAM_B     )
    , ( StdSecamD    , c'V4L2_STD_SECAM_D     )
    , ( StdSecamG    , c'V4L2_STD_SECAM_G     )
    , ( StdSecamH    , c'V4L2_STD_SECAM_H     )
    , ( StdSecamK    , c'V4L2_STD_SECAM_K     )
    , ( StdSecamK1   , c'V4L2_STD_SECAM_K1    )
    , ( StdSecamL    , c'V4L2_STD_SECAM_L     )
    , ( StdSecamLC   , c'V4L2_STD_SECAM_LC    )
    , ( StdAtsc8Vsb  , c'V4L2_STD_ATSC_8_VSB  )
    , ( StdAtsc16Vsb , c'V4L2_STD_ATSC_16_VSB )
    ]
  isStdUnknown (StdUnknown _) = True
  isStdUnknown _ = False
  unStdUnknown (StdUnknown x) = x
  unStdUnknown _ = error "Graphics.V4L2.Video.Standard.Internal.toVideoStandard.unUnknown"

{- |  Video standard identifier. -}
newtype VideoStandardID = VideoStandardID Int
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)

{- |  Video standard information. -}
data VideoStandardInfo = VideoStandardInfo
  { videoStandardStandard :: VideoStandard
  , videoStandardName :: String
  , videoStandardFramePeriod :: Fraction
  , videoStandardFrameLines :: Int
  }
  deriving (Eq, Ord, Read, Show, Data, Typeable)

{- |  Enumerate video standards.

      Drivers may enumerate a different set of standards after
      switching the video input or output.
-}
videoStandards :: Device -> IO (Map VideoStandardID VideoStandardInfo)
videoStandards = enumstds' 0

enumstds' :: VideoStandardID -> Device -> IO (Map VideoStandardID VideoStandardInfo)
enumstds' n h = do
  mi <- (Just `fmap` enumstd h n) `E.catch` (\e -> case ioe_type e of
    InvalidArgument -> return Nothing
    _ -> throwIO e)
  case mi of
    Just i -> M.insert n i `fmap` enumstds' (n + 1) h
    Nothing -> return M.empty

enumstd :: Device -> VideoStandardID -> IO VideoStandardInfo
enumstd h n = do
  i' <- ioctl h C'VIDIOC_ENUMSTD =<< return . (\s->s{ c'v4l2_standard'index = fromIntegral n }) =<< zero
  return (decodeStandard i')

decodeStandard :: C'v4l2_standard -> VideoStandardInfo
decodeStandard i = VideoStandardInfo
  { videoStandardStandard = fromVideoStandard $ c'v4l2_standard'id i
  , videoStandardName = fromString $ c'v4l2_standard'name i
  , videoStandardFramePeriod = fromFraction $ c'v4l2_standard'frameperiod i
  , videoStandardFrameLines = fromIntegral $ c'v4l2_standard'framelines i
  }

{- |  Get the current video standard. -}
getVideoStandard :: Device -> IO VideoStandard
getVideoStandard d = do
  s <- ioctl' d C'VIDIOC_G_STD
  return (fromVideoStandard s)

{- |  Set the current video standard. -}
setVideoStandard :: Device -> VideoStandard -> IO ()
setVideoStandard d s = do
  ioctl_ d C'VIDIOC_S_STD (toVideoStandard s)

{- |  Detect the current video standard. -}
detectVideoStandard :: Device -> IO VideoStandard
detectVideoStandard d = do
  s <- ioctl' d C'VIDIOC_QUERYSTD
  return (fromVideoStandard s)

-- Known standards.

videoStandardPalB  :: VideoStandard
videoStandardPalB1 :: VideoStandard
videoStandardPalG  :: VideoStandard
videoStandardPalH  :: VideoStandard
videoStandardPalI  :: VideoStandard
videoStandardPalD  :: VideoStandard
videoStandardPalD1 :: VideoStandard
videoStandardPalK  :: VideoStandard
videoStandardPalM  :: VideoStandard
videoStandardPalN  :: VideoStandard
videoStandardPalNc :: VideoStandard
videoStandardPal60 :: VideoStandard

videoStandardNtscM    :: VideoStandard
videoStandardNtscM_JP :: VideoStandard
videoStandardNtsc443  :: VideoStandard
videoStandardNtscM_KR :: VideoStandard

videoStandardSecamB  :: VideoStandard
videoStandardSecamD  :: VideoStandard
videoStandardSecamG  :: VideoStandard
videoStandardSecamH  :: VideoStandard
videoStandardSecamK  :: VideoStandard
videoStandardSecamK1 :: VideoStandard
videoStandardSecamL  :: VideoStandard
videoStandardSecamLC :: VideoStandard

videoStandardAtsc8Vsb  :: VideoStandard
videoStandardAtsc16Vsb :: VideoStandard

videoStandardMn      :: VideoStandard
videoStandardB       :: VideoStandard
videoStandardGh      :: VideoStandard
videoStandardDk      :: VideoStandard
videoStandardPalBg   :: VideoStandard
videoStandardPalDk   :: VideoStandard
videoStandardPal     :: VideoStandard
videoStandardNtsc    :: VideoStandard
videoStandardSecamDk :: VideoStandard
videoStandardSecam   :: VideoStandard
videoStandard525_60  :: VideoStandard
videoStandard625_50  :: VideoStandard
videoStandardAtsc    :: VideoStandard
videoStandardUnknown :: VideoStandard
videoStandardAll     :: VideoStandard

videoStandardPalB  = fromVideoStandard c'V4L2_STD_PAL_B
videoStandardPalB1 = fromVideoStandard c'V4L2_STD_PAL_B1
videoStandardPalG  = fromVideoStandard c'V4L2_STD_PAL_G
videoStandardPalH  = fromVideoStandard c'V4L2_STD_PAL_H
videoStandardPalI  = fromVideoStandard c'V4L2_STD_PAL_I
videoStandardPalD  = fromVideoStandard c'V4L2_STD_PAL_D
videoStandardPalD1 = fromVideoStandard c'V4L2_STD_PAL_D1
videoStandardPalK  = fromVideoStandard c'V4L2_STD_PAL_K
videoStandardPalM  = fromVideoStandard c'V4L2_STD_PAL_M
videoStandardPalN  = fromVideoStandard c'V4L2_STD_PAL_N
videoStandardPalNc = fromVideoStandard c'V4L2_STD_PAL_Nc
videoStandardPal60 = fromVideoStandard c'V4L2_STD_PAL_60

videoStandardNtscM    = fromVideoStandard c'V4L2_STD_NTSC_M
videoStandardNtscM_JP = fromVideoStandard c'V4L2_STD_NTSC_M_JP
videoStandardNtsc443  = fromVideoStandard c'V4L2_STD_NTSC_443
videoStandardNtscM_KR = fromVideoStandard c'V4L2_STD_NTSC_M_KR

videoStandardSecamB  = fromVideoStandard c'V4L2_STD_SECAM_B
videoStandardSecamD  = fromVideoStandard c'V4L2_STD_SECAM_D
videoStandardSecamG  = fromVideoStandard c'V4L2_STD_SECAM_G
videoStandardSecamH  = fromVideoStandard c'V4L2_STD_SECAM_H
videoStandardSecamK  = fromVideoStandard c'V4L2_STD_SECAM_K
videoStandardSecamK1 = fromVideoStandard c'V4L2_STD_SECAM_K1
videoStandardSecamL  = fromVideoStandard c'V4L2_STD_SECAM_L
videoStandardSecamLC = fromVideoStandard c'V4L2_STD_SECAM_LC

videoStandardAtsc8Vsb  = fromVideoStandard c'V4L2_STD_ATSC_8_VSB
videoStandardAtsc16Vsb = fromVideoStandard c'V4L2_STD_ATSC_16_VSB

-- derived standards
videoStandardMn      = fromVideoStandard c'V4L2_STD_MN
videoStandardB       = fromVideoStandard c'V4L2_STD_B
videoStandardGh      = fromVideoStandard c'V4L2_STD_GH
videoStandardDk      = fromVideoStandard c'V4L2_STD_DK
videoStandardPalBg   = fromVideoStandard c'V4L2_STD_PAL_BG
videoStandardPalDk   = fromVideoStandard c'V4L2_STD_PAL_DK
videoStandardPal     = fromVideoStandard c'V4L2_STD_PAL
videoStandardNtsc    = fromVideoStandard c'V4L2_STD_NTSC
videoStandardSecamDk = fromVideoStandard c'V4L2_STD_SECAM_DK
videoStandardSecam   = fromVideoStandard c'V4L2_STD_SECAM
videoStandard525_60  = fromVideoStandard c'V4L2_STD_525_60
videoStandard625_50  = fromVideoStandard c'V4L2_STD_625_50
videoStandardAtsc    = fromVideoStandard c'V4L2_STD_ATSC
videoStandardUnknown = fromVideoStandard c'V4L2_STD_UNKNOWN
videoStandardAll     = fromVideoStandard c'V4L2_STD_ALL