AERN-RnToRm-Plot-0.2: src/Data/Number/ER/RnToRm/Plot/FnView.hs
{-# LANGUAGE CPP #-}
#ifdef GLADE_DIR
#else
#define GLADE_DIR "./"
#endif
{-|
Module : Data.Number.ER.RnToRm.Plot.FnView
Description : plot function enclosures on GL canvas
Copyright : (c) 2007-2008 Michal Konecny
License : BSD3
Maintainer : mik@konecny.aow.cz
Stability : experimental
Portability : portable
This module provides a generic plotter for a set of function approximations.
The functions must be unary at present (R->R^n).
To be imported qualified, usually with the synonym FNV.
-}
module Data.Number.ER.RnToRm.Plot.FnView
(
FaData (..),
FnData (..),
defaultFaData,
defaultFnData,
new,
module Data.Number.ER.RnToRm.Plot.Params
)
where
--import IVPs
import Data.Number.ER.RnToRm.Plot.Params
import qualified Data.Number.ER.Real.Approx as RA
import qualified Data.Number.ER.RnToRm.Approx as FA
import qualified Data.Number.ER.BasicTypes.DomainBox as DBox
import Data.Number.ER.RnToRm.Plot.GLDrawable
import Data.Number.ER.BasicTypes
import Data.Number.ER.Misc
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.Gdk.EventM as GdkEv
import Graphics.UI.Gtk (AttrOp((:=)))
import qualified Graphics.UI.Gtk.Glade as Glade
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
import qualified System.Glib.Signals as Signals
--import qualified Graphics.UI.GLUT as GLUT
--import qualified Graphics.Rendering.FTGL as FTGL
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (HasSetter(($=)))
import Control.Concurrent as Concurrent
import Control.Concurrent.STM as STM
import Data.Number.ER.Misc.STM
import Data.IORef
import Data.Maybe
import qualified System.FilePath as FilePath
import System.Directory
import Control.Monad.Reader.Class
import Control.Monad.Trans
import Foreign.Storable
{-|
Two transactional variables with values of the following two types
will be used by the client(s) to communicate to the viewer what it
should be showing.
-}
data FaData fa =
FaData
{
dataFAs :: [fa] -- ^ functions to plot
}
data FnData =
FnData
{
dataDestroyed :: Bool, -- ^ command to destroy OR signal that user destroyed
dataFAsUpdated :: Bool, -- ^ avoid checking fas for equality
dataDomName :: String, -- ^ name of the domain variable (eg "t")
dataDomL :: Double, -- ^ left endpoint of the domain
dataDomR :: Double, -- ^ right endpoint of the domain
dataValLO :: Double, -- ^ lower bounds for values of all functions
dataValHI :: Double, -- ^ upper bounds for values of all functions
dataFnNames :: [String],
dataResultNames :: [[String]], -- ^ for each function list of result variable names
dataDefaultEvalPoint :: Double, -- ^ show the values of the functions at this point
dataDefaultEvalPointName :: String, -- ^ label to put on the button
dataDefaultPlotParams :: PlotParams
}
deriving (Eq, Show)
defaultFaData =
FaData
{
dataFAs = []
}
defaultFnData =
FnData
{
dataDestroyed = False,
dataFAsUpdated = False,
dataDomName = "t",
dataDomL = 0,
dataDomR = 1,
dataValLO = 0,
dataValHI = 1,
dataFnNames = [],
dataResultNames = [],
dataDefaultEvalPoint = 0,
dataDefaultEvalPointName = "default",
dataDefaultPlotParams = defaultPlotParams
}
getFnExtents fndata =
(dataValHI fndata, dataValLO fndata,
dataDomL fndata, dataDomR fndata)
readBothTVars ::
(TVar a, TVar a1) ->
STM (a, a1)
readBothTVars (fadataTV, fndataTV) =
do
fadata <- readTVar fadataTV
fndata <- readTVar fndataTV
return (fadata, fndata)
readAll3TVars ::
(TVar a1, TVar a2) ->
TVar a ->
STM ((a1, a2), a)
readAll3TVars fndataTVs stateTV =
do
state <- readTVar stateTV
fndatas <- readBothTVars fndataTVs
return (fndatas, state)
{-|
Create a new viewer linked to the given data variable.
-}
new ::
(FA.ERFnApprox box varid domra ranra fa, ERFnGLDrawable box varid domra ranra fa) =>
(TVar (FaData fa),
TVar (FnData)) ->
(Maybe Gtk.Window) {- ^ parent window -} ->
IO Gtk.Window
new fndataTVs@(fadataTV, fndataTV) maybeParentWindow =
do
-- create initial state objects:
stateTV <- atomically $
do
fadata <- readTVar fadataTV
fndata <- readTVar fndataTV
STM.newTVar $ initState (fadata, fndata)
dynWidgetsRef <- newIORef initERFnViewDynWidgets
-- create most widgets:
widgets <- loadGlade (FilePath.combine GLADE_DIR "FnView.glade")
-- create plotting canvas:
widgets <- makeCanvas widgets fndataTVs stateTV
-- attach handlers to widgets
Gtk.onDestroy (window widgets) $
do
atomically $ modifyTVar fndataTV $ \fndata -> fndata { dataDestroyed = True }
Gtk.mainQuit
setHandlers widgets dynWidgetsRef fndataTVs stateTV
-- start thread that reponds to changes in fndataTVs:
forkIO $ dataWatchThread widgets dynWidgetsRef fndataTVs stateTV
Gtk.widgetShowAll $ window widgets
return $ window widgets
loadGlade ::
FilePath ->
IO Widgets
loadGlade gladeFileName =
do
gotGladeFile <- doesFileExist gladeFileName
case gotGladeFile of
True -> return ()
False -> error $ "RnToRm.Plot.FnView: glade file " ++ gladeFileName ++ " not found"
Just xml <- Glade.xmlNew gladeFileName
window <- Glade.xmlGetWidget xml Gtk.castToWindow "window1"
canvasAlignment <- Glade.xmlGetWidget xml Gtk.castToAlignment "canvasAlignment1"
coorSystemCombo <- Glade.xmlGetWidget xml Gtk.castToComboBox "coorSystemCombo1"
evalPointEntry <- Glade.xmlGetWidget xml Gtk.castToEntry "evalPointEntry1"
defaultEvalPointButton <- Glade.xmlGetWidget xml Gtk.castToButton "defaultEvalPointButton1"
dimTable <- Glade.xmlGetWidget xml Gtk.castToTable "dimTable1"
domVarLabel <- Glade.xmlGetWidget xml Gtk.castToLabel "domVarLabel1"
zoomEntry <- Glade.xmlGetWidget xml Gtk.castToEntry "zoomEntry1"
defaultZoomPanButton <- Glade.xmlGetWidget xml Gtk.castToButton "defaultZoomPanButton1"
centreXEntry <- Glade.xmlGetWidget xml Gtk.castToEntry "centreXEntry1"
centreYEntry <- Glade.xmlGetWidget xml Gtk.castToEntry "centreYEntry1"
exportJPGButton <- Glade.xmlGetWidget xml Gtk.castToButton "exportJPGButton1"
printTXTButton <- Glade.xmlGetWidget xml Gtk.castToButton "printTXTButton1"
return $ Widgets
{
window = window,
canvasAlignment = canvasAlignment,
coorSystemCombo = coorSystemCombo,
evalPointEntry = evalPointEntry,
defaultEvalPointButton = defaultEvalPointButton,
dimTable = dimTable,
domVarLabel = domVarLabel,
zoomEntry = zoomEntry,
defaultZoomPanButton = defaultZoomPanButton,
centreXEntry = centreXEntry,
centreYEntry = centreYEntry,
exportJPGButton = exportJPGButton,
printTXTButton = printTXTButton,
canvas = error "canvas not created yet"
}
data Widgets =
Widgets
{
window :: Gtk.Window,
canvasAlignment :: Gtk.Alignment,
coorSystemCombo :: Gtk.ComboBox,
evalPointEntry :: Gtk.Entry,
defaultEvalPointButton :: Gtk.Button,
dimTable :: Gtk.Table,
domVarLabel :: Gtk.Label,
zoomEntry :: Gtk.Entry,
defaultZoomPanButton :: Gtk.Button,
centreXEntry :: Gtk.Entry,
centreYEntry :: Gtk.Entry,
exportJPGButton :: Gtk.Button,
printTXTButton :: Gtk.Button,
canvas :: GtkGL.GLDrawingArea
}
data ERFnViewDynWidgets =
ERFnViewDynWidgets
{
valueLabels :: [[Gtk.Label]]
}
initERFnViewDynWidgets :: ERFnViewDynWidgets
initERFnViewDynWidgets =
ERFnViewDynWidgets []
data ERFnViewState =
ERFnViewState
{
favstActiveDims :: [[Bool]],
favstTrackingDefaultEvalPt :: Bool,
favstPlotParams :: PlotParams,
favstZoomPercent :: Double,
favstPanCentre :: (Double, Double)
}
initState ::
(t, FnData) ->
ERFnViewState
initState (fadata, fndata) =
ERFnViewState
{
favstActiveDims = map (map $ const True) $ dataResultNames fndata,
favstTrackingDefaultEvalPt = True,
favstPlotParams = dataDefaultPlotParams fndata,
favstZoomPercent = defaultZoom,
favstPanCentre = getDefaultCentre fndata
}
defaultZoom :: Double
defaultZoom = 110
getDefaultCentre fndata =
(cX,cY)
where
cX = (fnL + fnR)/2
cY = (fnLO + fnHI)/2
(fnLO, fnHI, fnL, fnR) = getFnExtents fndata
updateZoomPanCentreCoordSystem zoomPercent panCentre coordSystem state =
state
{
favstPlotParams =
(favstPlotParams state)
{ pltprmCoordSystem = coordSystem },
favstZoomPercent = zoomPercent,
favstPanCentre = panCentre
}
updatePanCentreCoordSystem = updateZoomPanCentreCoordSystem defaultZoom
updateZoomPercentAndFnExtents zoomPercent fnExtents state =
state
{
favstPlotParams =
(favstPlotParams state)
{ pltprmCoordSystem = newCoordSystem },
favstZoomPercent = zoomPercent
}
where
newCoordSystem =
case pltprmCoordSystem (favstPlotParams state) of
CoordSystemLogSqueeze ->
CoordSystemLogSqueeze
CoordSystemLinear _ ->
linearCoordsWithZoomAndCentre zoomPercent centre fnExtents
centre = favstPanCentre state
updateCentreByRatio (ratX, ratY) state =
case pltprmCoordSystem (favstPlotParams state) of
CoordSystemLogSqueeze -> state
CoordSystemLinear (Rectangle hi lo l r) ->
state
{
favstPlotParams =
(favstPlotParams state)
{ pltprmCoordSystem = coordSystem },
favstPanCentre = (cX - shiftX, cY - shiftY)
}
where
(cX,cY) = favstPanCentre state
shiftX = ratX * fnDomWidth
shiftY = ratY * fnRangeHeight
fnDomWidth = fromRational $ r - l
fnRangeHeight = fromRational $ lo - hi
coordSystem =
CoordSystemLinear
(Rectangle
(hi - shiftYrat) (lo - shiftYrat)
(l - shiftXrat) (r - shiftXrat))
shiftXrat = toRational shiftX
shiftYrat = toRational shiftY
updateDimActive ::
TVar ERFnViewState ->
Int ->
Int ->
Bool ->
STM ERFnViewState
updateDimActive stateTV fnNo dimNo isActive =
do
modifyTVar stateTV update
readTVar stateTV
where
update state =
state
{
favstActiveDims = updateDim $ favstActiveDims state
}
updateDim activeDims =
listUpdate fnNo activeFnDims activeDims
where
activeFnDims =
listUpdate dimNo isActive (activeDims !! fnNo)
updateZoomWidgets widgets state =
case coordSystem of
CoordSystemLogSqueeze ->
do
Gtk.comboBoxSetActive (coorSystemCombo widgets) 0
Gtk.editableSetEditable (zoomEntry widgets) False
Gtk.editableSetEditable (centreXEntry widgets) False
Gtk.editableSetEditable (centreYEntry widgets) False
Gtk.entrySetText (zoomEntry widgets) ""
Gtk.entrySetText (centreXEntry widgets) ""
Gtk.entrySetText (centreYEntry widgets) ""
(CoordSystemLinear (Rectangle hi lo l r)) ->
do
Gtk.comboBoxSetActive (coorSystemCombo widgets) 1
Gtk.editableSetEditable (zoomEntry widgets) True
Gtk.editableSetEditable (centreXEntry widgets) True
Gtk.editableSetEditable (centreYEntry widgets) True
Gtk.entrySetText (zoomEntry widgets) $ show $ zoomPercent
Gtk.entrySetText (centreXEntry widgets) $ show $ cX
Gtk.entrySetText (centreYEntry widgets) $ show $ cY
where
zoomPercent = favstZoomPercent state
(cX,cY) = favstPanCentre state
coordSystem = pltprmCoordSystem $ favstPlotParams state
setHandlers ::
(FA.ERFnApprox box varid domra ranra fa,
ERFnGLDrawable box varid domra ranra fa) =>
Widgets ->
IORef ERFnViewDynWidgets ->
(TVar (FaData fa), TVar FnData) ->
TVar ERFnViewState ->
IO ()
setHandlers widgets dynWidgetsRef fndataTVs@(fadataTV, fndataTV) stateTV =
do
setHandlerPrintTXTButton
setHandlerDefaultEvalPointButton
setHandlerEvalPointEntry
setHandlerCoordSystem
setHandlerZoomAndPanEntries
setHandlerPanByMouse
setHandlerZoomByMouse
state <- atomically $ readTVar stateTV
updateZoomWidgets widgets state
-- putStrLn $ "setHandlers: " ++ (show $ pltprmCoordSystem $ favstPlotParams state)
return ()
where
setHandlerCoordSystem =
do
Gtk.on (coorSystemCombo widgets) Gtk.changed resetZoomPanFromCoordSystem
Gtk.onClicked (defaultZoomPanButton widgets) resetZoomPanFromCoordSystem
where
resetZoomPanFromCoordSystem =
do
maybeCSysIx <- Gtk.comboBoxGetActive (coorSystemCombo widgets)
case maybeCSysIx of
#ifdef GTK2HS_0_9_13
Nothing -> return ()
Just ix ->
#else
-1 -> return ()
ix ->
#endif
do
state <-
atomically $
do
fndata <- readTVar fndataTV
let coordSystem = case ix of
0 -> CoordSystemLogSqueeze
1 ->
linearCoordsWithZoom defaultZoom (getFnExtents fndata)
state <- modifyTVar stateTV $
updatePanCentreCoordSystem (getDefaultCentre fndata) coordSystem
return state
Gtk.widgetQueueDraw (canvas widgets)
updateZoomWidgets widgets state
setHandlerZoomAndPanEntries =
do
Gtk.onEntryActivate (zoomEntry widgets) (zoomHandler ())
Gtk.onFocusOut (zoomEntry widgets) (\ e -> zoomHandler False)
Gtk.onEntryActivate (centreXEntry widgets) (zoomHandler ())
Gtk.onFocusOut (centreXEntry widgets) (\ e -> zoomHandler False)
Gtk.onEntryActivate (centreYEntry widgets) (zoomHandler ())
Gtk.onFocusOut (centreYEntry widgets) (\ e -> zoomHandler False)
where
zoomHandler returnValue =
do
zoomS <- Gtk.entryGetText (zoomEntry widgets)
centreXS <- Gtk.entryGetText (centreXEntry widgets)
centreYS <- Gtk.entryGetText (centreYEntry widgets)
case (reads zoomS, reads centreXS, reads centreYS) of
([(zoomPercent,"")], [(centreX,"")], [(centreY,"")]) ->
atomically $
do
fndata <- readTVar fndataTV
modifyTVar stateTV $
updateZoomPanCentreCoordSystem zoomPercent (centreX, centreY) $
linearCoordsWithZoomAndCentre zoomPercent (centreX, centreY) $
getFnExtents fndata
return ()
_ -> return ()
-- putStrLn $ "zoomHandler"
Gtk.widgetQueueDraw (canvas widgets)
return returnValue
setHandlerPanByMouse =
do
-- a variable to keep track of position before each drag movement:
panOriginTV <- atomically $ newTVar Nothing
-- setup the canvas to receive various mouse events:
Gtk.widgetAddEvents (canvas widgets)
[Gtk.ButtonPressMask, Gtk.ButtonReleaseMask, Gtk.PointerMotionMask]
-- what to do when the left mouse button is pressed:
Gtk.on (canvas widgets) Gtk.buttonPressEvent $
do
button <- GdkEv.eventButton
coords <- GdkEv.eventCoordinates
case button of
GdkEv.LeftButton ->
liftIO $
do
-- remember the position and indicate that dragging is underway:
atomically $ writeTVar panOriginTV (Just coords)
return ()
_ -> return ()
return False
-- what to do when the left mouse button is released:
Gtk.on (canvas widgets) Gtk.buttonReleaseEvent $
do
button <- GdkEv.eventButton
case button of
GdkEv.LeftButton ->
liftIO $
do
-- indicate no dragging is underway:
atomically $ writeTVar panOriginTV Nothing
return ()
_ -> return ()
return False
-- what to do when mouse moves:
Gtk.on (canvas widgets) Gtk.motionNotifyEvent $
do
coords@(x,y) <- GdkEv.eventCoordinates
liftIO $
do
-- update the dragging information variable:
maybePanOrigin <- atomically $
do
maybePanOrigin <- readTVar panOriginTV
case maybePanOrigin of
Nothing ->
return maybePanOrigin
Just _ ->
do
writeTVar panOriginTV (Just coords)
return maybePanOrigin
-- check whether dragging or not:
case maybePanOrigin of
Nothing -> return ()
Just panOrigin@(oX,oY) -> -- yes, dragging occurred
do
-- find out the size of the canvas:
(canvasX, canvasY) <- Gtk.widgetGetSize (canvas widgets)
-- recalculate the centre and coordinate bounds
-- based on the drag amount relative to the size fo the canvas:
state <- atomically $ modifyTVar stateTV $
updateCentreByRatio
((x - oX) / (int2dbl canvasX),
(y - oY) / (int2dbl canvasY))
-- make sure the text in the zoom and pan entries are updated:
updateZoomWidgets widgets state
-- schedule the canvas for redraw:
Gtk.widgetQueueDraw (canvas widgets)
where
int2dbl :: Int -> Double
int2dbl = fromInteger . toInteger
return False
return ()
setHandlerZoomByMouse =
do -- IO
Gtk.widgetAddEvents (canvas widgets) [Gtk.ScrollMask]
Gtk.on (canvas widgets) Gtk.scrollEvent $
do -- ReaderTV
scrollDirection <- GdkEv.eventScrollDirection
liftIO $
do -- IO
state <- atomically $
do -- STM
state <- readTVar stateTV
let zoomPercent = favstZoomPercent state
let newZoomPercent = case scrollDirection of
GdkEv.ScrollUp -> 1.25 * zoomPercent
GdkEv.ScrollDown -> 0.8 * zoomPercent
_ -> zoomPercent
fndata <- readTVar fndataTV
state <- modifyTVar stateTV $
updateZoomPercentAndFnExtents newZoomPercent $ getFnExtents fndata
return state
updateZoomWidgets widgets state
Gtk.widgetQueueDraw (canvas widgets)
return False
return () -- TODO
setHandlerPrintTXTButton =
Gtk.onClicked (printTXTButton widgets) $
do
(state, FaData fas) <-
atomically $
do
state <- readTVar stateTV
fas <- readTVar fadataTV
return (state, fas)
putStrLn $
-- (show $ head fas)
-- ++ "\n---------------\n" ++
-- (show $ combustionField 7 $ head fas)
unlines $ map show $ fas
setHandlerDefaultEvalPointButton =
Gtk.onClicked (defaultEvalPointButton widgets) $
do
(state, fndata) <-
atomically $
do
state <- readTVar stateTV
fndata <- readTVar fndataTV
return (state, fndata)
case favstTrackingDefaultEvalPt state of
False ->
do
Gtk.entrySetText (evalPointEntry widgets) $
show $ dataDefaultEvalPoint fndata
atomically $ modifyTVar stateTV $
\ st -> st { favstTrackingDefaultEvalPt = True }
updateValueDisplayTV widgets dynWidgetsRef fndataTVs stateTV
True -> -- already tracking the default
return ()
setHandlerEvalPointEntry =
do
Gtk.onEntryActivate (evalPointEntry widgets) $
do
updateEvalPointHandler
Gtk.onFocusOut (evalPointEntry widgets) $ \ _ ->
do
updateEvalPointHandler
return False
where
updateEvalPointHandler =
do
-- indicate that we no longer wish to track the default point:
atomically $ modifyTVar stateTV $
\ st -> st { favstTrackingDefaultEvalPt = False }
-- update the values for the new point:
updateValueDisplayTV widgets dynWidgetsRef fndataTVs stateTV
linearCoordsWithZoom ::
Double {-^ zoom level in percent -} ->
(Double, Double, Double, Double)
{-^ upper, lower, left, right bounds of the function graph -} ->
CoordSystem
linearCoordsWithZoom zoomPercent fnExtents@(fnHI, fnLO, fnL, fnR) =
linearCoordsWithZoomAndCentre zoomPercent (cX,cY) fnExtents
where
cX = (fnL + fnR)/2
cY = (fnLO + fnHI)/2
linearCoordsWithZoomAndCentre ::
Double {-^ zoom level in percent -} ->
(Double, Double) {-^ x,y coordinates of the centre -} ->
(Double, Double, Double, Double)
{-^ upper, lower, left, right bounds of the function graph -} ->
CoordSystem
linearCoordsWithZoomAndCentre zoomPercent (cX,cY) (fnHI, fnLO, fnL, fnR) =
CoordSystemLinear $ Rectangle
((toRational hi))
((toRational lo))
((toRational l))
((toRational r))
where
hi = cY + heighHalf
lo = cY - heighHalf
l = cX - widthHalf
r = cX + widthHalf
heighHalf = zoomRatio * fnHeightHalf
widthHalf = zoomRatio * fnWidthHalf
zoomRatio = 100 / zoomPercent
fnWidthHalf = (fnR - fnL) / 2
fnHeightHalf = (fnHI - fnLO) / 2
{-|
Reconfigure the GUI to show variable names appropriate
for the given fndata.
-}
updateDimWidgets ::
(FA.ERFnApprox box varid domra ranra fa, ERFnGLDrawable box varid domra ranra fa) =>
Widgets ->
IORef ERFnViewDynWidgets ->
FnData ->
(TVar (FaData fa),
TVar FnData) ->
(TVar ERFnViewState) ->
IO ()
updateDimWidgets widgets dynWidgetsRef fndata fndataTVs stateTV =
do
-- update the name of the domain variable:
Gtk.labelSetText (domVarLabel widgets) $ domName ++ "="
-- set the default evaluation point:
Gtk.entrySetText (evalPointEntry widgets) $ show $ dataDefaultEvalPoint fndata
-- remove any old dim rows from dimTable:
children <- Gtk.containerGetChildren table
mapM (Gtk.containerRemove table) children
-- add new dim rows:
Gtk.tableResize table (dimRowCount + 1) 3
-- fill each row with widgets and return all newly created value entries:
valueLabels <- addFunctionLabels 0 $ zip3 [0..] fnNames dimNames
-- layout the table:
Gtk.widgetShowAll table
Gtk.containerResizeChildren table
-- remember valueEntries for later use:
modifyIORef dynWidgetsRef $ \ dynWidgets ->
dynWidgets
{
valueLabels = valueLabels
}
where
table = dimTable widgets
domName = dataDomName fndata
fnNames = dataFnNames fndata
dimNames = dataResultNames fndata
dimRowCount = (length fnNames) + (sum $ map length dimNames)
addFunctionLabels nextRowNo [] = return []
addFunctionLabels nextRowNo ((fnNo, fnName, dimNames):rest) =
do
-- add a function label:
fnLabel <- Gtk.labelNew (Just fnName)
Gtk.tableAttachDefaults table fnLabel 1 2 nextRowNo (nextRowNo + 1)
Gtk.set table [ Gtk.tableChildXOptions fnLabel := []]
Gtk.miscSetAlignment fnLabel 0 0.5
-- add all result labels:
labels <- addDimLabels (nextRowNo + 1) (fnNo, fnName) dimNames
-- recurse for the following functions:
restLabels <- addFunctionLabels (nextRowNo + 1 + (length dimNames)) rest
return $ labels : restLabels
addDimLabels nextRowNo (fnNo, fnName) dimNames =
do
mapM addDimLabel $ zip3 [nextRowNo..] [0..] dimNames
where
addDimLabel (nextRowNo, dimNo, dimName) =
do
-- add variable label:
dimLabel <- Gtk.labelNew (Just labelText)
Gtk.tableAttachDefaults table dimLabel 1 2 nextRowNo nextRowNoPlus1
Gtk.miscSetAlignment dimLabel 0 0.5
-- add value label:
valLabel <- Gtk.labelNew Nothing
Gtk.tableAttachDefaults table valLabel 2 3 nextRowNo nextRowNoPlus1
-- add a check button:
showCheckButton <- Gtk.checkButtonNew
Gtk.tableAttachDefaults table showCheckButton 0 1 nextRowNo nextRowNoPlus1
-- make it ticked:
Gtk.toggleButtonSetActive showCheckButton True
-- give the check button a handler:
Gtk.onToggled showCheckButton $
do
isActive <- Gtk.toggleButtonGetActive showCheckButton
state <- atomically $ updateDimActive stateTV fnNo dimNo isActive
fndatas <- atomically $ readBothTVars fndataTVs
Gtk.widgetQueueDraw (canvas widgets)
return ()
return dimLabel
where
labelText = " [" ++ show dimNo ++ "]" ++ dimName ++ "(" ++ domName ++ ")="
nextRowNoPlus1 = nextRowNo + 1
updateView ::
(FA.ERFnApprox box varid domra ranra fa, ERFnGLDrawable box varid domra ranra fa) =>
Widgets ->
IORef ERFnViewDynWidgets ->
(ERFnViewState) ->
((FaData fa),
FnData) ->
IO ()
updateView widgets dynWidgetsRef state (fadata, fndata) =
do
updateValueDisplay widgets dynWidgetsRef state (fadata, fndata)
updateZoomWidgets widgets state
Gtk.widgetQueueDraw (canvas widgets)
return ()
{-|
update the values shown against dimension names
-}
updateValueDisplay ::
(FA.ERFnApprox box varid domra ranra fa) =>
Widgets ->
IORef ERFnViewDynWidgets ->
(ERFnViewState) ->
((FaData fa),
FnData) ->
IO ()
updateValueDisplay widgets dynWidgetsRef state (fadata, fndata) =
do
evalPointText <- Gtk.entryGetText $ evalPointEntry widgets
let maybeFnValueTexts = getFnValueTexts evalPointText
case maybeFnValueTexts of
Nothing -> do return () -- putStrLn $ "failed to parse eval point: " ++ evalPointText
Just fnValueTexts ->
do
dynWidgets <- readIORef dynWidgetsRef
mapM (mapM $ uncurry Gtk.labelSetText) $
zipWith zip (valueLabels dynWidgets) fnValueTexts
return ()
where
getFnValueTexts evalPointText =
fmap (eval . RA.double2ra) $ readMaybe evalPointText
where
-- eval :: (ERIntApprox ira) => ra -> [[String]]
eval evalPoint =
map (map show . getDimValueTexts) $ dataFAs fadata
where
-- getDimValueTexts :: (FA.ERFnApprox box varid domra ranra fa) => fa -> [ra]
getDimValueTexts fa =
FA.eval (DBox.unary evalPoint) fa
updateValueDisplayTV widgets dynWidgetsRef fndataTVs stateTV =
do
-- putStrLn "updateValueDisplayTVERFA"
(fndatas, state) <- atomically $ readAll3TVars fndataTVs stateTV
updateValueDisplay widgets dynWidgetsRef state fndatas
dataWatchThread ::
(FA.ERFnApprox box varid domra ranra fa, ERFnGLDrawable box varid domra ranra fa) =>
Widgets ->
IORef ERFnViewDynWidgets ->
(TVar (FaData fa),
TVar FnData) ->
(TVar ERFnViewState) ->
IO ()
dataWatchThread widgets dynWidgetsRef fndataTVs@(fadataTV, fndataTV) stateTV =
do
fndata <- atomically $ readTVar fndataTV
dataWatchLoop fndata
where
dataWatchLoop fndataOld =
do
((dataChange, fndatas@(_, fndata)), state) <- waitForChange fndataOld
Gtk.timeoutAdd (do { action dataChange fndatas state; return False }) 10
Concurrent.yield
case dataChange of
DataChangeClose -> return ()
_ -> dataWatchLoop fndata
action DataChangeClose (fadata, fndata) state =
do
return ()
action DataChangeMeta (fadata, fndata) state =
do
-- putStrLn $ "DataChangeMeta"
-- putStrLn $ show $ dataFAs fadata
updateDimWidgets widgets dynWidgetsRef fndata fndataTVs stateTV
let initialisedState = initState (fadata, fndata)
atomically $ writeTVar stateTV initialisedState
updateView widgets dynWidgetsRef initialisedState (fadata, fndata)
action DataChangeFA (fadata, fndata) state =
do
-- putStrLn $ "DataChangeFA"
-- putStrLn $ show $ dataFAs fadata
case favstTrackingDefaultEvalPt state of
True ->
Gtk.entrySetText (evalPointEntry widgets) $
show $ (dataDefaultEvalPoint fndata)
False ->
return ()
updateView widgets dynWidgetsRef state (fadata, fndata)
action DataChangeDefaultEvalPoint (fadata, fndata) state =
do
-- putStrLn $ "DataChangeDefaultEvalPoint"
case favstTrackingDefaultEvalPt state of
True ->
do
Gtk.entrySetText (evalPointEntry widgets) $
show $ (dataDefaultEvalPoint fndata)
updateView widgets dynWidgetsRef state (fadata, fndata)
False -> return ()
waitForChange fndataOld =
do
waitFC fndataOld
where
waitFC fndataOld =
atomically $
do
fndata <- readTVar fndataTV
(change, fndatas) <-
case fndata == fndataOld of
True -> retry
False ->
case dataFAsUpdated fndata of
True ->
do
fadata <- readTVar fadataTV
let change = returnChange fndataOld fndata fadata
let fndataNew = fndata { dataFAsUpdated = False }
writeTVar fndataTV fndataNew
return (change, (fadata, fndataNew))
False ->
do
let change = returnChange fndataOld fndata undefined
return (change, (undefined, fndata))
state <- readTVar stateTV
return ((change, fndatas), state)
returnChange fndataOld fndata fadata
| dataDestroyed fndata =
DataChangeClose
| namesChanged =
DataChangeMeta
| dataFAsUpdated fndata =
DataChangeFA
| evalPtChanged =
DataChangeDefaultEvalPoint
| otherwise =
error $
"ERFnView: returnChange: cannot detect type of change:\n"
++ show fndata ++ "\n" ++ show fndataOld
where
changed field =
field fndata /= field fndataOld
namesChanged =
domNameChanged || resNamesChanged || fnNamesChanged
domNameChanged = changed dataDomName
resNamesChanged = changed dataResultNames
fnNamesChanged = changed dataFnNames
evalPtChanged = changed dataDefaultEvalPoint
data DataChange
= DataChangeClose -- signals the end...
| DataChangeMeta -- all change
| DataChangeFA -- only fn & eval point may have changed
| DataChangeDefaultEvalPoint -- only eval point has changes
makeCanvas widgets fndataTVs@(fadataTV, fndataTV) stateTV =
do
-- create canvas:
glconfig <-
GtkGL.glConfigNew
[GtkGL.GLModeRGBA,
GtkGL.GLModeDepth,
GtkGL.GLModeDouble]
canvas <- GtkGL.glDrawingAreaNew glconfig
-- set canvas properties:
Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \ _ ->
do
GL.clearColor $= (GL.Color4 0.05 0.0 0.2 0.0)
GL.matrixMode $= GL.Projection
GL.ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
GL.depthFunc $= Just GL.Less
GL.drawBuffer $= GL.BackBuffers
-- open font for labels:
-- font <- FTGL.createOutlineFont "VeraMono.ttf"
let font = () -- a dummy
-- set the canvas repaint handler:
Gtk.onExpose canvas $ \ event ->
do
(fndatas, state) <- atomically $
do
fadata <- readTVar fadataTV
fndata <- readTVar fndataTV
state <- readTVar stateTV
return ((fadata, fndata), state)
repaintCanvas canvas font fndatas state
-- plug the GL canvas in the GUI:
Gtk.set (canvasAlignment widgets)
[ Gtk.containerChild := canvas ]
return $ widgets { canvas = canvas }
repaintCanvas ::
(FA.ERFnApprox box varid domra ranra fa, ERFnGLDrawable box varid domra ranra fa) =>
GtkGL.GLDrawingArea ->
-- FTGL.Font ->
() ->
((FaData fa),
FnData) ->
(ERFnViewState) ->
IO Bool
repaintCanvas canvas font (fadata, fndata) state =
do
GtkGL.withGLDrawingArea canvas $ \glwindow ->
do
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
drawFG1 $ zip (dataFAs fadata) (favstActiveDims state)
drawCoords glwindow
GtkGL.glDrawableSwapBuffers glwindow
return True
where
plotParams = favstPlotParams state
coordSystem = pltprmCoordSystem plotParams
drawFG1 [] = return ()
drawFG1 ((fa, activeDims) : rest) =
do
GL.color $ GL.Color3 0.0 0.7 (0.8 :: GL.GLfloat)
glDraw (plotParams { pltprmPlotDimensions = activeDims }) fa
drawFG2 rest
drawFG2 [] = return ()
drawFG2 ((fa, activeDims) : rest) =
do
GL.color $ GL.Color3 0.8 0.4 (0.4 :: GL.GLfloat)
glDraw (plotParams { pltprmPlotDimensions = activeDims }) fa
drawFG1 rest
drawCoords glwindow =
do
GL.color $ GL.Color3 1 0.2 (0.4 :: GL.GLfloat)
drawPointLabel glwindow 0 0 "0"
case pltprmCoordSystem plotParams of
CoordSystemLogSqueeze ->
do
mapM (drawXmarks glwindow) $ [0.1, 0.5, 1, 10, 100]
mapM (drawYmarks glwindow) $ [0.1, 0.5, 1, 2, 5, 10, 100, 1000, 1000000, 1000000000000]
CoordSystemLinear _ ->
do
mapM (drawXmarks glwindow) $ [0.25, 0.5, 0.75, 1] -- TODO: use the rectangle
mapM (drawYmarks glwindow) $ [0.25, 0.5, 0.75, 1]
where
drawXmarks glwindow xm =
do
drawPointLabel glwindow xm 0 (show xm)
drawPointLabel glwindow (-xm) 0 (show $ - xm)
drawYmarks glwindow ym =
do
drawPointLabel glwindow 0 ym (show ym)
drawPointLabel glwindow 0 (-ym) (show $ - ym)
drawPointLabel glwindow xModel yModel label =
do
GL.renderPrimitive GL.Lines $
do
GL.vertex $ GL.Vertex3 (x - d) y z
GL.vertex $ GL.Vertex3 (x + d) y z
GL.vertex $ GL.Vertex3 x (y - d) z
GL.vertex $ GL.Vertex3 x (y + d) z
GL.vertex $ GL.Vertex3 x y (z - d)
GL.vertex $ GL.Vertex3 x y (z + d)
drawLabel (x + 2 * d,y - 2 * d,z) label
where
d = 0.01 :: GL.GLdouble
(x,y) = translateToCoordSystem coordSystem [xModel, yModel]
z = 0
drawLabel (x,y,z) label =
do
return ()
-- FTGL.setFontFaceSize font 6 12
-- GL.matrixMode $= GL.Projection
-- GL.preservingMatrix $
-- do
-- GL.translate $ GL.Vector3 0.2 0.8 z
-- GL.scale 0.01 0.01 z
-- m <- GL.newMatrix GL.ColumnMajor [0.1, 0, 0, 0, 0, 0.1, 0, 0, 0, 0, 0.1, 0, 0, 0, 0, 1]
-- GL.multMatrix (m :: GL.GLmatrix Double)
-- GL.renderPrimitive GL.Lines $
-- do
-- GL.vertex $ GL.Vertex3 0 0 z
-- GL.vertex $ GL.Vertex3 0.5 0.5 z
-- m <- GL.newMatrix GL.ColumnMajor [1,0,0,0,1,0,0,0,1]
-- let _ = m :: (GL.GLmatrix Double)
-- GL.withMatrix m $ \_ _ ->
-- do
---- GL.rasterPos $ GL.Vertex2 50 (50 :: GL.GLdouble)
---- FTGL.renderFont font label FTGL.Front
-- GL.renderPrimitive GL.Lines $
-- do
-- GL.vertex $ GL.Vertex3 0 0 z
-- GL.vertex $ GL.Vertex3 10 10 z
-- GtkGL.glDrawableSwapBuffers glwindow
---- box <- FTGL.getFontBBox font label
---- putStrLn $ show box
---- GLUT.renderString GLUT.Fixed9By15 label