module Graphics.Image.IO.Histogram (
Histogram(..), Histograms, getHistograms, getHistogram,
displayHistograms, writeHistograms
) where
import Prelude as P
import Control.Concurrent (forkIO)
import Control.Monad (void)
import Graphics.Image.Interface as I
import Graphics.Image.IO
import Graphics.Image.ColorSpace
import Graphics.Rendering.Chart.Easy
import Graphics.Rendering.Chart.Backend.Diagrams
import qualified Data.Colour as C
import qualified Data.Vector.Unboxed as V
import System.Directory (getTemporaryDirectory)
import System.FilePath ((</>))
import System.IO.Temp (createTempDirectory)
#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
data Histogram = Histogram { hBins :: V.Vector Int
, hName :: String
, hColour :: C.AlphaColour Double
}
type Histograms = [Histogram]
getHistograms :: forall arr cs e . (MArray arr Gray e, Array arr Gray e,
MArray arr cs e, Array arr cs e, Elevator e) =>
Image arr cs e
-> Histograms
getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toGrayImages
where setCh cs h = h { hName = show cs
, hColour = csColour cs }
getHistogram :: (MArray arr Gray e, Elevator e) =>
Image arr Gray e
-> Histogram
getHistogram img = Histogram { hBins = V.modify countBins $
V.replicate
(1 + fromIntegral (maxBound :: Word8)) (0 :: Int)
, hName = show Gray
, hColour = csColour Gray } where
incBin v (toWord8 -> PixelGray g) = modify v (+1) $ fromIntegral g
countBins v = I.mapM_ (incBin v) img
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