{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Interactive.Plot.Core (
Coord(..), cX, cY
, Range(.., RAbout), _rMid, _rSize', rMin, rMax, rSize, rMid, _rSize
, Auto(..)
, PointStyle, pattern PointStyle, _psMarker, _psColor, PointStyleF(..), AutoPointStyle, psMarker, psColor
, Series, SeriesF(..), AutoSeries, sItems, sStyle, toCoordMap, fromCoordMap
, Alignment(..)
, PlotOpts(..), poTermRatio, poAspectRatio, poXRange, poYRange, poRange, poAutoMethod, poHelp, poFramerate, poDelay, poDescription
, defaultPlotOpts
, renderPlot
, plotRange
, OrdColor(..)
, renderPoint
, hzToDelay
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Random
import Data.Coerce
import Data.Default.Class
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Maybe
import Data.Ord
import GHC.Generics (Generic)
import Graphics.Vty hiding ((<|>))
import Lens.Micro
import Lens.Micro.TH
import Text.Printf
import qualified Data.Map as M
import qualified Data.Set as S
newtype OrdColor = OC { getOC :: Color }
deriving Eq
instance Ord OrdColor where
compare = coerce compareColor
where
compareColor = \case
ISOColor c -> \case
ISOColor d -> compare c d
Color240 _ -> LT
Color240 c -> \case
ISOColor _ -> GT
Color240 d -> compare c d
data Coord a = C { _cX :: a
, _cY :: a
}
deriving (Show, Functor, Foldable, Traversable, Eq, Ord)
cX :: Lens' (Coord a) a
cX f (C x y) = (`C` y) <$> f x
cY :: Lens' (Coord a) a
cY f (C x y) = C x <$> f y
instance Num a => Num (Coord a) where
(+) = liftA2 (+)
(-) = liftA2 (-)
(*) = liftA2 (*)
negate = fmap negate
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Applicative Coord where
pure x = C x x
C f g <*> C x y = C (f x) (g y)
instance Monad Coord where
return x = C x x
C x y >>= f = C (_cX (f x)) (_cY (f y))
data Range a = R { _rMin :: a
, _rMax :: a
}
deriving (Show, Functor, Foldable, Traversable)
rMin :: Lens' (Range a) a
rMin f (R x y) = (`R` y) <$> f x
rMax :: Lens' (Range a) a
rMax f (R x y) = R x <$> f y
instance Applicative Range where
pure x = R x x
R f g <*> R x y = R (f x) (g y)
instance Monad Range where
return x = R x x
R x y >>= f = R (_rMin (f x)) (_rMax (f y))
data Auto a = Auto | Given a
deriving (Show, Eq, Ord, Generic, Functor)
instance Semigroup (Auto a) where
(<>) = \case
Auto -> id
Given x -> \case Auto -> Given x; Given y -> Given y
instance Monoid (Auto a) where
mempty = Auto
mappend = (<>)
instance Applicative Auto where
pure = Given
(<*>) = \case
Auto -> const Auto
Given f -> \case
Auto -> Auto
Given x -> Given (f x)
instance Monad Auto where
return = Given
(>>=) = \case
Auto -> const Auto
Given x -> ($ x)
instance Alternative Auto where
empty = Auto
(<|>) = \case
Auto -> id
Given x -> const (Given x)
instance MonadPlus Auto
data PointStyleF f = PointStyleF
{ _psMarkerF :: f Char
, _psColorF :: f Color
}
deriving (Generic)
psMarkerF :: Lens' (PointStyleF f) (f Char)
psMarkerF f (PointStyleF x y) = (`PointStyleF` y) <$> f x
psColorF :: Lens' (PointStyleF f) (f Color)
psColorF f (PointStyleF x y) = PointStyleF x <$> f y
type PointStyle = PointStyleF Identity
type AutoPointStyle = PointStyleF Auto
pattern PointStyle :: Char -> Color -> PointStyle
pattern PointStyle { _psMarker, _psColor } = PointStyleF (Identity _psMarker) (Identity _psColor)
{-# COMPLETE PointStyle #-}
instance (Semigroup (f Char), Semigroup (f Color)) => Semigroup (PointStyleF f) where
PointStyleF m1 c1 <> PointStyleF m2 c2 = PointStyleF (m1 <> m2) (c1 <> c2)
instance (Monoid (f Char), Monoid (f Color)) => Monoid (PointStyleF f) where
mempty = PointStyleF mempty mempty
deriving instance (Show (f Char), Show (f Color)) => Show (PointStyleF f)
deriving instance (Eq (f Char), Eq (f Color)) => Eq (PointStyleF f)
instance (Ord (f Char), Ord (f OrdColor), Functor f, Eq (f Color)) => Ord (PointStyleF f) where
compare = comparing $ \case PointStyleF m1 c1 -> (m1, OC <$> c1)
_Identity :: Lens (Identity a) (Identity b) a b
_Identity f (Identity x) = Identity <$> f x
psMarker :: Lens' PointStyle Char
psMarker = psMarkerF . _Identity
psColor :: Lens' PointStyle Color
psColor = psColorF . _Identity
data SeriesF f = Series { _sItems :: M.Map Double (S.Set Double)
, _sStyle :: PointStyleF f
}
deriving instance (Show (f Char), Show (f Color)) => Show (SeriesF f)
type Series = SeriesF Identity
type AutoSeries = SeriesF Auto
sItems :: Lens' (SeriesF f) (M.Map Double (S.Set Double))
sItems f (Series x y) = (`Series` y) <$> f x
sStyle :: Lens' (SeriesF f) (PointStyleF f)
sStyle f (Series x y) = Series x <$> f y
data Alignment = ALeft
| ACenter
| ARight
data PlotOpts = PO
{ _poTermRatio :: Double
, _poAspectRatio :: Maybe Double
, _poXRange :: Maybe (Range Double)
, _poYRange :: Maybe (Range Double)
, _poAutoMethod :: Maybe StdGen
, _poHelp :: Bool
, _poFramerate :: Maybe Double
, _poDescription :: Maybe Image
}
makeLenses ''PlotOpts
defaultPlotOpts :: PlotOpts
defaultPlotOpts = PO
{ _poTermRatio = 2.1
, _poAspectRatio = Just 1
, _poXRange = Nothing
, _poYRange = Nothing
, _poAutoMethod = Just $ mkStdGen 28922710942259
, _poHelp = True
, _poFramerate = Nothing
, _poDescription = Nothing
}
instance Default PlotOpts where
def = defaultPlotOpts
pattern RAbout :: Fractional a => a -> a -> Range a
pattern RAbout { _rMid, _rSize' } <- (\case R{..} -> ((_rMin + _rMax) / 2, _rMax - _rMin)->(_rMid, _rSize'))
where
RAbout rM rS = R (rM - rS2) (rM + rS2)
where
rS2 = rS / 2
{-# COMPLETE RAbout #-}
_rSize :: Num a => Range a -> a
_rSize R{..} = _rMax - _rMin
rSize :: Fractional a => Lens' (Range a) a
rSize f (RAbout m s) = RAbout m <$> f s
rMid :: Fractional a => Lens' (Range a) a
rMid f (RAbout m s) = (`RAbout` s) <$> f m
within :: Ord a => a -> Range a -> Bool
within x r = x >= r ^. rMin && x <= r ^. rMax
poRange :: Lens' PlotOpts (Maybe (Range Double), Maybe (Range Double))
poRange f (PO r a x y s h t d) = (\(x', y') -> PO r a x' y' s h t d) <$> f (x, y)
poDelay :: Lens' PlotOpts (Maybe Int)
poDelay = poFramerate . hzToDelay
hzToDelay :: Lens' (Maybe Double) (Maybe Int)
hzToDelay f md = fmap back <$> f (fmap forward md)
where
back d = 1000000 / fromIntegral d
forward p = round $ 1000000 / p
plotRange
:: PlotOpts
-> Coord (Range Int)
-> [Series]
-> Coord (Range Double)
plotRange PO{..} dr ss = case _poAspectRatio of
Just rA ->
let displayRatio = fromIntegral (dr ^. cY . to _rSize)
/ (fromIntegral (dr ^. cX . to _rSize) / _poTermRatio)
* rA
in case (_poXRange, _poYRange) of
(Nothing, Nothing) -> case compare pointRangeRatio displayRatio of
LT -> pointRange
& cY . rSize .~ pointRange ^. cX . rSize * displayRatio
EQ -> pointRange
GT -> pointRange
& cX . rSize .~ pointRange ^. cY . rSize / displayRatio
(Just x , Nothing) -> pointRange
& cX .~ x
& cY . rSize .~ x ^. rSize * displayRatio
(Nothing, Just y ) -> pointRange
& cX . rSize .~ y ^. rSize / displayRatio
& cY .~ y
(Just x , Just y ) -> C x y
Nothing -> case (_poXRange, _poYRange) of
(Nothing, Nothing) -> pointRange
(Just x , Nothing) -> pointRange & cX .~ x
(Nothing, Just y ) -> pointRange & cY .~ y
(Just x , Just y ) -> C x y
where
unZero :: Range Double -> Range Double
unZero r
| r ^. rSize == 0 = R (subtract 1) (+ 1) <*> r
| otherwise = r
pointRangeRatio :: Double
pointRangeRatio = pointRange ^. cY . rSize / pointRange ^. cX . rSize
pointRange :: Coord (Range Double)
pointRange = fmap unZero
. foldl' (liftA2 go) (C (R 0 0) (R 0 0))
$ ss ^.. traverse . sItems . folding fromCoordMap
where
go oldR x = R min max <*> pure x <*> oldR
renderPlot
:: Coord (Range Int)
-> Coord (Range Double)
-> [Series]
-> [Image]
renderPlot dr pr = overlayAxis dr pr
. concatMap (renderSeries dr pr)
overlayAxis
:: Coord (Range Int)
-> Coord (Range Double)
-> [Image]
-> [Image]
overlayAxis dr pr is = foldMap toList axisBounds ++ is ++ axisLines
where
origin = placeImage dr pr (C ACenter ACenter) (C 0 0) $
char defAttr '+'
xAxis = placeImage dr pr (C ALeft ACenter) (C (pr ^. cX . rMin) 0 ) $
charFill defAttr '-' (dr ^. cX . to _rSize) 1
yAxis = placeImage dr pr (C ACenter ALeft ) (C 0 (pr ^. cY . rMax)) $
charFill defAttr '|' 1 (dr ^. cY . to _rSize)
axisLines = [origin, xAxis, yAxis]
axisBounds :: Coord (Range Image)
axisBounds = getCompose $ do
pos <- Compose pr
coords <- Compose $ C (pure $ \d -> C d 0) (pure $ \d -> C 0 d)
xAlign <- Compose $ C (R ALeft ARight ) (R ACenter ACenter)
yAlign <- Compose $ C (R ACenter ACenter) (R ARight ALeft )
pure $ placeImage dr pr (C xAlign yAlign) (coords pos)
(string defAttr $ printf "%.2f" pos)
placeImage
:: Coord (Range Int)
-> Coord (Range Double)
-> Coord Alignment
-> Coord Double
-> Image
-> Image
placeImage dr pr (C aX aY) r i = translate x' (dr ^. cY . to _rSize - y') i
where
dr' = (fmap . fmap) fromIntegral dr
scaled = lerp <$> pr <*> dr' <*> r
C x' y' = (round <$> scaled) + C (aligner aX (imageWidth i))
(negate (aligner aY (imageHeight i)))
aligner = \case
ALeft -> const 0
ACenter -> negate . (`div` 2)
ARight -> negate
lerp
:: Fractional a
=> Range a
-> Range a
-> a
-> a
lerp rOld rNew x =
rNew ^. rMin + (x - rOld ^. rMin) / (rOld ^. rSize) * (rNew ^. rSize)
renderSeries
:: Coord (Range Int)
-> Coord (Range Double)
-> Series
-> [Image]
renderSeries dr pr Series{..} =
M.foldMapWithKey (\x -> foldMap (maybeToList . go . C x))
$ validPoints pr _sItems
where
go :: Coord Double -> Maybe Image
go r = placeImage dr pr (C ACenter ACenter) r (renderPoint _sStyle)
<$ guard (and $ within <$> r <*> pr)
validPoints
:: Ord k
=> Coord (Range k)
-> M.Map k (S.Set k)
-> M.Map k (S.Set k)
validPoints pr = fmap (setRange (pr ^. cY))
. mapRange (pr ^. cX)
where
mapRange r m = M.unions $ m''
: maybeToList (M.singleton (r ^. rMin) <$> mMin)
++ maybeToList (M.singleton (r ^. rMax) <$> mMax)
where
(_ , mMin, m') = M.splitLookup (r ^. rMin) m
(m'', mMax, _ ) = M.splitLookup (r ^. rMax) m'
setRange r s = S.unions $ s''
: (S.singleton (r ^. rMin) <$ guard sMin)
++ (S.singleton (r ^. rMax) <$ guard sMax)
where
(_ , sMin, s') = S.splitMember (r ^. rMin) s
(s'', sMax, _ ) = S.splitMember (r ^. rMax) s'
toCoordMap
:: Eq a
=> S.Set (Coord a)
-> M.Map a (S.Set a)
toCoordMap = fmap (S.fromDistinctAscList . ($ []))
. M.fromAscListWith (.)
. foldMap (\case C x y -> [(x, (y:))])
fromCoordMap
:: M.Map a (S.Set a)
-> S.Set (Coord a)
fromCoordMap = S.fromDistinctAscList
. M.foldMapWithKey (\k -> foldMap ((:[]) . C k))
renderPoint
:: PointStyle
-> Image
renderPoint PointStyle{..} = char (defAttr `withForeColor` _psColor) _psMarker