{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.Image.IO.Histogram (
Histogram(..), Histograms, ChannelColour(..), getHistograms, getHistogram,
equalizeHistogram, cdf,
displayHistograms, writeHistograms
) where
import Control.Concurrent (forkIO)
import Control.Monad (void)
import qualified Data.Colour as C
import qualified Data.Colour.Names as C
import qualified Data.Vector.Unboxed as V
import Prelude as P
import System.Directory (getTemporaryDirectory)
import System.FilePath ((</>))
import System.IO.Temp (createTempDirectory)
import Graphics.Image.ColorSpace
import Graphics.Image.Interface as I
import Graphics.Image.IO
import Graphics.Rendering.Chart.Backend.Diagrams
import Graphics.Rendering.Chart.Easy
#if MIN_VERSION_vector(0,11,0)
import Data.Vector.Unboxed.Mutable (modify)
#else
import Control.Monad.Primitive (PrimMonad (..))
import qualified Data.Vector.Unboxed.Mutable as MV
modify :: (PrimMonad m, V.Unbox a) => MV.MVector (PrimState m) a -> (a -> a) -> Int -> m ()
modify v f idx = do
e <- MV.read v idx
MV.write v idx $ f e
#endif
class ChannelColour cs where
csColour :: cs -> C.AlphaColour Double
data Histogram = Histogram { hBins :: V.Vector Int
, hName :: String
, hColour :: C.AlphaColour Double
}
type Histograms = [Histogram]
getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr X e, Array arr X e,
MArray arr cs e, Array arr cs e) =>
Image arr cs e
-> Histograms
getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toImagesX
where setCh !cs !h = h { hName = show cs
, hColour = csColour cs }
{-# INLINE setCh #-}
{-# INLINE getHistograms #-}
getHistogram :: MArray arr X e =>
Image arr X e
-> Histogram
getHistogram !img = Histogram { hBins = V.modify countBins $
V.replicate
(1 + fromIntegral (maxBound :: Word8)) (0 :: Int)
, hName = show X
, hColour = csColour X }
where
incBin !v (PixelX x) = modify v (+1) $ fromIntegral (toWord8 x)
{-# INLINE incBin #-}
countBins !v = I.mapM_ (incBin v) img
{-# INLINE countBins #-}
{-# INLINE getHistogram #-}
cdf :: MArray arr X e => Image arr X e -> V.Vector Double
cdf !img = V.unfoldr gen (0, 0)
where
!p = 1 / fromIntegral (m * n)
!(m, n) = dims img
!histogram = hBins $ getHistogram img
!l = V.length histogram
gen !(acc, k)
| k == l = Nothing
| otherwise =
let !acc' = acc + fromIntegral (V.unsafeIndex histogram k)
in Just (acc' * p, (acc', k + 1))
{-# INLINE gen #-}
{-# INLINE cdf #-}
equalizeHistogram
:: ( ToY cs e
, Array arr cs e
, Array arr Y Double
, Array arr X Word8
, MArray arr X Word8
)
=> Image arr cs e -> Image arr Y Double
equalizeHistogram !img = I.map f imgX where
!imgX = I.map (toX . toPixelY) img
!cdfImg = cdf imgX
toX (PixelY y) = PixelX $ toWord8 y
{-# INLINE toX #-}
f (PixelX x) = PixelY (V.unsafeIndex cdfImg (fromIntegral x))
{-# INLINE f #-}
{-# INLINE equalizeHistogram #-}
writeHistograms :: FilePath -> Histograms -> IO ()
writeHistograms fileName hists =
toFile def fileName $ do
layout_title .= "Histogram"
setColors $ P.map hColour hists
let axis = set la_nTicks 20 . set la_nLabels 14
layout_x_axis . laxis_generate .= scaledIntAxis (axis defaultIntAxis) (0, 260)
let plotHist h = plot $ line (hName h) [V.toList . V.imap (,) $ hBins h]
P.mapM_ plotHist hists
displayHistograms :: Histograms -> IO ()
displayHistograms = displayHistogramsUsing defaultViewer False
displayHistogramsUsing :: ExternalViewer
-> Bool
-> Histograms -> IO ()
displayHistogramsUsing viewer block hists = do
let display = do
tmpDir <- getTemporaryDirectory
histPath <- fmap (</> "tmp-hist.svg") (createTempDirectory tmpDir "hip-histogram")
writeHistograms histPath hists
displayImageFile viewer histPath
if block
then display
else void $ forkIO display
instance ChannelColour X where
csColour _ = C.opaque C.darkgray
instance ChannelColour Y where
csColour _ = C.opaque C.darkgray
instance ChannelColour YA where
csColour LumaYA = csColour LumaY
csColour AlphaYA = C.opaque C.gray
instance ChannelColour RGB where
csColour RedRGB = C.opaque C.red
csColour GreenRGB = C.opaque C.green
csColour BlueRGB = C.opaque C.blue
instance ChannelColour RGBA where
csColour RedRGBA = C.opaque C.red
csColour GreenRGBA = C.opaque C.green
csColour BlueRGBA = C.opaque C.blue
csColour AlphaRGBA = C.opaque C.gray
instance ChannelColour HSI where
csColour HueHSI = C.opaque C.purple
csColour SatHSI = C.opaque C.orange
csColour IntHSI = C.opaque C.darkblue
instance ChannelColour HSIA where
csColour HueHSIA = C.opaque C.purple
csColour SatHSIA = C.opaque C.orange
csColour IntHSIA = C.opaque C.darkblue
csColour AlphaHSIA = C.opaque C.gray
instance ChannelColour CMYK where
csColour CyanCMYK = C.opaque C.cyan
csColour MagCMYK = C.opaque C.magenta
csColour YelCMYK = C.opaque C.yellow
csColour KeyCMYK = C.opaque C.black
instance ChannelColour CMYKA where
csColour CyanCMYKA = csColour CyanCMYK
csColour MagCMYKA = csColour MagCMYK
csColour YelCMYKA = csColour YelCMYK
csColour KeyCMYKA = csColour KeyCMYK
csColour AlphaCMYKA = C.opaque C.grey
instance ChannelColour YCbCr where
csColour LumaYCbCr = C.opaque C.darkgray
csColour CBlueYCbCr = C.opaque C.darkblue
csColour CRedYCbCr = C.opaque C.darkred
instance ChannelColour YCbCrA where
csColour LumaYCbCrA = csColour LumaYCbCr
csColour CBlueYCbCrA = csColour CBlueYCbCr
csColour CRedYCbCrA = csColour CRedYCbCr
csColour AlphaYCbCrA = C.opaque C.gray