Aelve Codesearch

grep over package repositories
AERN-RnToRm-Plot-0.2.0.3
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
import Foreign.C.Types

{-|
    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 CDouble)
--                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