{-#LANGUAGE DoRec, DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, TypeFamilies,
  GeneralizedNewtypeDeriving, ScopedTypeVariables#-}
module Graphics.Tools.Tangible.Instances
 where
import qualified CV.Matrix as M
import CV.Edges
import qualified Data.Map as Map
import Graphics.UI.WX hiding (value)
import Utils.Persist(Default,Persist)
import qualified Utils.Persist as P
import Data.List(elemIndex)
import Data.Maybe(fromJust)
import Graphics.Tools.Tangible

instance Tangible Int where
  present i act parent = do
    pnl <- panel parent []
    s <- spinCtrl pnl 1 100 [selection := i]
    set s [on select := get s selection >>= act]
    set pnl [layout := hfill (widget s)]
    return pnl

newtype ConvolutionMask width height = Mask (M.Matrix Float) deriving (Show)
instance HasValue (ConvolutionMask width height) where
   type Value (ConvolutionMask width height) = M.Matrix Float
   value (Mask d) = d

class MaskSize a
instance MaskSize One
instance MaskSize Two
instance MaskSize Three
instance MaskSize Five
instance MaskSize Ten

instance (Val width, Val height) => Default (ConvolutionMask width height) where
   def = Mask $ M.fromList (w,h) (replicate (w*h) 0)
    where s@(w,h) = (val (undefined::width),(val (undefined::height)))

instance (Val width, Val height) => Persist (ConvolutionMask width height) where
   put p (Mask m) = Map.singleton (p++"/ConvolutionMask:"
                                     ++ show (val (undefined::width)::Int
                                             ,(val (undefined::height)::Int)))
                                   (show . M.toList $ m)
   get p map = Mask . M.fromList (w,h)
                     $ (read $ Map.findWithDefault "[0,0,0, 0,1,0, 0,0,0]"
                        (p++"/ConvolutionMask:" ++ show s)
                        map)
         where s@(w,h) = (val (undefined::width),(val (undefined::height)))

instance (Val width, Val height) => Tangible (ConvolutionMask width height) where
   present (Mask mat) act parent = do
      pnl <- panel parent []
      rec
         let act' _ = mapM (mapM (\s -> get s selection)) spinners
                      >>= act . Mask . M.fromList (w,h) . map fromIntegral . concat
         spinners <- sequence [sequence [(makeSpinner pnl act' element) | element <- row]
                                                               | row <- M.toRows mat ]
      set pnl [layout := grid w h (map (map widget) spinners)]
      return pnl
    where
     s@(w,h) = (val (undefined::width),val (undefined::height))
     makeSpinner pnl act el = do
      s <- spinCtrl pnl (-100) 100 [selection := round el]
      set s [on select := get s selection >>= act]
      return s

instance Tangible Bool where
  present i act parent = do
    pnl <- panel parent []
    s <- checkBox pnl [checked := i]
    set s [on command := get s checked >>= print >> get s checked >>= act]
    set pnl [layout := hfill (widget s)]
    return pnl

instance Tangible Float where
  present i act parent = do
    pnl <- panel parent []
    s <- spinCtrl pnl 1 1000 [selection := round (1000*i)]
    set s [on select := get s selection >>= act.(/1000).fromIntegral]
    set pnl [layout := hfill (widget s)]
    return pnl

instance Tangible Double where
  present i act parent = do
    pnl <- panel parent []
    s <- hslider pnl False 1 1000 [selection := round (1000*i)]
    set s [on command := get s selection >>= act.(/1000).fromIntegral]
    set pnl [layout := hfill (widget s)]
    return pnl

newtype Range tp a b = Range tp deriving (Eq,Ord,Show,Num,Fractional,Default,Persist)
type DoubleRange = Range Double

instance (Val a, Val b) => Tangible (Range Double a b) where
  present i act parent = do
    pnl <- panel parent []
    s <- hslider pnl False 1 1000 [selection := toInt i]
    ctext <- staticText pnl [ text := show (value i) ]
    set s [on command := get s selection >>= \s -> set ctext [text := show (value (fromInt s))] >>
                                                   act (fromInt s)]
    set pnl [layout := hfill (row 2 [hfill (widget s), widget ctext])]
    return pnl
   where
      (minVal,maxVal) = bounds i
      toInt (Range d) = round (1000* ((d-minVal)/(maxVal-minVal)))
      fromInt i    = Range (minVal+fromIntegral i*(1/1000)*(maxVal-minVal))

instance HasValue (Range tpe a b) where
   type Value (Range tpe a b) = tpe
   value (Range d) = d

-- newtype IntRange a b = IR Int deriving (Eq,Ord,Show,Num,Default,Persist)
type IntRange = Range Int
instance (Val a, Val b) => Tangible (IntRange a b) where
  present i act parent = do
    pnl <- panel parent []
    let (mn,mx) = bounds i
    s <- spinCtrl pnl mn mx [selection := value i]
    set s [on select := get s selection >>= act.Range]
    set pnl [layout := hfill (widget s)]
    return pnl

bounds :: forall a b n. (Val a, Val b, Num n, FromFractional n) => Range n a b -> (n,n)
bounds _ = (val (undefined::a), val (undefined::b))

intbounds :: forall a b. (Val a, Val b) => IntRange a b -> (Int,Int)
intbounds _ = (val (undefined::a), val (undefined::b))

newtype Odd = Odd Int deriving (Eq,Ord,Show,Default,Persist)
instance HasValue Odd where
   type Value Odd = Int
   value (Odd i) = i

instance Tangible Odd where
  present i act parent = do
    pnl <- panel parent []
    s <- hslider pnl False 1 100 [selection := toInt i]
    ctext <- staticText pnl      [text := show (value i) ]
    set s [on command := get s selection >>= \s -> set ctext [text := show (value (fromInt s))] >>
                                                   act (fromInt s)]
    set pnl [layout := hfill (row 2 [hfill (widget s), widget ctext])]
    return pnl
   where
      toInt (Odd d) = d
      fromInt i    | even i = Odd $ i+1
                   | odd  i = Odd i



-- instance Default SobelAperture where def = s3
-- 
-- instance Persist SobelAperture where
--    put path i = Map.singleton (path++"/SobelAperture") (show i)
--    get path   = P.lookupDef (path++"/SobelAperture")
-- 
-- instance Tangible SobelAperture where
--   present = mkSelection [("Scharr",sScharr)
--                         ,("1",s1)
--                         ,("3",s3)
--                         ,("5",s5)
--                         ,("7",s7)]
-- 
-- instance Default LaplacianAperture where def = l3
-- 
-- instance Persist LaplacianAperture where
--    put path i = Map.singleton (path++"/SobelAperture") (show i)
--    get path   = P.lookupDef (path++"/SobelAperture")
-- 
-- instance Tangible LaplacianAperture where
--   present = mkSelection [("1",l1)
--                         ,("3",l3)
--                         ,("5",l5)
--                         ,("7",l7)]

mkSelection mp i act parent = do
    pnl <- panel parent []
    let fromIdx i = map snd mp !! i
        toIdx   a = fromJust $ elemIndex i (map snd mp)
    s <- radioBox pnl Horizontal (map fst mp) [text := "Aperture"]
    set s [selection := toIdx i]
    set s [on select := get s selection >>= act . fromIdx]
    set pnl [layout := hfill (widget s)]
    return pnl


class FromFractional a where
   fromFrac :: RealFrac b => b -> a

instance FromFractional Double where fromFrac = realToFrac
instance FromFractional Int    where fromFrac = ceiling

class HasValue a where
   type Value a :: *
   value :: a -> Value a

data Zero = Zero
data AlmostZero = AlmostZero
data One    = One
data Two    = Two
data Three  = Three
data Four   = Four
data Five   = Five
data Ten    = Ten
data Fifty  = Fifty
data Hundred = Hundred
data Thousand = Thousand

class Val a where
   val ::  (FromFractional n) => a -> n

instance Val AlmostZero where val _ = fromFrac ( 0.000001 :: Double )
instance Val Zero where val _       = fromFrac ( 0 :: Double)
instance Val One where val _        = fromFrac ( 1 :: Double)
instance Val Two where val _        = fromFrac ( 2 :: Double)
instance Val Three where val _      = fromFrac ( 3 :: Double)
instance Val Four where val _       = fromFrac ( 4 :: Double)
instance Val Five where val _       = fromFrac ( 5 :: Double)
instance Val Ten where val _        = fromFrac ( 10 :: Double)
instance Val Fifty where val _      = fromFrac ( 50 :: Double)
instance Val Hundred where val _    = fromFrac ( 100 :: Double)
instance Val Thousand where val _   = fromFrac ( 1000 :: Double)