packages feed

graphicstools 0.2 → 0.2.1

raw patch · 5 files changed

+526/−2 lines, 5 filesdep +containersdep +directorydep +ghc-primdep ~CV

Dependencies added: containers, directory, ghc-prim

Dependency ranges changed: CV

Files

+ Graphics/Tools/DefaultGUI.hs view
@@ -0,0 +1,147 @@+{-#LANGUAGE FlexibleInstances , FlexibleContexts, DoRec, NoMonomorphismRestriction, TypeFamilies #-}+module Graphics.Tools.DefaultGUI (+   defaultGUI,+   testFunction,+   module Graphics.Tools.Tangible,+   module Graphics.Tools.Tangible.Instances,+   module Utils.Persist,+   module Graphics.Tools.WX,+   module GHC.Generics+   ) where++import Graphics.UI.WX hiding (image,value,parent,get)+import qualified Graphics.UI.WX as WX (value,parent,get)+import Graphics.Tools.WX+import Graphics.Tools.CV2WX()+import CV.Image as CV+import CV.Filters++import Data.IORef+import Control.Applicative+import Utils.Persist++import System.Directory (doesFileExist)+import qualified Data.Map as Map+import Graphics.Tools.Tangible+import Graphics.Tools.Tangible.Instances+import GHC.Generics++defaultGUI+  :: (Tangible α,+      Persist α,+      Default α,+      WxPaintable β,+      WxImage  (Image c d),+      Loadable (Image c d)) =>+        FilePath -- ^ File to store the filter parameters in+     -> FilePath -- ^ Initial image file+     -> (α -> Image c d -> β) -- ^ The processing function+     -> IO ()+defaultGUI storeFile imageFile = start . buildGUI imageFile . mkGUIOp storeFile++testFunction :: Int -> Image GrayScale  D32 -> Image GrayScale D32+testFunction i img = (!!i) . iterate (gaussian (3,3)) $ img++type GUIOp c d=+   IORef (Image c d)+   -> Frame () -> Panel () -> Frame ()+   -> IO (IO ())++mkGUIOp :: (Persist α, Default α, Tangible α, WxPaintable β) =>+      FilePath               -- ^ File to persist parameters+   -> (α -> Image c d -> β)  -- ^ A function to transform a tangible value and image to something+                             --   that WX knows how to paint+   -> GUIOp c d              -- ^ Operation that can be given to `defaultMain`++mkGUIOp storeFile function imageRef frame surface controls =+  let update lastValue value = do+         image <- readIORef imageRef+         let display = function value image+         set frame [outerSize := paintSize display]+         updateSurface surface display+         store <- readIORef lastValue+         let store' = Map.union (put "" value) store+         writeIORef lastValue store'+         writeFile storeFile (show store')+  in do+      e <- doesFileExist storeFile+      store  <- if e then read <$> readFile storeFile else return Map.empty+      lastValue <- newIORef store+      c <- present (get "" store) (update lastValue) controls+      set controls [layout := widget c]+      return (readIORef lastValue >>= update lastValue . get "")++buildGUI :: (WxImage (Image c d), Loadable (Image c d)) =>+            FilePath -> GUIOp c d -> IO ()+buildGUI imagePath guiOp = do+  -- Program state+  image <- CV.readFromFile imagePath+  imageRef <- newIORef image++  -- Main window+  f <- frame [ text := "Filter Tuner" ]++  -- Create the menu+  file   <- menuPane [text := "&File"]+  mopen  <- menuItem file [text  := "&Open Image\tCtrl+O"+                          , help := "Open image to be processed"]+  msave  <- menuItem file [text  := "&Save Image\tCtrl+O"+                          , help := "Save current image"]+  mclose <- menuQuit file []+  set f [menuBar := [file]]++  -- Create the image viewer+  imgPanel <- panel f []+  surface <- createSurface imgPanel image++  -- Create the control panel+  controls <- frameTool [] f+  update <- guiOp imageRef f surface controls++  -- Hook everything together+  set f [on (menu mopen)  := openFile f imageRef >> update+        ,on (menu mclose) := close f+        ,on (menu msave)  := saveFile f imageRef+                             ]+  set f [layout := row 2 [widget imgPanel]]++  -- Make sure the image is current+  set f [on idle := update >> return False]+  return ()++saveFile :: Window a -> IORef (Image c d) -> IO ()+saveFile f imageRef = do+  file <- fileSaveDialog f True False "Save as" [("Image file",["*.png","*.jpg","*.tif","*.tiff"])] "" ""+  case file of+   Nothing -> return ()+   Just filename -> readIORef imageRef >>= saveImage filename++openFile :: (CV.Sized a1, Loadable a1, CV.Size a1 ~ (Int, Int)) =>+            Window a -> IORef a1 -> IO ()+openFile f imageRef = do+   file <- fileOpenDialog f True True "Select Image"+             [("Image file",["*.png","*.jpg","*.tif","*.tiff"])] "" ""+   case file of+    Nothing -> return ()+    Just newFile -> do+                     img <- readFromFile newFile+                     writeIORef imageRef img++imageSize :: (Num b, CV.Sized a, CV.Size a ~ (b, b)) => a -> Size2D b+imageSize = uncurry Size . getSize++paintSurface' :: WxPaintable p => p -> DC a -> t -> IO ()+paintSurface' p dc _ = doPaint dc (point 0 0) p++createSurface :: WxPaintable p => Window a -> p -> IO (Panel ())+createSurface f p =+  panel f [ on paint := paintSurface' p, outerSize := paintSize p ]++updateSurface :: (Paint w, Dimensions w, WxPaintable p) => w -> p -> IO ()+updateSurface s p = do+  set s [ on paint := paintSurface p, outerSize := paintSize p ]+  repaint s++paintSurface :: WxPaintable p => p -> DC a -> t -> IO ()+paintSurface p dc _ = doPaint dc (point 0 0) p+
+ Graphics/Tools/Tangible.hs view
@@ -0,0 +1,57 @@+{-#LANGUAGE DoRec, DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, TypeFamilies,+  GeneralizedNewtypeDeriving, ScopedTypeVariables#-}+module Graphics.Tools.Tangible (Tangible(..)) where+import GHC.Generics+import Data.IORef+import Graphics.UI.WX hiding (value)++class Tangle f where+   make ::  f a -> (f a -> IO ()) -> Window b -> IO (Panel ())++instance (Tangible a) => Tangle (K1 R a) where+   make (K1 a) event parent = do+      pnl <- panel parent []+      el <- present a (event.K1) pnl+      set pnl [layout := hfill $ widget el]+      return pnl++instance (Tangle a, Tangle b) => Tangle (a :*: b) where+   make (a :*: b) act parent = do+                           p <- panel parent []+                           ref <- newIORef (a,b)+                           rec+                              aw <- make a act1 p+                              bw <- make b act2 p+                              let act1 x = do+                                         modifyIORef ref (\(a,b) -> (x,b))+                                         readIORef ref >>= \(a,b) -> act (a:*:b)+                                  act2 x = do+                                         modifyIORef ref (\(a,b) -> (a,x))+                                         readIORef ref >>= \(a,b) -> act (a:*:b)+                           set p [layout := column 2 [hfill $ widget aw+                                                     ,hfill $ widget bw]]+                           return p++instance (Datatype s1, Constructor c1, Tangle f) => Tangle (M1 D s1 (M1 C c1 f)) where+   make m1@(M1 x) event parent = do+                  pnl <- panel parent []+                  ctext <- staticText pnl [ text := datatypeName m1++"/"++conName x++":" ]+                  el <- make (unM1 x) (event . M1 . M1) pnl+                  set pnl [layout := column 0 [widget ctext+                                              ,hfill $ widget el]]+                  return pnl++instance (Selector s1, Tangle f) => Tangle (M1 S s1 f) where+   make m1@(M1 x) event parent = do+                  pnl <- panel parent []+                  ctext <- staticText pnl [ text := selName m1 ]+                  el <- make x (event.M1) pnl+                  set pnl [layout := row 0 [widget ctext,vspace 8, hfill $ widget el]]+                  return $ pnl+++class Tangible a where+   present :: a -> (a -> IO ()) -> Window b -> IO (Panel ())+   default present :: (Generic a, Tangle (Rep a)) => a -> (a -> IO ()) -> Window b -> IO (Panel ())+   present a evt p = make (from a) (evt.to) p+
+ Graphics/Tools/Tangible/Instances.hs view
@@ -0,0 +1,222 @@+{-#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)+
+ Utils/Persist.hs view
@@ -0,0 +1,91 @@+{-#LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts,ScopedTypeVariables, TypeOperators, DefaultSignatures, TypeFamilies#-}+module Utils.Persist where+import GHC.Generics+import qualified Data.Map as M+import Data.Map (Map, (!))++class Default a where+   def :: a+   default def :: (Generic a, Defaulting (Rep a)) => a+   def = to deff++instance Default Int where+   def = 1++instance Default Bool where+   def = False++instance Default Double where+   def = 1.0++class Defaulting f where+   deff :: f a++instance Defaulting U1 where+   deff = U1++instance (Defaulting a, Defaulting b) => Defaulting (a :*: b) where+   deff = deff :*: deff++instance (Defaulting a, Defaulting b) => Defaulting (a :+: b) where+   deff = L1 deff++instance (Defaulting a) => Defaulting (M1 i c a) where+  deff  = M1 $ deff++instance (Default a) => Defaulting (K1 i a) where+  deff  = K1 def+++lookupDef :: (Read a, Default a) => String -> Map String String -> a+lookupDef path map = case M.lookup path map of+                      Nothing -> def+                      Just  s -> read s++class Persistent f where+   persist :: String -> f a -> Map String String+   restore :: String -> Map String String -> f a++instance Persist Int where+   put path i = M.singleton (path++"/int") (show i)+   get path = lookupDef (path++"/int")++instance Persist Bool where+   put path i = M.singleton (path++"/bool") (show i)+   get path = lookupDef (path++"/bool")++instance Persist Double where+   put path i = M.singleton (path++"/double") (show i)+   get path = lookupDef (path++"/double")++instance Persist f => Persistent (K1 R f) where+   persist path i = put path (unK1 i)+   restore path map  = K1 $ get path map++instance (Selector s1, Persistent a) => Persistent (M1 S s1 a) where+   persist path a = persist (path++"/"++selName a) (unM1 $ a)+   restore path map = M1 $ restore (path++"/"++selName (undefined :: M1 S s1 a x)) map++instance (Constructor c1, Persistent f) => Persistent (M1 C c1 f) where+   persist path a = persist (path++"/"++conName a) (unM1 $ a)+   restore path map = M1 (restore (path++"/"++conName (undefined :: M1 C c1 f a)) map)++instance (Datatype c1, Persistent f) => Persistent (M1 D c1 f) where+   persist path a = persist (path++"/"++datatypeName a) (unM1 $ a)+   restore path map = M1 (restore (path++"/"++datatypeName (undefined :: M1 D c1 f a)) map)++instance (Persistent a, Persistent b) => Persistent (a :*: b) where+   persist path (a:*:b) = M.union (persist path a) (persist path b)+   restore path map = restore path map :*: restore path map++class Persist a where+   put :: String -> a -> Map String String+   default put :: (Generic a, Persistent (Rep a)) => String -> a -> Map String String+   put s a = persist s (from a)+   get :: String -> Map String String -> a+   default get :: (Generic a, Persistent (Rep a)) => String -> Map String String -> a+   get s m = to (restore s m)++type Store = Map String String+migrate :: (Default a, Default b, Persist a, Persist b) => a -> b+migrate = get "" . put ""
graphicstools.cabal view
@@ -1,5 +1,5 @@ Name:                graphicstools-Version:             0.2+Version:             0.2.1 Synopsis:            Tools for creating graphical UIs, based on wxHaskell. Description:         This library provides interfaces for creating easily                      graphical UIs especially for computer vision purposes,@@ -32,13 +32,20 @@   Exposed-modules:     Graphics.Tools.WX,     Graphics.Tools.CV2WX,+    Graphics.Tools.DefaultGUI,+    Graphics.Tools.Tangible+    Graphics.Tools.Tangible.Instances+    Utils.Persist     Graphics.Tools.Bindings.Convert   Extensions:     ForeignFunctionInterface   Build-Depends:     base >= 3 && < 5,+    ghc-prim,+    containers >= 0.4.2 && < 0.8,     bindings-DSL >= 1.0.7 && < 1.1,-    CV >= 0.3.4,+    directory >= 1.1 &&  < 2.5,+    CV >= 0.3.5,     wxcore >= 0.12.1.6,     wx >= 0.12.1.6   Include-dirs: