diff --git a/Help.hs b/Help.hs --- a/Help.hs +++ b/Help.hs @@ -9,8 +9,8 @@ \DESCRIPTION\n\ \\n\ \\n\ -\ image the image file to scan, it should be a 32-bit PNG with an alpha\n\ -\ channel\n\ +\ image the image file to scan, it should be a 32-bit PNG with an\n\ +\ alpha channel\n\ \\n\ \\n\ \\n\ @@ -23,9 +23,9 @@ \\n\ \ tolerance how much color components can deviate from base colors\n\ \ \n\ -\ S strict: allow no deviation (= TC 0 0 0 0)\n\ +\ S strict: allow no deviation (= TC 0 0 0 0)\n\ \\n\ -\ TA m maximum delta for all components (= TC m m m m)\n\ +\ TA m maximum delta for all components (= TC m m m m)\n\ \\n\ \ TC r g b a individiual maximum delta values\n\ \ for corresponding components\n\ @@ -36,11 +36,11 @@ \\n\ \ (w = image width, h = image height)\n\ \\n\ -\ F all image area (= B 0 0 w h)\n\ +\ F all image area (= B 0 0 w h)\n\ \\n\ -\ O l t offset from left and top (= B l t w h)\n\ +\ O l t offset from left and top (= B l t w h)\n\ \\n\ -\ M l t r b margins from left, top, (= B l t w-r h-b)\n\ +\ M l t r b margins from left, top, (= B l t w-r h-b)\n\ \ right and bottom\n\ \\n\ \ B l t r b a plot box; with left, top, right and bottom\n\ @@ -48,12 +48,19 @@ \\n\ \\n\ \\n\ -\ interval horizontal scan interval in pixels, this value is read as\n\ -\ a floating point number so you can give 4,5 for a scan\n\ +\ step-size horizontal step-size, this value is read as a floating point\n\ +\ number\n\ \\n\ +\ (w = image width)\n\ +\\n\ +\ double-precision constant step size s\n\ +\\n\ +\ / double-precision step-size gained by dividing\n\ +\ the width of the image by n\n\ +\\n\ \ \n\ \ \n\ -\ translation 2d translation to be applied to the output pixels\n\ +\ [translation] 2d translation to be applied to the output pixels\n\ \\n\ \ Identity output pixels exactly as they are located\n\ \ in the input image; old default with full\n\ @@ -67,6 +74,10 @@ \\n\ \\n\ \HISTORY\n\ +\\n\ +\ 0.0.7\n\ +\ - Support for invocation files\n\ +\ - Support for calculating step sizes by dividing the scan area\n\ \\n\ \ 0.0.6.2\n\ \ - Fixed help output\n\ diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,9 +1,11 @@ --- (c) 2009, Cetin Sert +-- Copyright 2009, Cetin Sert + -- | ExPloRe: Experimental Plot Reconstructor module Main where -import System.Environment +import System.Environment +import System.Directory import System.IO.Unsafe import System.Exit import Data.Word @@ -13,11 +15,21 @@ import Control.Monad import Codec.Image.PNG -import Help +import Help -- | line names in legends -type Name = String +type Name = String +-- | file paths +type ImagePath = String + +-- | legends +type Legend = [(Name, RGBA)] + +-- | internal representation of an unnormalized explore invocation +data ExploreInvocation = Explore ImagePath Legend Matching ScanArea StepSize Translation + deriving (Show, Read, Eq) + -- | 32-bit color representation data RGBA = RGBA !Word8 !Word8 !Word8 !Word8 -- ^ RED BLUE GREEN ALPHA deriving (Show, Read, Eq) @@ -50,12 +62,17 @@ 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 + | Default -- ^ gets normalized to the default translation deriving (Show, Read, Eq) +-- | step size +data StepSize = ConstantJump Double -- ^ only step size supported upto version 0.0.6.2 + | WidthDivision Double -- ^ + deriving (Show, Read, Eq) + -- | normalizes scan area representations normalizeScanArea :: Int -> Int -> ScanArea -> ScanArea normalizeScanArea w h F = B 0 0 w h @@ -63,6 +80,46 @@ normalizeScanArea w h (M l t r b) = B l t (w-r) (h-b) normalizeScanArea _ _ box = box +-- | horizontal translation function +type HTrans = Int -> Int + +-- | vertical translation function +type VTrans = Int -> Int + +-- | creates translation functions +makeTranslationFunctions :: Translation -> ScanArea -> (HTrans, VTrans) +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) + -- | ExPloRe requires PNGs with transparency channel and no interlacing checkAlpha :: PNGImage -> IO () checkAlpha (hasAlphaChannel -> True) = return () @@ -73,70 +130,107 @@ checkArgs [] = putStrLn help >> exitSuccess checkArgs _ = return () -hrule :: String -hrule = replicate 80 '-' +hrule :: Char -> String +hrule = replicate 80 --- | main program -main :: IO () +-- | main +main :: IO () main = do - putStrLn $ "ExPloRe 0.0.6.2 : Experimental Plot Reconstructor" - putStrLn $ hrule - putStrLn $ "" + putStrLn $ "ExPloRe 0.0.7 : Experimental Plot Reconstructor" + putStrLn $ hrule '=' args <- getArgs checkArgs args - let (imgPath:legendPath:matching_:area_:step_:oargs) = args + putStrLn $ "invocation file" + putStrLn $ hrule '-' ++ tail (filter (/= '"') $ concatMap (('\n':) . show) args) ++ "\n" ++ hrule '-' + explore <- makeInvocation args + run explore - -- optional arguments - let translation = case null oargs of - True -> Box Bottom - _ -> read . head $ oargs - - -- initialize image +-- | supports invocation files and provides backwards-compatibility with +-- 0.0.6.2 style command line arguments +makeInvocation :: [String] -> IO ExploreInvocation + +makeInvocation [invocationPath] = do + makeInvocation =<< (liftM lines . readFile $ invocationPath) + +makeInvocation args = do + putStrLn $ "args : " ++ show args + let (imgPath:legend_:matching_:area_:step_:oargs) = args + matching <- return . read $ matching_ + area <- return . read $ area_ + lfexists <- doesFileExist legend_ + legend <- case lfexists of + True -> liftM read . readFile $ legend_ + _ -> return . read $ legend_ + stepSize <- return $ case step_ of + ('/':parts) -> WidthDivision $ read parts + size -> ConstantJump $ read size + translation <- return $ case null oargs of + True -> Box Bottom + _ -> read . head $ oargs + return $ Explore imgPath legend matching area stepSize translation + + +-- | new run function +run :: ExploreInvocation -> IO () +run invocation@(Explore imgPath legend matching area stepSize translation) = do + -- display internal normalized invocation + -- putStrLn $ "invoc.: " ++ show invocation + -- putStrLn $ "" + + -- 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 $ "" + let (w,h) = (fromIntegral wu, fromIntegral hu) + args <- getArgs putStrLn $ "image : " ++ imgPath putStrLn $ "width : " ++ show w putStrLn $ "height: " ++ show h - putStrLn $ "" - checkAlpha img + checkAlpha img + -- initialize scan - let box@(B l t r b) = normalizeScanArea w h . read $ area_ :: ScanArea + let box@(B l t r b) = normalizeScanArea w h area :: ScanArea let start = fromIntegral l :: Double - let step = read step_ :: Double + let end = fromIntegral r :: Double + let step = case stepSize of + ConstantJump size -> size + WidthDivision parts -> (end - start) / parts + let trans = case translation of + Default -> Box Bottom + any -> any let (@#) = make2DIndexer w let rows = [t..b] - let cols = takeWhile (< r) $ map (floor . (start +) . (step *)) [0..] + 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 + putStrLn $ "trans.: " ++ show trans + putStrLn $ "match : " ++ show matching + putStrLn $ "step : " ++ show stepSize + putStrLn $ "step : " ++ (show $ convertStepSize (end - start) stepSize) - -- 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 + -- display legend + putStrLn $ "#lines: " ++ (show . length $ legend) + putStrLn $ "" + mapM_ (putStrLn . show) legend + -- scan bitmap + mapM_ (scan bitmap translation box icols rows (@#) (~=)) legend +convertStepSize :: Double -> StepSize -> StepSize +convertStepSize width (ConstantJump size ) = WidthDivision $ width / size +convertStepSize width (WidthDivision parts) = ConstantJump $ width / parts + + + -- | 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 $ hrule '-' putStrLn $ name putStrLn $ "" putStrLn $ show color @@ -159,45 +253,4 @@ 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) +-- Copyright 2010, Cetin Sert diff --git a/explore.cabal b/explore.cabal --- a/explore.cabal +++ b/explore.cabal @@ -1,9 +1,9 @@ name: explore -version: 0.0.6.2 +version: 0.0.7.0 cabal-version: >= 1.4 license: BSD3 license-file: LICENSE -copyright: (c) 2009, Cetin Sert +copyright: Copyright 2009, 2010, Cetin Sert author: Cetin Sert maintainer: Cetin Sert bug-reports: Cetin Sert @@ -37,6 +37,7 @@ main-is: Main.hs ghc-options: -O2 -fglasgow-exts -funbox-strict-fields build-depends: base <= 5, + directory -any, array -any, pngload -any extensions: ViewPatterns