graphicstools-0.2.2: Graphics/Tools/Tangible/Instances.hs
{-#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
import Control.Monad
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 []
spinners <- sequence [sequence [(makeSpinner pnl element) | element <- row]
| row <- M.toRows mat ]
let act' = mapM (mapM (\s -> get s selection)) spinners
>>= act . Mask . M.fromList (w,h) . map fromIntegral . concat
setSpinners (concat spinners) act'
set pnl [layout := grid w h (map (map widget) spinners)]
return pnl
where
s@(w,h) = (val (undefined::width),val (undefined::height))
setSpinners ss act = forM_ ss $ \s -> set s [on select := get s selection >>= print >> act]
makeSpinner pnl el = do
s <- spinCtrl pnl (-100) 100 [selection := round el]
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)