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