large portion
[hsv4l2:phischus-v4l2.git] / Graphics / V4L2 / VideoStandard / Internal.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2 {- |
3 Module      : Graphics.V4L2.VideoStandard.Internal
4 Maintainer  : claudiusmaximus@goto10.org
5 Stability   : no
6 Portability : no
7 -}
8 module Graphics.V4L2.VideoStandard.Internal
9   ( VideoStandardID()
10   , VideoStandardInfo(..)
11   , videoStandards
12   , getVideoStandard
13   , setVideoStandard
14   , detectVideoStandard
15   -- predefined standards
16   , VideoStandard
17   , VideoStandardType(..)
18   , videoStandardPalB 
19   , videoStandardPalB1
20   , videoStandardPalG 
21   , videoStandardPalH 
22   , videoStandardPalI 
23   , videoStandardPalD 
24   , videoStandardPalD1
25   , videoStandardPalK 
26   , videoStandardPalM 
27   , videoStandardPalN 
28   , videoStandardPalNc
29   , videoStandardPal60
30   , videoStandardNtscM   
31   , videoStandardNtscM_JP
32   , videoStandardNtsc443 
33   , videoStandardNtscM_KR
34   , videoStandardSecamB 
35   , videoStandardSecamD 
36   , videoStandardSecamG 
37   , videoStandardSecamH 
38   , videoStandardSecamK 
39   , videoStandardSecamK1
40   , videoStandardSecamL 
41   , videoStandardSecamLC
42   , videoStandardAtsc8Vsb 
43   , videoStandardAtsc16Vsb
44   , videoStandardMn     
45   , videoStandardB      
46   , videoStandardGh     
47   , videoStandardDk     
48   , videoStandardPalBg  
49   , videoStandardPalDk  
50   , videoStandardPal    
51   , videoStandardNtsc   
52   , videoStandardSecamDk
53   , videoStandardSecam  
54   , videoStandard525_60 
55   , videoStandard625_50 
56   , videoStandardAtsc   
57   , videoStandardUnknown
58   , videoStandardAll
59   --
60   , fromVideoStandard
61   ) where
62
63 import Prelude hiding (catch)
64
65 import Control.Exception (catch, throwIO)
66 import Data.Data (Data)
67 import Data.Set (Set)
68 import Data.Map (Map)
69 import qualified Data.Map as M
70 import Data.Typeable (Typeable)
71 import Data.Word (Word64)
72 import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)
73
74 import Bindings.Linux.VideoDev2
75
76 import Foreign.Extra.BitSet (fromBitSet, toBitSet)
77 import Foreign.Extra.String (fromString)
78 import Graphics.V4L2.Device (Device)
79 import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero)
80 import Graphics.V4L2.Types (Fraction)
81 import Graphics.V4L2.Types.Internal (fromFraction)
82
83 type VideoStandard = Set VideoStandardType
84
85 {- |  Elementary video standard flags. -}
86 data VideoStandardType
87   = StdPalB
88   | StdPalB1
89   | StdPalG
90   | StdPalH
91   | StdPalI
92   | StdPalD
93   | StdPalD1
94   | StdPalK
95   | StdPalM
96   | StdPalN
97   | StdPalNc
98   | StdPal60
99   | StdNtscM
100   | StdNtscMJp
101   | StdNtsc443
102   | StdNtscMKr
103   | StdSecamB
104   | StdSecamD
105   | StdSecamG
106   | StdSecamH
107   | StdSecamK
108   | StdSecamK1
109   | StdSecamL
110   | StdSecamLC
111   | StdAtsc8Vsb
112   | StdAtsc16Vsb
113   | StdUnknown Word64
114   deriving (Eq, Ord, Read, Show, Data, Typeable)
115
116 {- |  internal -}
117 fromVideoStandard :: Word64 -> VideoStandard
118 toVideoStandard :: VideoStandard -> Word64
119 (fromVideoStandard, toVideoStandard) = (fromBitSet spec StdUnknown, toBitSet spec isStdUnknown unStdUnknown) where
120   spec =
121     [ ( StdPalB      , c'V4L2_STD_PAL_B       )
122     , ( StdPalB1     , c'V4L2_STD_PAL_B1      )
123     , ( StdPalG      , c'V4L2_STD_PAL_G       )
124     , ( StdPalH      , c'V4L2_STD_PAL_H       )
125     , ( StdPalI      , c'V4L2_STD_PAL_I       )
126     , ( StdPalD      , c'V4L2_STD_PAL_D       )
127     , ( StdPalD1     , c'V4L2_STD_PAL_D1      )
128     , ( StdPalK      , c'V4L2_STD_PAL_K       )
129     , ( StdPalM      , c'V4L2_STD_PAL_M       )
130     , ( StdPalN      , c'V4L2_STD_PAL_N       )
131     , ( StdPalNc     , c'V4L2_STD_PAL_Nc      )
132     , ( StdPal60     , c'V4L2_STD_PAL_60      )
133     , ( StdNtscM     , c'V4L2_STD_NTSC_M      )
134     , ( StdNtscMJp   , c'V4L2_STD_NTSC_M_JP   )
135     , ( StdNtsc443   , c'V4L2_STD_NTSC_443    )
136     , ( StdNtscMKr   , c'V4L2_STD_NTSC_M_KR   )
137     , ( StdSecamB    , c'V4L2_STD_SECAM_B     )
138     , ( StdSecamD    , c'V4L2_STD_SECAM_D     )
139     , ( StdSecamG    , c'V4L2_STD_SECAM_G     )
140     , ( StdSecamH    , c'V4L2_STD_SECAM_H     )
141     , ( StdSecamK    , c'V4L2_STD_SECAM_K     )
142     , ( StdSecamK1   , c'V4L2_STD_SECAM_K1    )
143     , ( StdSecamL    , c'V4L2_STD_SECAM_L     )
144     , ( StdSecamLC   , c'V4L2_STD_SECAM_LC    )
145     , ( StdAtsc8Vsb  , c'V4L2_STD_ATSC_8_VSB  )
146     , ( StdAtsc16Vsb , c'V4L2_STD_ATSC_16_VSB )
147     ]
148   isStdUnknown (StdUnknown _) = True
149   isStdUnknown _ = False
150   unStdUnknown (StdUnknown x) = x
151   unStdUnknown _ = error "Graphics.V4L2.Video.Standard.Internal.toVideoStandard.unUnknown"
152
153 videoStandardPalB  :: VideoStandard
154 videoStandardPalB1 :: VideoStandard
155 videoStandardPalG  :: VideoStandard
156 videoStandardPalH  :: VideoStandard
157 videoStandardPalI  :: VideoStandard
158 videoStandardPalD  :: VideoStandard
159 videoStandardPalD1 :: VideoStandard
160 videoStandardPalK  :: VideoStandard
161 videoStandardPalM  :: VideoStandard
162 videoStandardPalN  :: VideoStandard
163 videoStandardPalNc :: VideoStandard
164 videoStandardPal60 :: VideoStandard
165
166 videoStandardNtscM    :: VideoStandard
167 videoStandardNtscM_JP :: VideoStandard
168 videoStandardNtsc443  :: VideoStandard
169 videoStandardNtscM_KR :: VideoStandard
170
171 videoStandardSecamB  :: VideoStandard
172 videoStandardSecamD  :: VideoStandard
173 videoStandardSecamG  :: VideoStandard
174 videoStandardSecamH  :: VideoStandard
175 videoStandardSecamK  :: VideoStandard
176 videoStandardSecamK1 :: VideoStandard
177 videoStandardSecamL  :: VideoStandard
178 videoStandardSecamLC :: VideoStandard
179
180 videoStandardAtsc8Vsb  :: VideoStandard
181 videoStandardAtsc16Vsb :: VideoStandard
182
183 videoStandardMn      :: VideoStandard
184 videoStandardB       :: VideoStandard
185 videoStandardGh      :: VideoStandard
186 videoStandardDk      :: VideoStandard
187 videoStandardPalBg   :: VideoStandard
188 videoStandardPalDk   :: VideoStandard
189 videoStandardPal     :: VideoStandard
190 videoStandardNtsc    :: VideoStandard
191 videoStandardSecamDk :: VideoStandard
192 videoStandardSecam   :: VideoStandard
193 videoStandard525_60  :: VideoStandard
194 videoStandard625_50  :: VideoStandard
195 videoStandardAtsc    :: VideoStandard
196 videoStandardUnknown :: VideoStandard
197 videoStandardAll     :: VideoStandard
198
199 videoStandardPalB  = fromVideoStandard c'V4L2_STD_PAL_B
200 videoStandardPalB1 = fromVideoStandard c'V4L2_STD_PAL_B1
201 videoStandardPalG  = fromVideoStandard c'V4L2_STD_PAL_G
202 videoStandardPalH  = fromVideoStandard c'V4L2_STD_PAL_H
203 videoStandardPalI  = fromVideoStandard c'V4L2_STD_PAL_I
204 videoStandardPalD  = fromVideoStandard c'V4L2_STD_PAL_D
205 videoStandardPalD1 = fromVideoStandard c'V4L2_STD_PAL_D1
206 videoStandardPalK  = fromVideoStandard c'V4L2_STD_PAL_K
207 videoStandardPalM  = fromVideoStandard c'V4L2_STD_PAL_M
208 videoStandardPalN  = fromVideoStandard c'V4L2_STD_PAL_N
209 videoStandardPalNc = fromVideoStandard c'V4L2_STD_PAL_Nc
210 videoStandardPal60 = fromVideoStandard c'V4L2_STD_PAL_60
211
212 videoStandardNtscM    = fromVideoStandard c'V4L2_STD_NTSC_M
213 videoStandardNtscM_JP = fromVideoStandard c'V4L2_STD_NTSC_M_JP
214 videoStandardNtsc443  = fromVideoStandard c'V4L2_STD_NTSC_443
215 videoStandardNtscM_KR = fromVideoStandard c'V4L2_STD_NTSC_M_KR
216
217 videoStandardSecamB  = fromVideoStandard c'V4L2_STD_SECAM_B
218 videoStandardSecamD  = fromVideoStandard c'V4L2_STD_SECAM_D
219 videoStandardSecamG  = fromVideoStandard c'V4L2_STD_SECAM_G
220 videoStandardSecamH  = fromVideoStandard c'V4L2_STD_SECAM_H
221 videoStandardSecamK  = fromVideoStandard c'V4L2_STD_SECAM_K
222 videoStandardSecamK1 = fromVideoStandard c'V4L2_STD_SECAM_K1
223 videoStandardSecamL  = fromVideoStandard c'V4L2_STD_SECAM_L
224 videoStandardSecamLC = fromVideoStandard c'V4L2_STD_SECAM_LC
225
226 videoStandardAtsc8Vsb  = fromVideoStandard c'V4L2_STD_ATSC_8_VSB
227 videoStandardAtsc16Vsb = fromVideoStandard c'V4L2_STD_ATSC_16_VSB
228
229 -- derived standards
230 videoStandardMn      = fromVideoStandard c'V4L2_STD_MN
231 videoStandardB       = fromVideoStandard c'V4L2_STD_B
232 videoStandardGh      = fromVideoStandard c'V4L2_STD_GH
233 videoStandardDk      = fromVideoStandard c'V4L2_STD_DK
234 videoStandardPalBg   = fromVideoStandard c'V4L2_STD_PAL_BG
235 videoStandardPalDk   = fromVideoStandard c'V4L2_STD_PAL_DK
236 videoStandardPal     = fromVideoStandard c'V4L2_STD_PAL
237 videoStandardNtsc    = fromVideoStandard c'V4L2_STD_NTSC
238 videoStandardSecamDk = fromVideoStandard c'V4L2_STD_SECAM_DK
239 videoStandardSecam   = fromVideoStandard c'V4L2_STD_SECAM
240 videoStandard525_60  = fromVideoStandard c'V4L2_STD_525_60
241 videoStandard625_50  = fromVideoStandard c'V4L2_STD_625_50
242 videoStandardAtsc    = fromVideoStandard c'V4L2_STD_ATSC
243 videoStandardUnknown = fromVideoStandard c'V4L2_STD_UNKNOWN
244 videoStandardAll     = fromVideoStandard c'V4L2_STD_ALL
245
246
247 newtype VideoStandardID = VideoStandardID Int
248   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
249
250 data VideoStandardInfo = VideoStandardInfo
251   { videoStandardStandard :: VideoStandard
252   , videoStandardName :: String
253   , videoStandardFramePeriod :: Fraction
254   , videoStandardFrameLines :: Int
255   }
256   deriving (Eq, Ord, Read, Show, Data, Typeable)
257
258 {- |  Enumerate video standards.
259
260       Drivers may enumerate a different set of standards after
261       switching the video input or output.
262 -}
263 videoStandards :: Device -> IO (Map VideoStandardID VideoStandardInfo)
264 videoStandards = enumstds' 0
265
266 enumstds' :: VideoStandardID -> Device -> IO (Map VideoStandardID VideoStandardInfo)
267 enumstds' n h = do
268   mi <- (Just `fmap` enumstd h n) `catch` (\e -> case ioe_type e of
269     InvalidArgument -> return Nothing
270     _ -> throwIO e)
271   case mi of
272     Just i -> M.insert n i `fmap` enumstds' (n + 1) h
273     Nothing -> return M.empty
274
275 enumstd :: Device -> VideoStandardID -> IO VideoStandardInfo
276 enumstd h n = do
277   i' <- ioctl h C'VIDIOC_ENUMSTD =<< return . (\s->s{ c'v4l2_standard'index = fromIntegral n }) =<< zero
278   return (decodeStandard i')
279
280 decodeStandard :: C'v4l2_standard -> VideoStandardInfo
281 decodeStandard i = VideoStandardInfo
282   { videoStandardStandard = fromVideoStandard $ c'v4l2_standard'id i
283   , videoStandardName = fromString $ c'v4l2_standard'name i
284   , videoStandardFramePeriod = fromFraction $ c'v4l2_standard'frameperiod i
285   , videoStandardFrameLines = fromIntegral $ c'v4l2_standard'framelines i
286   }
287
288 {- |  Get the current video standard. -}
289 getVideoStandard :: Device -> IO VideoStandard
290 getVideoStandard d = do
291   s <- ioctl' d C'VIDIOC_G_STD
292   return (fromVideoStandard s)
293
294 {- |  Set the current video standard. -}
295 setVideoStandard :: Device -> VideoStandard -> IO ()
296 setVideoStandard d s = do
297   ioctl_ d C'VIDIOC_S_STD (toVideoStandard s)
298
299 {- |  Detect the current video standard. -}
300 detectVideoStandard :: Device -> IO VideoStandard
301 detectVideoStandard d = do
302   s <- ioctl' d C'VIDIOC_QUERYSTD
303   return (fromVideoStandard s)