{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Interactive.Plot.Run (
runPlot
, runPlotAuto
, animatePlot, lastForever
, animatePlotFunc
, animatePlotMoore, Moore(..)
, runPlotDynamic
, PlotData(..), pdTitle, pdSerieses, pdDesc
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Foldable
import Data.IORef
import Data.List
import Data.Maybe
import Graphics.Vty hiding ((<|>))
import Interactive.Plot.Core
import Interactive.Plot.Series
import Lens.Micro
import Lens.Micro.TH
import Text.Printf
import qualified Data.List.NonEmpty as NE
data PEvent = PEQuit
| PEZoom (Coord Double)
| PEPan (Coord Double)
| PEResize (Coord Int)
| PEHelp
| PEReset
| PETick
processEvent :: Event -> Maybe PEvent
processEvent = \case
EvKey KEsc [] -> Just PEQuit
EvKey (KChar 'c') [MCtrl] -> Just PEQuit
EvKey (KChar 'q') [] -> Just PEQuit
EvKey (KChar 'r') [] -> Just PEReset
EvKey (KChar 'R') [] -> Just PEReset
EvKey (KChar '=') [] -> Just $ PEZoom (C (sqrt 0.5) (sqrt 0.5))
EvKey (KChar '+') [] -> Just $ PEZoom (C (sqrt 0.5) (sqrt 0.5))
EvKey (KChar '-') [] -> Just $ PEZoom (C (sqrt 2 ) (sqrt 2 ))
EvKey (KChar '_') [] -> Just $ PEZoom (C (sqrt 2 ) (sqrt 2 ))
EvKey (KChar 'h') [] -> Just $ PEPan (C (-0.2) 0 )
EvKey (KChar 'j') [] -> Just $ PEPan (C 0 (-0.2))
EvKey (KChar 'k') [] -> Just $ PEPan (C 0 0.2 )
EvKey (KChar 'l') [] -> Just $ PEPan (C 0.2 0 )
EvKey (KChar 'w') [] -> Just $ PEPan (C (-0.2) 0 )
EvKey (KChar 'a') [] -> Just $ PEPan (C 0 (-0.2))
EvKey (KChar 's') [] -> Just $ PEPan (C 0 0.2 )
EvKey (KChar 'd') [] -> Just $ PEPan (C 0.2 0 )
EvKey KLeft [] -> Just $ PEPan (C (-0.2) 0 )
EvKey KDown [] -> Just $ PEPan (C 0 (-0.2))
EvKey KUp [] -> Just $ PEPan (C 0 0.2 )
EvKey KRight [] -> Just $ PEPan (C 0.2 0 )
EvKey (KChar 'v') [] -> Just $ PEZoom (C 1 (sqrt 2 ))
EvKey (KChar '^') [] -> Just $ PEZoom (C 1 (sqrt 0.5))
EvKey (KChar '<') [] -> Just $ PEZoom (C (sqrt 2 ) 1 )
EvKey (KChar '>') [] -> Just $ PEZoom (C (sqrt 0.5) 1 )
EvKey (KChar '?') [] -> Just PEHelp
EvKey (KChar '/') [] -> Just PEHelp
EvResize ht wd -> Just $ PEResize (C ht wd)
_ -> Nothing
data PlotState = PlotState
{ _psRange :: Coord (Range Double)
, _psHelp :: Bool
}
makeClassy ''PlotState
displayRange :: Output -> IO (Coord (Range Int))
displayRange o = do
(wd, ht) <- displayBounds o
pure $ C (R 0 wd) (R 0 ht)
data PlotData = PlotData
{ _pdTitle :: Maybe String
, _pdDesc :: Maybe Image
, _pdSerieses :: [Series]
}
pdTitle :: Lens' PlotData (Maybe String)
pdTitle f (PlotData x y z) = (\x' -> PlotData x' y z) <$> f x
pdDesc :: Lens' PlotData (Maybe Image)
pdDesc f (PlotData x y z) = (\y' -> PlotData x y' z) <$> f y
pdSerieses :: Lens' PlotData [Series]
pdSerieses f (PlotData x y z) = PlotData x y <$> f z
runPlotAuto
:: PlotOpts
-> Maybe String
-> [AutoSeries]
-> IO ()
runPlotAuto po t s = case po ^. poAutoMethod of
Nothing -> runPlot po t =<< fromAutoSeriesIO s
Just g -> runPlot po t $ fromAutoSeries_ g s
runPlot
:: PlotOpts
-> Maybe String
-> [Series]
-> IO ()
runPlot po t s = runPlotDynamic po
(const (pure True))
(pure (Just (PlotData t (_poDescription po) s)))
animatePlot
:: PlotOpts
-> Double
-> Maybe String
-> [[Series]]
-> IO ()
animatePlot po fps t ss = do
ssRef <- newEmptyMVar
rateMult <- newIORef 0
tid <- forkIO $ do
forM_ ss $ \s -> do
putMVar ssRef (Just s)
threadDelay . mkDelay =<< readIORef rateMult
takeMVar ssRef
putMVar ssRef Nothing
runPlotDynamic po' (updateFr rateMult) (mkData rateMult ssRef)
killThread tid
where
mkDelay i = round $ 1000000 / (fps * (2 ** (fromIntegral i / 2)))
mkData rateMult ssRef = do
ss' <- readMVar ssRef
desc <- animateDesc (_poDescription po) <$> readIORef rateMult
pure $ PlotData t desc <$> ss'
po' = po & poFramerate %~ (<|> Just (max fps 10))
updateFr :: IORef Int -> Event -> IO Bool
updateFr rateMult = \case
EvKey (KChar '[') [] -> True <$ modifyIORef rateMult (subtract 1)
EvKey (KChar ']') [] -> True <$ modifyIORef rateMult (+ 1)
_ -> pure True
lastForever :: [a] -> [a]
lastForever [] = []
lastForever [x] = repeat x
lastForever (x:xs@(_:_)) = x : lastForever xs
animateDesc :: Maybe Image -> Int -> Maybe Image
animateDesc d r = desc' <|> Just desc
where
desc = string defAttr $ "[/] rate" ++ rString
desc' = (`vertJoin` desc) . (`vertJoin` char defAttr ' ') <$> d
rString
| r == 0 = ""
| otherwise = printf " (x%.2f)" $ 2 ** (fromIntegral @_ @Double r / 2)
animatePlotFunc
:: PlotOpts
-> Maybe String
-> (Double -> Maybe [Series])
-> IO ()
animatePlotFunc po t f = animatePlotMoore po t $ Moore
{ moInitVal = f 0
, moInitState = 0
, moUpdate = \dt tt ->
let t' = tt + dt
in pure $ (, t') <$> f t'
}
data Moore a = forall s. Moore
{
moInitVal :: Maybe a
, moInitState :: s
, moUpdate :: Double -> s -> IO (Maybe (a, s))
}
deriving instance Functor Moore
animatePlotMoore
:: PlotOpts
-> Maybe String
-> Moore [Series]
-> IO ()
animatePlotMoore po t Moore{..} = do
ssRef <- newIORef moInitVal
rateMult <- newIORef 0
currState <- newIORef moInitState
tid <- forkIO . void . runMaybeT . many . MaybeT . fmap guard $ do
threadDelay td
dt <- mkDT <$> readIORef rateMult
s <- readIORef currState
moUpdate dt s >>= \case
Nothing -> False <$ writeIORef ssRef Nothing
Just (xs, s') -> True <$ do
writeIORef ssRef (Just xs)
writeIORef currState s'
runPlotDynamic po (updateFr rateMult) (mkData rateMult ssRef)
killThread tid
where
fps = fromMaybe 1 $ po ^. poFramerate
td = fromMaybe 1000000 $ po ^. poDelay
mkDT i = 1 / (fps * (2 ** (- fromIntegral i / 2)))
mkData rateMult ssRef = do
ss' <- readIORef ssRef
desc <- animateDesc (_poDescription po) <$> readIORef rateMult
pure $ PlotData t desc <$> ss'
updateFr :: IORef Int -> Event -> IO Bool
updateFr rateMult = \case
EvKey (KChar '[') [] -> True <$ modifyIORef rateMult (subtract 1)
EvKey (KChar ']') [] -> True <$ modifyIORef rateMult (+ 1)
_ -> pure True
runPlotDynamic
:: PlotOpts
-> (Event -> IO Bool)
-> IO (Maybe PlotData)
-> IO ()
runPlotDynamic po pe ssRef = do
vty <- mkVty =<< standardIOConfig
pdmaybe <- ssRef
forM_ pdmaybe $ \initPD -> do
psRef <- newIORef =<< initPS vty initPD
peChan <- newChan
tPE <- forkIO . forever $ do
e <- nextEvent vty
q <- pe e
unless q $ writeChan peChan PEQuit
traverse_ (writeChan peChan) $ processEvent e
tTick <- forM (po ^. poDelay) $ \td ->
forkIO . forever $ do
threadDelay td
writeChan peChan PETick
void . runMaybeT . many . MaybeT . fmap guard $
plotLoop vty peChan psRef
killThread tPE
traverse_ killThread tTick
shutdown vty
where
initPS :: Vty -> PlotData -> IO PlotState
initPS vty PlotData{..} = do
dr <- displayRange $ outputIface vty
pure $ PlotState
{ _psRange = plotRange po dr _pdSerieses
, _psHelp = po ^. poHelp
}
plotLoop
:: Vty
-> Chan PEvent
-> IORef PlotState
-> IO Bool
plotLoop vty peChan psRef = do
dr <- displayRange $ outputIface vty
ps <- readIORef psRef
pdmaybe <- ssRef
fmap or . forM pdmaybe $ \pd@PlotData{..} -> do
let titleBox = fmap (vertCat . intersperse (char defAttr ' ') . toList) . NE.nonEmpty . catMaybes $
[ string (withStyle defAttr bold) <$> _pdTitle
, _pdDesc
]
uiText = case (titleBox, _psHelp ps) of
(Nothing, False) -> id
(Just t , False) -> (box t ++)
(Nothing, True ) -> (box helpBox ++)
(Just t , True ) -> (box (vertCat [t, char defAttr ' ', helpBox]) ++)
imgs = uiText $ renderPlot dr (_psRange ps) _pdSerieses
update vty $ picForLayers imgs
hideCursor . outputIface $ vty
readChan peChan >>= \case
PEQuit -> pure False
PEZoom d -> do
let scaler s = over rSize (* s)
writeIORef psRef $
ps & psRange %~ (<*>) (scaler <$> d)
pure True
PEPan d -> do
let panner s r = fmap (+ (r ^. rSize * s)) r
writeIORef psRef $
ps & psRange %~ (<*>) (panner <$> d)
pure True
PEResize newDim -> do
let oldDim = _rSize <$> dr
newRange = do
d0 <- oldDim
d1 <- newDim
r0 <- _psRange ps
pure $ r0 & rSize %~ (* (fromIntegral d1 / fromIntegral d0))
writeIORef psRef $
ps & psRange .~ newRange
pure True
PEHelp -> do
writeIORef psRef $
ps & psHelp %~ not
pure True
PEReset -> do
writeIORef psRef =<< initPS vty pd
pure True
PETick -> pure True
helpText :: [(String, String)]
helpText =
[ ("-/+" , "zoom")
, ("arrows", "pan")
, ("v/^" , "vert stretch")
, ("</>" , "horiz stretch")
, ("r" , "reset disp")
, ("?" , "show help")
, ("q" , "quit")
]
helpBox :: Image
helpBox = vertCat (string defAttr . (++ " ") <$> x)
`horizJoin` vertCat (string defAttr <$> y)
where
(x,y) = unzip helpText
box :: Image -> [Image]
box (pad 1 0 1 0 -> i) = [boxed, charFill defAttr ' ' (imageWidth i + 1) (imageHeight i + 1)]
where
lr = charFill defAttr '|' 1 (imageHeight i)
tb = charFill defAttr '-' (imageWidth i) 1
c = char defAttr '+'
boxed = vertCat . map horizCat $
[ [c , tb, c ]
, [lr, i , lr]
, [c , tb, c ]
]