Plot data reconstruction reading pixel colors from image files

Answer 1

One can use pngload and write some simple scanner:

module Main where

import System.Environment
import System.IO.Unsafe
import System.Exit
import Data.Word
import Foreign.Ptr
import Foreign.Storable
import Data.Array.Storable
import Control.Monad
import Control.Applicative
import Codec.Image.PNG

type Name  = String
type Color = RGBA

data RGBA = RGBA Word8 Word8 Word8 Word8 deriving (Show, Read, Eq)

instance Storable RGBA where
  sizeOf _    = sizeOf (0 :: Word8) * 4
  alignment _ = 1
  poke color (RGBA r g b a) = do
     let byte :: Ptr Word8 = castPtr color
     pokeElemOff byte 0 r
     pokeElemOff byte 1 g
     pokeElemOff byte 2 b
     pokeElemOff byte 3 a
  peek color = do
     let byte :: Ptr Word8 = castPtr color
     r <- peekElemOff byte 0
     g <- peekElemOff byte 1
     b <- peekElemOff byte 2
     a <- peekElemOff byte 3
     return $ RGBA r g b a

--

checkForAlpha :: PNGImage -> IO ()
checkForAlpha (hasAlphaChannel -> True) = return ()
checkForAlpha (hasAlphaChannel -> _   ) = putStrLn "no alpha channel going on!!!" >> exitWith (ExitFailure 1)

--

main :: IO ()
main = do
  putStrLn $ "ExPloRe 0.0 : Experimental Plot Reconstructor"

  args@(path:legend_:tr_:tg_:tb_:ta_:start_:step_:_) <- getArgs

  -- initialize image
  Right img <- loadPNGFile path
  let bitmap  = imageData  img
  let (wu,hu) = dimensions img
  let (w,h)   = (fromIntegral wu, fromIntegral hu)

  putStrLn $ "-------------------------------------------------------------------"
  putStrLn $ ""
  putStrLn $ "call  : " ++ tail (filter (/= '"') $ concatMap ((' ':) . show) args)
  putStrLn $ ""

  putStrLn $ "image : " ++ path
  putStrLn $ "legend: " ++ legend_
  putStrLn $ ""

  putStrLn $ "width : " ++ show w
  putStrLn $ "height: " ++ show h

  checkForAlpha img -- !!


  -- initialize lines
  let [tr,tg,tb,ta] = map read [tr_,tg_,tb_,ta_] :: [Int]
  mapM_ (\(n,v) -> putStrLn $ show n ++ " ~ : " ++ show v) $ zip "rgba" [tr,tg,tb,ta]

  lines_ <- readFile legend_
  let lines = read lines_ :: [(Name,Color)]

  putStrLn $ "lines : " ++ (show $ length lines)
  putStrLn $ ""
  mapM_ (putStrLn . show) lines


  -- initialize scan

  let (@#)   = mu w
  let start  = read start_ :: Double
  let step   = read step_  :: Double
  let rows   = [0..h]
  let cols   = takeWhile (< w) $ map (floor . (start +) . (step *)) [0..]
  let icols  = zip [1..] cols

  -- scan bitmap
  let (~=) = mcc tr tg tb ta
  mapM_ (scan bitmap icols rows (@#) (~=)) lines

--

scan bitmap icols rows (@#) (~=) (name,color) = do
  putStrLn $ ""
  putStrLn $ "-------------------------------------------------------------------"
  putStrLn $ show color
  putStrLn $ ""
  putStrLn $ name
  putStrLn $ ""
  withStorableArray bitmap $ \byte -> do
     let pixel :: Ptr RGBA = castPtr byte
     forM_ icols $ \(n,j) -> do
      let matches = flip filter rows $ \i -> (pixel @# i) j ~= color
      let m = median matches
      putStrLn $ case not . null $ matches of
       True  -> show n ++ "\t" ++ show j ++ "\t" ++ show m ++ "\t" ++ show matches
       False -> show n ++ "\t" ++ show j ++ "\t   \t[]"

--
cb t x y = (abs $ (fromIntegral x) - (fromIntegral y)) < t

mcc :: Int -> Int -> Int -> Int -> RGBA -> RGBA -> Bool
mcc tr tg tb ta (RGBA a b c d) (RGBA x y z w) =
  cb tr a x && cb tg b y && cb tb c z && cb ta d w

median :: [a] -> a
median xs = xs !! (fromIntegral . floor . (/ 2) . fromIntegral . length) xs

(@!) :: Storable a => Ptr a -> Int -> IO a
(@!) = peekElemOff

mu :: Storable a => Int -> Ptr a -> Int -> Int -> a
mu w p j i = unsafePerformIO $ p @! (i + j * w)