plot-lab-0.0.1.7: src/PlotLab/Main.hs
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)
--------------------------------------------------------------------------------