{-#LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances
, FlexibleContexts, FunctionalDependencies, ScopedTypeVariables, DoRec,
UndecidableInstances#-}
module Main where

import Graphics.UI.WX
import Graphics.Tools.WX
import Graphics.Tools.CV2WX
import CV.Image as CV
import CV.Filters
import CV.Edges
import CV.ColourUtils
import CV.Corners
import CV.HoughTransform hiding (start)
import CV.DFT
import CV.Operations hiding (set)
import qualified CV.Operations as Op
import CV.ImageMath as IM
import CV.ImageMathOp
import CV.Iterators
import CV.Histogram

import Data.IORef
import Control.Applicative

triangleImage :: IO (CV.Image CV.GrayScale CV.D32)
triangleImage = CV.readFromFile "triangle_1.png"

triangleImage8 :: IO (CV.Image CV.GrayScale CV.D8)
triangleImage8 = CV.readFromFile "triangle_1.png"

triangleImageColor :: IO (CV.Image CV.RGB CV.D8)
triangleImageColor = CV.readFromFile "triangle_1.png"

rectangleImage :: IO (CV.Image CV.GrayScale CV.D32)
rectangleImage = CV.readFromFile "rectangle_5.png"

smallLenaImage :: IO (CV.Image CV.GrayScale CV.D32)
smallLenaImage = CV.readFromFile "smallLena.jpg"

smallLenaImage8 :: IO (CV.Image CV.GrayScale CV.D8)
smallLenaImage8 = CV.readFromFile "smallLena.jpg"

smallLenaImageColor :: IO (CV.Image CV.RGB CV.D32)
smallLenaImageColor = CV.readFromFile "smallLena.jpg"

main :: IO ()
main = do
  --i <- smallLenaImage
  --i <- smallLenaImage
  --i <- smallLenaImageColor
  --i <- smallLenaImage8
  i <- triangleImage8
  start (buildGUI i (Label "i" 25,Label "j" 75,(OneOf [3,5,7] 1)) f)
  where
    --f (i::Int,j::Int,t::OneOf) img = stretch_experiment img (selectOne t) i j
    --f (i::Int,j::Int,t::OneOf) img = dft_experiment img i
    --f (i::Int,j::Int,t::OneOf) img = rgb_experiment img i
    --f (i::Int,j::Int,t::OneOf) img = canny_experiment img i j $ selectOne t
    f (Label _ (i::Int),Label "j" (j::Int),t::OneOf) img = hough_experiment img i j

stretch_experiment img t i j =
  stretchHistogram $ (img #+) . unsafeImageTo32F . IM.lessThan (fromIntegral t/100) $
      ((iterate (gaussian (3,3)) img) !! i) #- ((iterate (gaussian (3,3)) img) !! j)

dft_experiment i v =
  [ PB $ polarDFT i,
    PB $ thresholdMag t $ polarDFT i,
    PB $ mapPair logNormalize $ maskMag t $ dftToPolar $ dft i,
    PB $ filterPolar (maskMag t) i ]
  where
    t = (fromIntegral v / 100)

rgb_experiment i v =
  [ PB $ i,
    PB $ histStatRgb $ rgbSplit i,
    PB $ maskR s $ rgbSplit i,
    PB $ filterRgb (maskR s) i ]
  where
    s = (fromIntegral v / 100)

canny_experiment :: Image GrayScale D8 -> Int -> Int -> Int -> [PaintableBox]
canny_experiment i v1 v2 a =
  [ PB $ (i32, stat i32, hist i32),
    PB $ IM.lessThan t1 $ i32,
    PB $ IM.lessThan t2 $ i32,
    PB $ canny (round t1 * 255) (round t2 * 255) a i]
  where
    i32 = unsafeImageTo32F i
    t1 = (fromIntegral v1 / 100)
    t2 = (fromIntegral v2 / 100)

hough_experiment i a b =
  imageHoughLinesProbabilistic 100 rho1pix theta1deg (fromIntegral a) (fromIntegral b) 10 $
  canny 64 192 5 i

scharrXEdges = sobel (1,0) sScharr

defaultHarrisResponse = harris 2 3 0.04

strongHarris = harrisCorners 0.4

probabilisticHough = (imageHoughLinesProbabilistic 100 rho1pix theta1deg 20 10 10) . (canny 64 192 5)

mapPair f (a,b) = (f a, f b)
mapTriple f (a,b,c) = (f a, f b, f c)

dftRound = idft . dft

cartesianDFT i = mapPair logNormalize (dftSplit $ dft i)

polarDFT i = mapPair logNormalize (dftToPolar $ dft i)

polarRound = idft . dftFromPolar . dftToPolar . dft

zeroPhase (mag,ang) = (mag,(clear ang))

setPhase v (mag,ang) = (mag,(Op.set v ang))

setMag v (mag,ang) = ((Op.set v mag),ang)

threshold t = gaussian (5,5) . CV.unsafeImageTo32F . IM.lessThan t

thresholdMag t (mag,ang) = (threshold t mag, ang)

maskMag t (mag,ang) = (mul (threshold t $ logNormalize mag) mag, ang)

filterPolar f = idft . dftFromPolar . f . dftToPolar . dft

filterRgb f = rgbMerge . f . rgbSplit

hist i = simpleGetHistogram i Nothing 0 1 100 False

histRgb (r,g,b) = ((r, hist r), (g, hist g), (b, hist b))

stat :: CV.Image CV.GrayScale CV.D32 -> (Float,Float)
stat i = (a,s)
  where ((a,_,_,_),(s,_,_,_)) = imageAvgSdv i

histStatRgb (r,g,b) = ((r, stat r, hist r), (g, stat g, hist g), (b, stat b, hist b))

maskR s (r,g,b) = (subS r s, g, b)

class Tangible a where
   data Representation a :: *
   type GUI a :: *
   present :: a -> (a -> IO ()) -> Window b -> IO (Representation a)
   acquire :: Representation a -> GUI a
   getValue :: Representation a -> IO a

data Labeled a = Label String a deriving (Eq,Ord,Show)

instance (Tangible a, Widget (GUI a), Tangible b, Widget (GUI b))
         => Tangible (a,b) where
   data Representation (a,b) = RPair (Panel ()) (Representation a) (Representation b)
   type GUI (a,b) = Panel ()
   acquire (RPair panel _ _) = panel
   getValue (RPair _ a b) = (,) <$> getValue a <*> getValue b
   present (a,b) act parent = do
                           p <- panel parent []
                           rec
                              aw <- present a act1 p
                              bw <- present b act2 p
                              let act1 x = do
                                         v <-getValue bw
                                         act (x,v)
                                  act2 x = do
                                         v<-getValue aw
                                         act (v,x)
                           set p [layout := column 2 [hfill $ widget (acquire aw)
                                                     ,hfill $ widget (acquire bw)]]
                           return $ RPair p aw bw

instance (Tangible a, Widget (GUI a))
         => Tangible (Labeled a) where
   type GUI (Labeled a) = Panel ()
   data Representation (Labeled a) = LabelRep String (Panel ()) (Representation a)
   acquire (LabelRep s p a) = p
   getValue (LabelRep s p a) = Label s <$> (getValue a)
   present (Label s a) e p = do
                  pnl <- panel p []
                  ctext <- staticText pnl [ text := s ]
                  el <- present a (\a -> e (Label s a)) pnl
                  set pnl [layout := column 2 [hfill $ widget ctext
                                              ,hfill $ widget (acquire el)]]
                  return $ LabelRep s pnl el


instance (Tangible a, Tangible b, Tangible c,Widget (GUI a), Widget (GUI b), Widget (GUI c))
         => Tangible (a,b,c) where
   type GUI (a,b,c) = GUI (a,(b,c))
   data Representation (a,b,c) = RTriple (Representation (a,(b,c)))
   acquire (RTriple a) = acquire a
   getValue (RTriple a) = getValue a >>= \(a,(b,c)) -> return (a,b,c)
   present (a,b,c) e p = RTriple <$> present (a,(b,c)) (\(a,(b,c))-> e (a,b,c)) p

instance (Tangible a, Widget (GUI a)) => Tangible [a] where
   type GUI [a] = Panel ()
   data Representation [a] = RList (Panel ()) [Representation a]
   acquire (RList p _) = p
   getValue (RList _ r) = mapM getValue r
   present xs act parent = do
               p <- panel parent []
               rec
                  let act' _ = mapM getValue reps >>= act
                  reps <- mapM (\a -> present a act' p) xs
               set p [layout := column 2 (map (hfill.widget.acquire) reps)]
               return $ RList p reps

instance Tangible Int where
  data Representation Int = RInt (Slider ())
  type GUI Int = Slider ()
  acquire (RInt s) = s
  getValue (RInt s) = get s selection
  present i act parent = do
    s <- hslider parent True 1 100 [selection := i]
    set s [on command := get s selection >>= act]
    return (RInt s)

data OneOf = OneOf{ choices :: [Int], index :: Int }

selectOne :: OneOf -> Int
selectOne (OneOf xs i)
  | i >= 0 && i < length xs = xs !! i
  | otherwise = 0

instance Tangible OneOf where
  type GUI OneOf = RadioBox ()
  data Representation OneOf = ROneOf (RadioBox ()) [Int] Int
  acquire (ROneOf b _ _) = b
  getValue (ROneOf b as _) = do
    i <- get b selection
    return $ (OneOf as i)
  present (OneOf as i) act parent = do
    b <- radioBox parent Horizontal (map show as) [selection := i]
    set b [on select := getValue (ROneOf b as i) >>= act]
    return $ ROneOf b as i

paintSurface p dc viewArea = doPaint dc (point 0 0) p

createSurface f p =
  panel f [ on paint := paintSurface p, outerSize := paintSize p ]

updateSurface s p = do
  set s [ on paint := paintSurface p, outerSize := paintSize p ]
  repaint s

buildGUI :: (Tangible a, Widget (GUI a), WxPaintable p)
            => Image c d -> a ->
               (a -> Image c d -> p) -> IO ()
buildGUI i tv function = do
  f <- frame [ text := "FilterVictor" ]
  s <- createSurface f (function tv i)

  let update tv' = updateSurface s (function tv' i)

  controls <- panel f []
  ctext <- staticText controls [ text := "Controls" ]
  c :: b <- acquire <$> present tv update controls
  set controls [layout := margin 5 (column 2 [widget ctext, hfill $ widget c])]

  set f [ layout := margin 10 $ column 10 [row 10 [widget s,widget controls]]]
  return ()