explore-0.0.6.2: Main.hs
-- (c) 2009, Cetin Sert
-- | ExPloRe: Experimental Plot Reconstructor
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 Codec.Image.PNG
import Help
-- | line names in legends
type Name = String
-- | 32-bit color representation
data RGBA = RGBA !Word8 !Word8 !Word8 !Word8 -- ^ RED BLUE GREEN ALPHA
deriving (Show, Read, Eq)
-- storable instance for retrieveal
instance Storable RGBA where
sizeOf _ = sizeOf (0 :: Word8) * 4
alignment _ = 1
peek color = do
let byte :: Ptr Word8 = castPtr color
[r,g,b,a] <- mapM (byte @!) [0..3]
return $ RGBA r g b a
-- | colour matching behaviour
data Matching = S -- ^ strict
| TA Int -- ^ shared threshold for all color components
| TC Int Int Int Int -- ^ individual thresholds for color components
deriving (Show, Read, Eq)
-- | scan area
-- w = width of the PNG image
-- h = height of the PNG image
data ScanArea = F -- ^ scan all the image area (FULL) | 0 0 w h
| O Int Int -- ^ offset from LEFT TOP | L T w h
| M Int Int Int Int -- ^ offset from LEFT TOP RIGHT BOTTOM | L T (w-R) (h-B)
| B Int Int Int Int -- ^ box LEFT TOP RIGHT BOTTOM | L T R B
deriving (Show, Read, Eq)
-- | vertical offset reference line
data VerticalOffsetReferenceLine = Top -- ^ top line of plot box
| Bottom -- ^ bottom line of plot box
deriving (Show, Read, Eq)
-- | translation
data Translation = Identity -- ^ identity translation
| Box VerticalOffsetReferenceLine -- ^ box translation
deriving (Show, Read, Eq)
-- | normalizes scan area representations
normalizeScanArea :: Int -> Int -> ScanArea -> ScanArea
normalizeScanArea w h F = B 0 0 w h
normalizeScanArea w h (O l t) = B l t w h
normalizeScanArea w h (M l t r b) = B l t (w-r) (h-b)
normalizeScanArea _ _ box = box
-- | ExPloRe requires PNGs with transparency channel and no interlacing
checkAlpha :: PNGImage -> IO ()
checkAlpha (hasAlphaChannel -> True) = return ()
checkAlpha _ = putStrLn "no alpha channel going on!!!" >> exitWith (ExitFailure 1)
-- | check presence of arguments, show usage otherwise
checkArgs :: [String] -> IO ()
checkArgs [] = putStrLn help >> exitSuccess
checkArgs _ = return ()
hrule :: String
hrule = replicate 80 '-'
-- | main program
main :: IO ()
main = do
putStrLn $ "ExPloRe 0.0.6.2 : Experimental Plot Reconstructor"
putStrLn $ hrule
putStrLn $ ""
args <- getArgs
checkArgs args
let (imgPath:legendPath:matching_:area_:step_:oargs) = args
-- optional arguments
let translation = case null oargs of
True -> Box Bottom
_ -> read . head $ oargs
-- initialize image
Right img <- loadPNGFile imgPath
let bitmap = imageData img
let (wu,hu) = dimensions img
let (w,h) = (fromIntegral wu, fromIntegral hu)
putStrLn $ "call : " ++ tail (filter (/= '"') $ concatMap ((' ':) . show) args)
putStrLn $ ""
putStrLn $ "image : " ++ imgPath
putStrLn $ "width : " ++ show w
putStrLn $ "height: " ++ show h
putStrLn $ ""
checkAlpha img
-- initialize scan
let box@(B l t r b) = normalizeScanArea w h . read $ area_ :: ScanArea
let start = fromIntegral l :: Double
let step = read step_ :: Double
let (@#) = make2DIndexer w
let rows = [t..b]
let cols = takeWhile (< r) $ map (floor . (start +) . (step *)) [0..]
let icols = zip [1..] cols
let matching = read matching_ :: Matching
let (~=) = colorEq matching
putStrLn $ "box : " ++ show box
putStrLn $ "width : " ++ show (r - l)
putStrLn $ "height: " ++ show (b - t)
putStrLn $ "match : " ++ show matching
-- initialize lines
lines_ <- readFile legendPath
let lines = read lines_ :: [(Name,RGBA)]
putStrLn $ "legend: " ++ legendPath
putStrLn $ "lines : " ++ (show $ length lines)
putStrLn $ "step : " ++ show step
putStrLn $ ""
mapM_ (putStrLn . show) lines
-- scan bitmap
mapM_ (scan bitmap translation box icols rows (@#) (~=)) lines
-- | a very simple scanning algorithm that works only if no lines
-- occlude each other.
scan bitmap translation box@(B l t r b) icols rows (@#) (~=) (name,color) = do
putStrLn $ ""
putStrLn $ hrule
putStrLn $ name
putStrLn $ ""
putStrLn $ show color
putStrLn $ ""
putStrLn $ "box : " ++ show box
putStrLn $ "width : " ++ show (r - l)
putStrLn $ "height : " ++ show (b - t)
putStrLn $ "translation: " ++ show translation
putStrLn $ ""
putStrLn $ "x\tpoint\tmid y\tmatching ys"
putStrLn $ ""
withStorableArray bitmap $ \byte -> do
let pixel :: Ptr RGBA = castPtr byte
let (hof,vof) = makeTranslationFunctions translation box
forM_ icols $ \(n,j) -> do
let ys = map vof $ flip filter rows $ \i -> (pixel @# i) j ~= color
let my = mid ys
let x = hof j
putStrLn $ case not . null $ ys of
True -> show x ++ "\t" ++ show n ++ "\t" ++ show my ++ "\t" ++ show ys
False -> show x ++ "\t" ++ show n ++ "\t \t[]"
-- | translation functions
type HorizontalTranslationFunction = Int -> Int
type VerticalTranslationFunction = Int -> Int
makeTranslationFunctions :: Translation
-> ScanArea
-> (HorizontalTranslationFunction,
VerticalTranslationFunction)
makeTranslationFunctions Identity _ = (id, id)
makeTranslationFunctions (Box Top ) (B l t r b) = ((− l),(− t))
makeTranslationFunctions (Box Bottom) (B l t r b) = ((− l),(b −))
(−) = (-)
-- | fuzzy color matching
colorEq :: Matching -> RGBA -> RGBA -> Bool
colorEq S = compEq 0 0 0 0
colorEq (TA v) = compEq v v v v
colorEq (TC r g b a) = compEq r g b a
-- | fuzzy color matching
compEq :: Int -> Int -> Int -> Int -> RGBA -> RGBA -> Bool
compEq tr tg tb ta (RGBA a b c d) (RGBA x y z w) = let fe = fuzzyEq in
fe tr a x && fe tg b y && fe tb c z && fe ta d w
-- | simple fuzzy equality
fuzzyEq :: forall b a. (Num b, Ord b, Integral a) => b -> a -> a -> Bool
fuzzyEq 0 = (==)
fuzzyEq t = \x y -> t > (abs $ fromIntegral x - fromIntegral y)
-- | gets the middle element of a list, used as a quick median function
mid :: forall a. [a] -> a
mid xs = xs !! (fromIntegral . floor . (/ 2) . fromIntegral . length) xs
(@!) :: Storable a => Ptr a -> Int -> IO a
(@!) = peekElemOff
make2DIndexer :: Storable a => Int -> Ptr a -> Int -> Int -> a
make2DIndexer w = \p j i -> unsafePerformIO $ p @! (i + j * w)