AERN-RnToRm-Plot-0.1.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.FAView
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.Real.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 Graphics.UI.Gtk (AttrOp((:=)))
import qualified Graphics.UI.Gtk.Glade as Glade
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
import qualified Graphics.UI.GLUT as GLUT
import qualified System.Glib.Signals as Signals
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.MiscSTM
import Data.IORef
import Data.Maybe
import qualified System.FilePath as FilePath
import System.Directory
{-|
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
}
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"
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,
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,
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
}
initState ::
(t, FnData) ->
ERFnViewState
initState (fadata, fndata) =
ERFnViewState
{
favstActiveDims = map (map $ const True) $ dataResultNames fndata,
favstTrackingDefaultEvalPt = True,
favstPlotParams = dataDefaultPlotParams fndata
}
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)
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
return ()
where
setHandlerCoordSystem =
do
Gtk.on (coorSystemCombo widgets) Gtk.changed $
do
maybeCSysIx <- Gtk.comboBoxGetActive (coorSystemCombo widgets)
case maybeCSysIx of
#ifdef GTK2HS_0_9_13
Nothing -> return ()
Just ix ->
#else
-1 -> return ()
ix ->
#endif
do
coordSystem <-
atomically $
do
fndata <- readTVar fndataTV
let coordSystem = case ix of
0 -> CoordSystemLogSqueeze
1 ->
CoordSystemLinear $ Rectangle
((toRational $ dataValHI fndata) + 0.2)
((toRational $ dataValLO fndata) - 0.2)
((toRational $ dataDomL fndata) - 0.1)
((toRational $ dataDomR fndata) + 0.1)
modifyTVar stateTV $ update coordSystem
return coordSystem
changeCoordSystem coordSystem
where
update coordSystem state =
state
{
favstPlotParams =
(favstPlotParams state)
{ pltprmCoordSystem = coordSystem }
}
changeCoordSystem coordSystem =
do
resetZoom coordSystem
(fndatas, state) <- atomically $ readAll3TVars fndataTVs stateTV
repaintCanvas (canvas widgets) fndatas state
return ()
resetZoom CoordSystemLogSqueeze =
do
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) ""
resetZoom (CoordSystemLinear (Rectangle hi lo l r)) =
do
-- Gtk.editableSetEditable (zoomEntry widgets) True
-- Gtk.editableSetEditable (centreXEntry widgets) True
-- Gtk.editableSetEditable (centreYEntry widgets) True
Gtk.editableSetEditable (zoomEntry widgets) False
Gtk.editableSetEditable (centreXEntry widgets) False
Gtk.editableSetEditable (centreYEntry widgets) False
Gtk.entrySetText (zoomEntry widgets) "100"
Gtk.entrySetText (centreXEntry widgets) $ show $ (l + r)/2
Gtk.entrySetText (centreYEntry widgets) $ show $ (hi + lo)/2
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
{-|
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
repaintCanvas (canvas widgets) fndatas state
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)
repaintCanvas (canvas widgets) (fadata, fndata) state
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.loadIdentity
GL.ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
GL.depthFunc $= Just GL.Less
GL.drawBuffer $= GL.BackBuffers
-- 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 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 ->
((FaData fa),
FnData) ->
(ERFnViewState) ->
IO Bool
repaintCanvas canvas (fadata, fndata) state =
do
GtkGL.withGLDrawingArea canvas $ \glwindow ->
do
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
drawFG1 $ zip (dataFAs fadata) (favstActiveDims state)
drawCoords
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 =
do
GL.color $ GL.Color3 1 0.2 (0.4 :: GL.GLfloat)
drawPointLabel 0 0 "0"
case pltprmCoordSystem plotParams of
CoordSystemLogSqueeze ->
do
mapM drawXmarks $ [0.1, 0.5, 1, 10, 100]
mapM drawYmarks $ [0.1, 0.5, 1, 2, 5, 10, 100, 1000, 1000000, 1000000000000]
CoordSystemLinear _ ->
do
mapM drawXmarks $ [0.25, 0.5, 0.75, 1] -- TODO: use the rectangle
mapM drawYmarks $ [0.25, 0.5, 0.75, 1]
where
drawXmarks xm =
do
drawPointLabel xm 0 (show xm)
drawPointLabel (-xm) 0 (show $ - xm)
drawYmarks ym =
do
drawPointLabel 0 ym (show ym)
drawPointLabel 0 (-ym) (show $ - ym)
drawPointLabel 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.GLfloat
(x,y) = translateToCoordSystem coordSystem [xModel, yModel]
z = 0
drawLabel (x,y,z) label =
do
GL.rasterPos $ GL.Vertex3 x y z
GLUT.renderString GLUT.Fixed9By15 label