plot-lab-0.0.1.9: src/PlotLab/Main.hs
module PlotLab.Main (main) where
import PlotLab.Events (attachHandlers)
import PlotLab.FigureSettings
import Control.Monad (when)
import Data.Colour.Names
import Data.IORef (IORef, modifyIORef, newIORef,
readIORef)
import Data.Maybe (fromJust)
import Data.Text (pack)
import Graphics.Rendering.Plot
import Graphics.UI.Gtk hiding (Circle, Color, Cross, Scale)
import Numeric.LinearAlgebra (linspace)
-- 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 :: AxisType -> Bool -> (AxisPosn, AxisSide) -> Maybe (Double, Double)
-> Scale -> Maybe String -> FontSize -> Plot ()
updateAxis axis state location range scale label size = do
let (position, side) = location
when state $ 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 str = plotTitle fset
size = plotTitleSize fset
in updateFigureText withTitle str size
let str = subTitle fset
size = subTitleSize fset
in updateFigureText withSubTitle str size
setPlots 1 1
withPlot (1, 1) $ do
setDataset dset
-- X-Axis
let state = showXAxis fset
label = xLabel fset
size = xLabelSize fset
loc = xLocation fset
range = xRange fset
scale = plotScaleX fset
in updateAxis XAxis state loc range scale label size
-- Y-Axis
let state = showYAxis fset
label = yLabel fset
size = yLabelSize fset
loc = yLocation fset
range = yRange fset
scale = plotScaleY fset
in updateAxis YAxis state loc range scale label 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 = mapM newAdj
newHScaleList = mapM hScaleNew
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 * ceiling (y - x)) (fromJust $ xRange fset)
domain = linspace samples (fromJust $ xRange fset)
f = g vars
colour = blue :: Color
dset = (domain, [line f colour])
r = render $ buildFigure dset fset
box <- regionRectangle $ Rectangle 0 0 w h
drawWindowBeginPaintRegion drw box
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 fun = do
builder <- builderNew
builderAddFromFile builder plotGlade
plotBox <- builderGetObject builder castToVBox "Plot Region"
adjs <- addSlidersToBox conf plotBox
fset <- readIORef iofset
let updateEntryText entryGlade txt =
when (txt /= Nothing) $ do entry <- builderGetObject builder
castToEntry entryGlade
entrySetText entry $ fromJust txt
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 fun 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 fset = do
ref <- newIORef fset
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
--------------------------------------------------------------------------------
-- Gaussian Distribution
func :: [Double] -> Double -> Double
func [s, m] x = exp (-((x - m) ** 2) / (2 * (s ** 2))) / (s * sqrt (2 * pi))
func _ _ = error "Invalid arguments"
g :: [Double] -> Double -> Double
g [a, b, c, d] x = func [a, b] x + func [c, d] x
g _ _ = error "Invalid arguments"
--------------------------------------------------------------------------------
main :: FilePath -> String -> IO ()
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 $
let 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)
in 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)
--------------------------------------------------------------------------------