{-# 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