module PlotLab.Main (main) where import Control.Monad (when) import Data.Maybe (fromJust) import Data.Colour.Names import Graphics.Rendering.Plot import Graphics.UI.Gtk hiding(Circle,Cross) import Data.IORef (IORef, newIORef, readIORef, modifyIORef) import Numeric.LinearAlgebra (linspace) import Data.Text (pack, unpack) import PlotLab.Events (attachHandlers) import PlotLab.FigureSettings -- import Control.Concurrent -- import Control.Concurrent.MVar -- import qualified Graphics.Rendering.Pango as P -- import qualified Graphics.Rendering.Cairo as C -- import Data.Packed.Vector -- import Data.Packed.Random -- import Data.Packed() -- import Numeric.LinearAlgebra.Instances -- import Numeric.LinearAlgebra.Interface -- import Numeric.GSL.Statistics -- import Debug.Trace -- import qualified Data.Array.IArray as A -------------------------------------------------------------------------------- updateFigureText :: (Text () -> Figure ()) -> (Maybe String) -> Double -> Figure () updateFigureText withSomething txt size = withSomething $ do if txt == Nothing then setText "" else setText (fromJust txt) setFontSize size -------------------------------------------------------------------------------- updateAxis axis show location range scale label size = do let (position, side) = location when show $ addAxis axis position (when (label /= Nothing) $ withAxisLabel $ do setText $ fromJust label setFontSize size) if range == Nothing then setRangeFromData axis side scale else uncurry (setRange axis side scale) (fromJust range) -------------------------------------------------------------------------------- buildFigure :: (Dataset a) => a -> FigureSettings -> Figure () buildFigure dset fset = do withTextDefaults $ setFontFamily (fontFamily fset) let title = plotTitle fset size = plotTitleSize fset in updateFigureText withTitle title size let title = subTitle fset size = subTitleSize fset in updateFigureText withSubTitle title size setPlots 1 1 withPlot (1, 1) $ do setDataset dset -- X-Axis let show = showXAxis fset text = xLabel fset size = xLabelSize fset loc = xLocation fset range = xRange fset scale = plotScaleX fset in updateAxis XAxis show loc range scale text size -- Y-Axis let show = showYAxis fset text = yLabel fset size = yLabelSize fset loc = yLocation fset range = yRange fset scale = plotScaleY fset in updateAxis YAxis show loc range scale text size -------------------------------------------------------------------------------- type AdjustmentSettings = (Double, Double, Double, Double, Double, Double) -------------------------------------------------------------------------------- addSlidersToBox :: [AdjustmentSettings] -> VBox -> IO [Adjustment] addSlidersToBox conf box = do let newAdj (a, b, c, d, e, f) = adjustmentNew a b c d e f newAdjList conf = mapM newAdj conf newHScaleList adjs = mapM hScaleNew adjs adjs <- newAdjList conf sliders <- newHScaleList adjs mapM_ (\x -> scaleSetValuePos x PosRight) sliders mapM_ (\x -> scaleSetDigits x 2) sliders mapM_ (\x -> boxPackEnd box x PackNatural 0) sliders return adjs -------------------------------------------------------------------------------- updateCanvas :: DrawingArea -> IORef FigureSettings -> [Adjustment] -> IO () updateCanvas canvas iofset adjs = do fset <- readIORef iofset s@(w, h) <- widgetGetSize canvas drw <- widgetGetDrawWindow canvas vars <- mapM adjustmentGetValue adjs let rate = samplingRate fset samples = (\(x, y) -> rate * floor (y - x)) (fromJust $ xRange fset) domain = linspace samples (fromJust $ xRange fset) f = g vars dset = (domain, [line f blue]) r = render $ buildFigure dset fset region <- regionRectangle $ Rectangle 0 0 w h drawWindowBeginPaintRegion drw region renderWithDrawable drw (r s) drawWindowEndPaint drw -------------------------------------------------------------------------------- -- Create a new window -- Initially fill the values -- Call PlotLab.Events.attachHandlers to attach Event Handlers figureWindow :: String -> IORef FigureSettings -> [AdjustmentSettings] -> ([Double] -> Double -> Double) -> IO () figureWindow plotGlade iofset conf g = do builder <- builderNew builderAddFromFile builder plotGlade plotBox <- builderGetObject builder castToVBox "Plot Region" adjs <- addSlidersToBox conf plotBox fset <- readIORef iofset let updateEntryText entryGlade text = when (text /= Nothing) $ do entry <- builderGetObject builder castToEntry entryGlade entrySetText entry $ fromJust text in do updateEntryText "Plot Title Entry" $ plotTitle fset updateEntryText "Subtitle Entry" $ subTitle fset updateEntryText "X-Label Entry" $ xLabel fset updateEntryText "Y-Label Entry" $ yLabel fset updateEntryText "File Entry" $ Just (fileName fset) let adjApplyValue adjGlade val = do adj <- builderGetObject builder castToAdjustment adjGlade adjustmentSetValue adj val in do adjApplyValue "Title Font Size" $ plotTitleSize fset adjApplyValue "Subtitle Font Size" $ subTitleSize fset adjApplyValue "Sampling Adj" $ fromIntegral $ samplingRate fset adjApplyValue "X-Label Size" $ xLabelSize fset adjApplyValue "Y-Label Size" $ yLabelSize fset let checkApplyState checkGlade state = do check <- builderGetObject builder castToCheckButton checkGlade toggleButtonSetActive check $ if state then True else False in do checkApplyState "X-Axis Check" $ showXAxis fset checkApplyState "Y-Axis Check" $ showYAxis fset checkApplyState "Y-Range Check" $ yRange fset == Nothing -- Y-Axis Range and CheckButton let range = yRange fset in if range == Nothing then do entries <- builderGetObject builder castToHBox "Y-Range Entries" widgetHideAll entries else let (l, u) = fromJust range in do lower <- builderGetObject builder castToAdjustment "Y-Lower" upper <- builderGetObject builder castToAdjustment "Y-Upper" adjustmentSetValue lower l adjustmentSetValue upper u -- X-Axis Range let range = xRange fset in if range == Nothing then error "Invalid xRange" else let (l, u) = fromJust range in do lower <- builderGetObject builder castToAdjustment "X-Lower" upper <- builderGetObject builder castToAdjustment "X-Upper" adjustmentSetValue lower l adjustmentSetValue upper u -- Export Size let (w, h) = exportSize fset in do width <- builderGetObject builder castToAdjustment "Export Width" height <- builderGetObject builder castToAdjustment "Export Height" adjustmentSetValue width $ fromIntegral w adjustmentSetValue height $ fromIntegral h -- Export ComboBox combo <- comboBoxNewText mapM (\(x, y) -> comboBoxInsertText combo x $ pack y) [(1, "PNG"), (2, "SVG"), (3, "PS"), (4, "PDF")] comboBoxSetActive combo 0 comboArea <- builderGetObject builder castToHBox "File Name" boxPackEndDefaults comboArea combo -- Attach Event Handlers attachHandlers builder iofset adjs updateCanvas g buildFigure combo -- Show Widgets plotWindow <- builderGetObject builder castToWindow "Plot Window" widgetShowAll plotWindow -- Hide the useless checkButton for now check <- builderGetObject builder castToCheckButton "X-Range Check" widgetHide check -------------------------------------------------------------------------------- giveSettings :: FigureSettings -> IO (IORef FigureSettings) giveSettings fst = do ref <- newIORef fst modifyIORef ref $ \f -> f { plotTitle = Just "Example: Sum of two gaussian distributions" , subTitle = Just "Play with the sliders, and other options" , xRange = Just (-5, 5) , yRange = Just ( 0, 2) , plotTitleSize = 12.5 } return ref -------------------------------------------------------------------------------- mu1 = (-5.00, -5.00, 5.00, 0.01, 0.01, 0.00) sigma1 = ( 1.00, 0.01, 6.00, 0.01, 0.01, 0.00) mu2 = ( 0.00, -5.00, 5.00, 0.01, 0.01, 0.00) sigma2 = ( 1.00, 0.01, 6.00, 0.01, 0.01, 0.00) -------------------------------------------------------------------------------- -- Gaussian Distribution h :: [Double] -> Double -> Double h [s, m] x = exp (-((x - m) ** 2) / (2 * (s ** 2))) / (s * sqrt (2 * pi)) g :: [Double] -> Double -> Double g [a, b, c, d] x = h [a, b] x + h [c, d] x -------------------------------------------------------------------------------- main mainGlade plotGlade = do initGUI builder <- builderNew builderAddFromFile builder mainGlade mainWindow <- builderGetObject builder castToWindow "Main Window" plotButton <- builderGetObject builder castToButton "Plot Button" onDestroy mainWindow mainQuit widgetShowAll mainWindow settings <- giveSettings defaultSettings onClicked plotButton $ figureWindow plotGlade settings [sigma2, mu2, sigma1, mu1] g mainGUI -------------------------------------------------------------------------------- -- xs = linspace ln (-2.5, 2.5) :: Vector Double -- ys = ln |> [exp (-x ** 2) | x <- [(-2.5),(-2.475)..2.5] :: [Double]] -- figure = buildFigure (domain, [point (ys, xs) (Cross, red), -- line f1 red, line f2 green, -- line f3 blue, line f4 black]) default_fset -- export = writeFigure SVG "plot.svg" (1000,1000) $ buildFigure dset fset -------------------------------------------------------------------------------- -- applyParameters :: (Function a) => a -> [Double] -> (Double -> Double) --------------------------------------------------------------------------------