Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
168 lines (152 sloc) 6.82 KB
-- |An example application demonstrating realtime image processing on
-- the video feed from an attached webcam or a video file specified as
-- a command line argument. The executable prints usage instructions
-- to the console when run.
import OpenCV.HighCV
import OpenCV.ArrayOps
import OpenCV.Filtering
import OpenCV.Histograms
import Control.Applicative
import Control.Parallel
import System.Environment (getArgs)
import System.Exit (exitSuccess)
import Rate
-- Canny edges
edges = convertGrayToRGB . canny 70 110 3 . convertRGBToGray
{-# INLINE edges #-}
-- Heavily smoothed video with red edge highlights.
edgesOnSmoothed x = let e = edges x; s = smooth x in e `par` s `pseq` add e s
where edges = cvAndS (0,0,255) . convertGrayToRGB . dilate 1
. canny 70 110 3 . convertRGBToGray
smooth = smoothGaussian 21
{-# INLINE edgesOnSmoothed #-}
-- Morphological closing
close :: GrayImage -> GrayImage
close = erode 4 . dilate 4
{-# INLINE close #-}
-- Posterize into two shades of blue.
twoTone :: GrayImage -> ColorImage
twoTone g = light t `cvOr` dark t
where t = close . thresholdBinaryOtsu 255 $ g
light = cvAndS (255,0,0) . convertGrayToRGB
dark = cvAndS (180,0,0) . convertGrayToRGB . cvNot
{-# INLINE twoTone #-}
-- Smoothed Canny edges.
neonEdges :: GrayImage -> ColorImage
neonEdges = convertGrayToRGB . smoothGaussian 3 . dilate 1 . canny 70 110 3
-- Boost saturation
boostSat x = convertHSVToBGR $ replaceChannel 1 s' hsv
where hsv = convertBGRToHSV x
s' = convertScale 2.0 0 . isolateChannel 1 $ hsv
{-# INLINE boostSat #-}
-- Saturate and blur the borders
centralFocus :: ColorImage -> ColorImage
centralFocus img = withROI r (copy (setROI r img)) bg
where bg = smoothGaussian 35 . boostSat $ img
r = CvRect 150 100 340 280
{-# INLINE centralFocus #-}
-- A two-tone blueprint effect.
blueprint x = toned `par` neon `pseq` add neon toned
where g = convertRGBToGray x
toned = twoTone g
neon = neonEdges g
{-# INLINE blueprint #-}
-- No parallelism
blueprintSlow x = add (neonEdges g) (twoTone g)
where g = convertRGBToGray x
{-# INLINE blueprintSlow #-}
-- Posterize into four shades of blue.
fourTones :: GrayImage -> ColorImage
fourTones g = cvOr light dark
where t = close . thresholdBinaryOtsu 255 $ g
lightMean = avgMask g t
l1 = close $ cmpS CmpGT lightMean g
l2 = convertGrayToRGB $ cvNot l1 `cvAnd` t
light = cvAndS (255,0,0) (convertGrayToRGB l1) `cvOr`
cvAndS (220,0,0) l2
t' = cvNot t
darkMean = avgMask g t'
d2 = close $ cmpS CmpLT darkMean g
d1 = convertGrayToRGB $ cvNot d2 `cvAnd` t'
dark = cvAndS (180,0,0) d1 `cvOr`
cvAndS (140,0,0) (convertGrayToRGB d2)
{-# INLINE fourTones #-}
-- A four-tone blueprint effect.
blueprint2 x = toned `par` neon `pseq` add neon toned
where g = convertRGBToGray x
toned = fourTones g
neon = neonEdges g
{-# INLINE blueprint2 #-}
-- No parallelism
blueprint2slow x = add (neonEdges g) (fourTones g)
where g = convertRGBToGray x
{-# INLINE blueprint2slow #-}
-- NOTE: trackRate counts all the time in between frames. In low-light
-- situations, a camera may run at a lower rate to effect a longer
-- exposure time. To still report a useful performance metric, the
-- perfMon monitor counts only the time a frame is being processed and
-- drawn. Thus, the displayed framerate is the maximum theoretical
-- rate the processing and display code could run at if the image
-- capturing mechanism could feed it that fast.
main = do args <- getArgs
cam <- case args of
["--help"] -> do putStrLn "Usage: ./VideoFunhouse [filename]"
putStr "If no file is given, a connected "
putStrLn "camera is opened."
exitSuccess
[fname] -> createFileCaptureLoop fname
_ -> createCameraCapture (Just 0)
(showImg,close) <- namedWindow "Video Funhouse" [AutoSize]
--rater <- trackRate
(startFrame', curr, stopFrame) <- perfMon
str <- prepFont ComplexSerif False 1 1 2
let showFPS :: IO (ColorImage -> ColorImage)
--showFPS = str (300,450) (0,255,0) . (++ " FPS") <$> rater
showFPS = str (300,450) (0,255,0) . (++ " FPS") <$> curr
startFrame x = startFrame' >> return x
checkKey b _ 49 = go b id -- 1
checkKey b _ 50 = go b edges -- 2
checkKey b _ 51 = go b edgesOnSmoothed -- 3
checkKey b _ 52 = go b blueprint -- 4
checkKey b _ 53 = go b blueprintSlow -- 5
checkKey b _ 54 = go b blueprint2 -- 6
checkKey b _ 55 = go b blueprint2slow -- 7
checkKey b _ 56 = go b boostSat -- 8
checkKey b _ 57 = go b centralFocus -- 9
checkKey b p 102 = go (not b) p
checkKey _ _ 27 = close >> exitSuccess
checkKey b p _ = go b p
go False proc = cam >>= startFrame >>= showImg . proc >>
stopFrame >> waitKey 1 >>=
maybe (go False proc) (checkKey False proc)
go True proc = cam >>= startFrame >>= (showFPS <*>) . pure . proc >>=
showImg >> stopFrame >> waitKey 1 >>=
maybe (go True proc) (checkKey True proc)
-- go False proc = cam >>= showImg . proc >> waitKey 1 >>=
-- maybe (go False proc) (checkKey False proc)
-- go True proc = cam >>= (showFPS <*>) . pure . proc >>= showImg >>
-- waitKey 1 >>=
-- maybe (go True proc) (checkKey True proc)
showHelp
go False id
showHelp :: IO ()
showHelp = do p "Usage: VideoFunhouse [file]"
p ""
p "Press 'f' to toggle framerate display"
p " The rate is computed from the per-frame processing time."
p " Lighting conditions and the specific camera used will"
p " determine the actual rate at which frames are acquired."
p ""
p "Number keys select a video effect:"
p " 1 - Raw video"
p " 2 - Canny edges"
p " 3 - Smoothed image with red edge highlights"
p " 4 - A two-tone blueprint effect"
p " 5 - Two-tone blueprint effect without par annotations"
p " 6 - A four-tone blueprint effect"
p " 7 - Four-tone blueprint effect without par annotations"
p " 8 - Saturation boost"
p " 9 - Focus on the middle"
p ""
p "Press Esc to exit."
where p = putStrLn