-- (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 ()


-- | main program
main :: IO ()
main = do
  putStrLn $ "ExPloRe 0.0.6.0 : Experimental Plot Reconstructor"
  putStrLn $ "-------------------------------------------------------------------"
  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 $ "-------------------------------------------------------------------"
  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)