diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Changelog for interactive-plot + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Justin Le (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Justin Le nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,61 @@ +[interactive-plot][] +==================== + +[interactive-plot]: https://hackage.haskell.org/package/interactive-plot + +Quick time series terminal plotting for data exploration/in ghci. + +Most commonly used imports should be available in *Interactive.Plot*. + +Construct a `Series` from scratch using the raw data type, or use one of the +handy helpers: + +1. `listSeries`: Create a series from a list or any foldable. +2. `tupleSeries`: Create a series from a list of ordered-pair tuples providing + x and y locations. +3. `funcSeries`: Create a series from a function `Double -> Double`, given a + range of `x`s to produce the `y`s. + +Then simply "run" a list of series (or "automatic-styled series") using +`runPlotAuto` or `runPlot`: + +```haskell +runPlotAuto + :: PlotOpts -- ^ options (can be 'defaultPlotOpts') + -> Maybe String -- ^ optional title + -> [AutoSeries] -- ^ uninitialized data of serieses + -> IO () +``` + +![Static Plots](https://i.imgur.com/SkH1C1j.gif) + +These plots can be zoomed, stretched, scaled, panned interactively after +launch. If you quit, things resume back to the ghci session (or whatever point +in the program you launch from). + +There are also options for rudimentary animations: + +```haskell +animatePlot + :: PlotOpts + -> Double -- ^ update rate (frames per second) + -> Maybe String -- ^ title + -> [[Series]] -- ^ list of series data (potentially infinite) + -> IO () + +animatePlotFunc + :: PlotOpts + -> Maybe String -- ^ title + -> (Double -> Maybe [Series]) -- ^ function from time to plot. will quit + -- as soon as 'Nothing' is returned. + -> IO () +``` + +![Animated Plots](https://i.imgur.com/37Cq8ET.gif) + +Todo +---- + +* Consider being able to use functions directly as a series, instead of + converting them into ordered pairs based on a known x series. +* I'm sure usability could always be improved :) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/demo.hs b/app/demo.hs new file mode 100644 --- /dev/null +++ b/app/demo.hs @@ -0,0 +1,15 @@ +import Interactive.Plot + +cosTest, lineTest :: AutoSeries +cosTest = funcSeries cos (enumRange 100 (R (-5) 5)) mempty +lineTest = funcSeries id (enumRange 20 (R (-4) 4)) mempty + +sinTest :: Double -> AutoSeries +sinTest t = funcSeries (sin . (+ t)) (enumRange 100 (R (-5) 5)) mempty + +main :: IO () +main = do + runPlotAuto defaultPlotOpts (Just "simple test") [cosTest, lineTest] + animatePlotFunc (defaultPlotOpts { _poFramerate = Just 20 }) (Just "animate test") $ + Just . fromAutoSeries . (:[]) . sinTest + diff --git a/interactive-plot.cabal b/interactive-plot.cabal new file mode 100644 --- /dev/null +++ b/interactive-plot.cabal @@ -0,0 +1,65 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: cf947ccf209af0eda27250773d3b66c1d51014c28562f3bcaa6fd42224cd4074 + +name: interactive-plot +version: 0.1.0.0 +synopsis: Interactive quick time series plotting +description: Quick time series terminal plotting for data exploration/in ghci. See + documentation for "Interactive.Plot" and README for more information. +category: Interactive +homepage: https://github.com/mstksg/interactive-plot#readme +bug-reports: https://github.com/mstksg/interactive-plot/issues +author: Justin Le +maintainer: justin@jle.im +copyright: (c) Justin Le 2018 +license: BSD3 +license-file: LICENSE +tested-with: GHC >= 8.4 && < 8.8 +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/mstksg/interactive-plot + +library + exposed-modules: + Interactive.Plot + Interactive.Plot.Core + Interactive.Plot.Run + Interactive.Plot.Series + other-modules: + Paths_interactive_plot + hs-source-dirs: + src + ghc-options: -Wall -Wredundant-constraints -Werror=incomplete-patterns -Wcompat + build-depends: + MonadRandom + , base >=4.11 && <5 + , containers >=0.5.11 + , data-default-class + , microlens + , microlens-th + , mtl + , transformers + , vty + default-language: Haskell2010 + +executable interactive-plot-demo + main-is: demo.hs + other-modules: + Paths_interactive_plot + hs-source-dirs: + app + ghc-options: -Wall -Wredundant-constraints -Werror=incomplete-patterns -Wcompat -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.11 && <5 + , interactive-plot + default-language: Haskell2010 diff --git a/src/Interactive/Plot.hs b/src/Interactive/Plot.hs new file mode 100644 --- /dev/null +++ b/src/Interactive/Plot.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- Module : Interative.Plot +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Simple interactive rendering of plots. See README for information on +-- usage. +-- +-- The main way to use this library is to use 'runPlotAuto' or 'runPlot' on +-- some series you make using the series constructors ('listSeries', +-- 'funcSeries', etc.) +-- +module Interactive.Plot ( + -- * Construct Series + Auto(..) + , Series, AutoSeries, SeriesF(..), sItems, sStyle + -- ** Making common serieses + , listSeries + , tupleSeries + , funcSeries + , enumRange + , toCoordMap + , fromCoordMap + -- ** Series from AutoSeroes + , fromAutoSeries + , fromAutoSeriesIO + , fromAutoSeries_ + -- ** Types + , PointStyle, pattern PointStyle, _psMarker, _psColor, AutoPointStyle, PointStyleF(..), psMarker, psColor + , Coord(..), cX, cY + , Range(..), _rMid, _rSize', rMin, rMax, rSize, rMid, _rSize + -- * Run a Plot + , runPlot + , runPlotAuto + -- ** Animated + , animatePlot, lastForever + , animatePlotFunc + -- ** Options + , PlotOpts(..), poTermRatio, poAspectRatio, poXRange, poYRange, poRange, poAutoMethod, poHelp, poFramerate, poDelay + , defaultPlotOpts + ) where + +import Interactive.Plot.Core +import Interactive.Plot.Run +import Interactive.Plot.Series diff --git a/src/Interactive/Plot/Core.hs b/src/Interactive/Plot/Core.hs new file mode 100644 --- /dev/null +++ b/src/Interactive/Plot/Core.hs @@ -0,0 +1,539 @@ +{-# 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 : Interative.Plot.Core +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Core rendering functionality for the library. +-- +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 + -- * Internal + , 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 wrapper providing an 'Ord' instance for 'Color'. +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 + +-- | An ordered pair in @a@. +data Coord a = C { _cX :: a -- ^ Access @x@. + , _cY :: a -- ^ Access @y@. + } + deriving (Show, Functor, Foldable, Traversable, Eq, Ord) + +-- | Getter/setter lens to the @x@ position in a 'Coord'. +cX :: Lens' (Coord a) a +cX f (C x y) = (`C` y) <$> f x + +-- | Getter/setter lens to the @x@ position in a 'Coord'. +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) + +-- | Basically the same as @Reader 'Bool'@, for @x@ and @y@. +instance Monad Coord where + return x = C x x + C x y >>= f = C (_cX (f x)) (_cY (f y)) + +-- | A specification for a range. Using 'R', contains the minimum and +-- maximum. Using 'RAbout', contains the midpoint and size. +data Range a = R { _rMin :: a -- ^ Minimum of range. + , _rMax :: a -- ^ Maximum of range. + } + deriving (Show, Functor, Foldable, Traversable) + + +-- | Getter/setter lens to the minimum value in a 'Range'. +rMin :: Lens' (Range a) a +rMin f (R x y) = (`R` y) <$> f x + +-- | Getter/setter lens to the maximum value in a 'Range'. +rMax :: Lens' (Range a) a +rMax f (R x y) = R x <$> f y + +-- | "Zipping" behavior on minimum and maximum +instance Applicative Range where + pure x = R x x + R f g <*> R x y = R (f x) (g y) + +-- | Basically the same as @Reader 'Bool'@, for minimum and maximum +-- fields. +instance Monad Range where + return x = R x x + R x y >>= f = R (_rMin (f x)) (_rMax (f y)) + +-- | Used to specify fields in 'PointStyle' and 'Series': Use 'Auto' for +-- automatic inference, and 'Given' to provide a specific value. +-- +-- Its 'Semigroup' instance keeps the last 'Given'. +data Auto a = Auto | Given a + deriving (Show, Eq, Ord, Generic, Functor) + +-- | Keeps the final 'Given': like 'Data.Monoid.Last' +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) + +-- | Opposite behavior of 'Semigroup' instance: like 'Maybe's 'Alternative' +-- instance, or 'Data.Monoid.First'. +instance Alternative Auto where + empty = Auto + (<|>) = \case + Auto -> id + Given x -> const (Given x) + +-- | Opposite behavior of 'Semigroup' instance: like 'Maybe's 'Alternative' +-- instance, or 'Data.Monoid.First'. +instance MonadPlus Auto + +-- | A parameterized version of 'PointStyle' to unify functions in +-- "Interactive.Plot.Series". +-- +-- Mainly you will be using either 'PointStyle' or 'AutoPointStyle'. +data PointStyleF f = PointStyleF + { _psMarkerF :: f Char -- ^ Marker character. + , _psColorF :: f Color -- ^ Marker color. + } + deriving (Generic) + +-- | Getter/setter lens to the marker field of a 'PointStyleF' +psMarkerF :: Lens' (PointStyleF f) (f Char) +psMarkerF f (PointStyleF x y) = (`PointStyleF` y) <$> f x + +-- | Getter/setter lens to the color field of a 'PointStyleF' +psColorF :: Lens' (PointStyleF f) (f Color) +psColorF f (PointStyleF x y) = PointStyleF x <$> f y + +-- | Specification of a style for a point. +-- +-- Construct this wiht the 'PointStyle' pattern synonym. +type PointStyle = PointStyleF Identity + +-- | A version of 'PointStyle' where you can leave the marker or color +-- blank, to be automatically inferred. +-- +-- You can construct this with the 'PointStyleF' constructor. +-- +-- It has a very convenient 'Monoid' instance: 'mempty' gives +-- a 'PointStyle' where every field is 'Auto', and '<>' combines +-- 'PointStyle's field-by-field, keeping the last 'Given'. +type AutoPointStyle = PointStyleF Auto + +-- | Pattern synonym/constructor for 'PointStyle'. +-- +-- This comes with two record fields, '_psMarker' and '_psColor'. +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 + +-- | A parameterized version of 'Series' to unify functions in +-- "Interactive.Plot.Series". +-- +-- Mainly you will be using either 'Series' or 'AutoSeries'. +data SeriesF f = Series { _sItems :: M.Map Double (S.Set Double) -- ^ A map of @x@ positions to @y@ points at that position + , _sStyle :: PointStyleF f -- ^ The style of points. For 'Series', this is 'PointStyle'; for 'AutoSeries', this is 'AutoPointStyle'. + } + +deriving instance (Show (f Char), Show (f Color)) => Show (SeriesF f) + +-- | Data for a single series: contains the coordinate map with the point +-- style for the series. +type Series = SeriesF Identity + +-- | A version of 'Series' where you can leave the marker or color blank, +-- to be automatically inferred. +type AutoSeries = SeriesF Auto + +-- | Getter/setter lens to the items field of a 'SeriesF' +sItems :: Lens' (SeriesF f) (M.Map Double (S.Set Double)) +sItems f (Series x y) = (`Series` y) <$> f x + +-- | Getter/setter lens to the style field of a 'SeriesF' +-- +-- @ +-- 'sStyle' :: Lens 'Series' 'PointStyle' +-- 'sStyle' :: Lens 'AutoSeries' 'AutoPointStyle' +-- @ +sStyle :: Lens' (SeriesF f) (PointStyleF f) +sStyle f (Series x y) = Series x <$> f y + +-- | Alignment specification. +data Alignment = ALeft + | ACenter + | ARight + +-- | Options used for running the plot interactively in a terminal. +data PlotOpts = PO + { _poTermRatio :: Double -- ^ character width ratio of terminal (H/W). Default is 2.1. + , _poAspectRatio :: Maybe Double -- ^ plot aspect ratio (H/W). Use 'Nothing' for automatic. Default is @'Just' 1@. + , _poXRange :: Maybe (Range Double) -- ^ X Range. Use 'Nothing' for automatic. Default is 'Nothing'. + , _poYRange :: Maybe (Range Double) -- ^ Y Range. Use 'Nothing' for automatic. Default is 'Nothing'. + , _poAutoMethod :: Maybe StdGen -- ^ How to fill in missing + -- values when run using + -- 'Interactive.Plot.Run.runPlotAuto'. + -- 'Nothing' for IO, 'Just' + -- for deterministic seed. + -- Ignored when using + -- 'Interactive.Plot.Run.runPlot'. + -- Default is an arbitrarily + -- selected seed. + , _poHelp :: Bool -- ^ Whether or not to show help box initially. Box can always be toggled with @?@. (Default is 'True') + , _poFramerate :: Maybe Double -- ^ Updates per second; 'Nothing' for no updates. Use 'poDelay' to treat this as a microsecond delay instead. (default: 'Nothing') + , _poDescription :: Maybe Image -- ^ Initial extra information in description box. Ignored if directly using 'runPlotDynamic'. Default is 'Nothing' + } + +makeLenses ''PlotOpts + +-- | Sensible defaults for most terminals. +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 + +-- | An alternative "constructor" for 'R', which takes a midpoint and size +-- instead of a min and max. +-- +-- This comes with record fields, '_rMid' and '_rSize''. +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 #-} + +-- | Gets the size of a 'Range'. +-- +-- A version of '_rSize'' that works for any instance of 'Num'. +_rSize :: Num a => Range a -> a +_rSize R{..} = _rMax - _rMin + +-- | Lens into the size of a 'Range' Modifying this size results in +-- a scaling about the midpoint of the range. +-- +-- @ +-- view rSize (R 2 4) +-- -- 2 +-- over rSize (* 2) (R 2 4) +-- -- R 1 5 +-- @ +rSize :: Fractional a => Lens' (Range a) a +rSize f (RAbout m s) = RAbout m <$> f s + +-- | Lens into the midpoint of a 'Range'. Modifying this midpoint shifts +-- the range to a new midpoint, preserving the size. +-- +-- @ +-- view rMid (R 2 4) +-- -- 3 +-- over rMid (+ 3) (R 2 4) +-- -- R 5 7 +-- @ +rMid :: Fractional a => Lens' (Range a) a +rMid f (RAbout m s) = (`RAbout` s) <$> f m + +-- | Check if a point is within the 'Range' (inclusive). +within :: Ord a => a -> Range a -> Bool +within x r = x >= r ^. rMin && x <= r ^. rMax + +-- | Lens into a 'PlotOpts' getting its range X and range Y settings. +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) + +-- | Lens into microsecond delay between frames, specified by a 'PlotOpts'. +poDelay :: Lens' PlotOpts (Maybe Int) +poDelay = poFramerate . hzToDelay + +-- | Used for 'poDelay': a lens into a microsecond delay given +-- a framerate. Should technically be an isomorphism, but this isn't +-- supported by microlens. +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 + +-- | Compute plot axis ranges based on a list of points and the size of the +-- display region. +plotRange + :: PlotOpts + -> Coord (Range Int) -- ^ display region + -> [Series] -- ^ Points + -> Coord (Range Double) -- ^ actual plot axis range +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 + -- TODO: can this be computed only for points in view? + 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 + +-- | Render serieses based on a display region and plot axis ranges. +renderPlot + :: Coord (Range Int) -- ^ display region + -> Coord (Range Double) -- ^ plot axis range + -> [Series] + -> [Image] +renderPlot dr pr = overlayAxis dr pr + . concatMap (renderSeries dr pr) + +overlayAxis + :: Coord (Range Int) -- ^ display region + -> Coord (Range Double) -- ^ plot axis range + -> [Image] -- ^ thing to overlay over + -> [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) -- ^ Display region + -> Coord (Range Double) -- ^ Plot axis range + -> Coord Alignment -- ^ Alignment + -> Coord Double -- ^ Position in plot space + -> Image -- ^ Image to place + -> 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 -- ^ input range + -> Range a -- ^ output range + -> a + -> a +lerp rOld rNew x = + rNew ^. rMin + (x - rOld ^. rMin) / (rOld ^. rSize) * (rNew ^. rSize) + +-- | Render a single series as a set of points. +renderSeries + :: Coord (Range Int) -- ^ Display region + -> Coord (Range Double) -- ^ Plot axis range + -> Series -- ^ Series to plot + -> [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' + +-- | Turn a set of coordinates into a map of x's to the y's found in +-- the set. +-- +-- Note that this forms an isomorphism with 'fromCoordMap'. +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:))]) + +-- | Convert a map of x's to y's into a set of x-y coordinates. +-- +-- Note that this forms an isomorphism with 'toCoordMap'. +fromCoordMap + :: M.Map a (S.Set a) + -> S.Set (Coord a) +fromCoordMap = S.fromDistinctAscList + . M.foldMapWithKey (\k -> foldMap ((:[]) . C k)) + +-- | Render a single according to a 'PointStyle'. +renderPoint + :: PointStyle + -> Image +renderPoint PointStyle{..} = char (defAttr `withForeColor` _psColor) _psMarker diff --git a/src/Interactive/Plot/Run.hs b/src/Interactive/Plot/Run.hs new file mode 100644 --- /dev/null +++ b/src/Interactive/Plot/Run.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Interative.Plot.Run +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Run plots interactively in the terminal. +module Interactive.Plot.Run ( + -- * Simple + runPlot + , runPlotAuto + -- * Animated + , animatePlot, lastForever + , animatePlotFunc + , animatePlotMoore, Moore(..) + -- * Custom + , 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) + +-- | Dynamically adjustable plot data. +data PlotData = PlotData + { _pdTitle :: Maybe String + , _pdDesc :: Maybe Image + , _pdSerieses :: [Series] + } + +-- | Getter/setter lens to the title field of a 'PlotData' +pdTitle :: Lens' PlotData (Maybe String) +pdTitle f (PlotData x y z) = (\x' -> PlotData x' y z) <$> f x + +-- | Getter/setter lens to the description box field of a 'PlotData' +pdDesc :: Lens' PlotData (Maybe Image) +pdDesc f (PlotData x y z) = (\y' -> PlotData x y' z) <$> f y + +-- | Getter/setter lens to the serieses field of a 'PlotData' +pdSerieses :: Lens' PlotData [Series] +pdSerieses f (PlotData x y z) = PlotData x y <$> f z + +-- | Display fixed plot and title interactively, filling in default values. +-- +-- See 'runPlotDynamic' for more control. +runPlotAuto + :: PlotOpts -- ^ options (can be 'defaultPlotOpts') + -> Maybe String -- ^ title + -> [AutoSeries] -- ^ uninitialized series data + -> IO () +runPlotAuto po t s = case po ^. poAutoMethod of + Nothing -> runPlot po t =<< fromAutoSeriesIO s + Just g -> runPlot po t $ fromAutoSeries_ g s + +-- | Display fixed plot and title interactively. +-- +-- See 'runPlotDynamic' for more control. +runPlot + :: PlotOpts -- ^ options (can be 'defaultPlotOpts') + -> Maybe String -- ^ title + -> [Series] -- ^ series data + -> IO () +runPlot po t s = runPlotDynamic po + (const (pure True)) + (pure (Just (PlotData t (_poDescription po) s))) + +-- | Display a series of plots (@['Series']@) with a time delay between +-- each one. Will quit when the last plot is displayed. Use 'lastForever' +-- on the input list to repeat the last item indefinitely, or 'cycle' to +-- cycle through the list forever. +-- +-- Note that this behavior is pretty simple; more advanced functionality +-- can be achieved with 'runPlotDynamic' directly. +animatePlot + :: PlotOpts -- ^ options (can be 'defaultPlotOpts') + -> Double -- ^ update rate (frames per second) + -> Maybe String -- ^ title + -> [[Series]] -- ^ list of series data (potentially infinite) + -> 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 + +-- | Handy function to use with 'animatePlot' to extend the last frame into +-- eternity. +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) + + +-- | Animate (according to the framerate in the 'PlotOpts') a function +-- @'Double' -> 'Maybe' [Series]@, where the input is the current time in +-- seconds and the output is the plot to display at that time. Will quit +-- as soon as 'Nothing' is given. +-- +-- Remember to give a 'PlotOpts' with a 'Just' framerate. +-- +-- This is a simple wrapper over 'animatePlotMoore' with a stateless +-- function. For more advanced functionality, use 'animatePlotMoore' or +-- 'runPlotDynamic' directly. +animatePlotFunc + :: PlotOpts -- ^ options (can be 'defaultPlotOpts', but remember to set a framerate) + -> Maybe String -- ^ title + -> (Double -> Maybe [Series]) -- ^ function from time to plot. will quit as soon as 'Nothing' is returned. + -> 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' + } + +-- | Used for 'animatePlotMoore' to specify how a plot evolves over time +-- with some initial state. +data Moore a = forall s. Moore + { -- | initial value of plot. 'Nothing' for a non-starter. + moInitVal :: Maybe a + -- | initial state of plot + , moInitState :: s + -- | Given change in time since last render and old state, return new + -- plot and state. Return 'Nothing' to quit. + , moUpdate :: Double -> s -> IO (Maybe (a, s)) + } + +deriving instance Functor Moore + +-- | Animate (according to the framerate in the 'PlotOpts') a "Moore +-- machine" description of a plot evolving over time with some initial +-- state. +-- +-- Remember to give a 'PlotOpts' with a 'Just' framerate. +-- +-- For a simplified version of a stateless function, see 'animatePlotFunc'. +-- This is implemented in terms of 'runPlotDynamic', but the representation +-- of an animation in terms of a moore machine is powerful enough to +-- represent a very general class of animations. +animatePlotMoore + :: PlotOpts -- ^ options (can be 'defaultPlotOpts', but remember to set a framerate) + -> Maybe String -- ^ title + -> Moore [Series] -- ^ moore machine representing progression of plot from an initial state + -> 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 + + +-- | Version of 'runPlot' that allows you to vary the plotted data and the +-- title. It will execute the @'IO' PlotData@ to get the current plot +-- data; you can use this with i.e. an 'IORef' to adjust the data in +-- real-time. +runPlotDynamic + :: PlotOpts + -> (Event -> IO Bool) -- ^ process VTY events (return 'False' to trigger quit) + -> IO (Maybe PlotData) -- ^ action to "get" the plot data every frame. if 'Nothing', quit. + -> 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 ] + ] diff --git a/src/Interactive/Plot/Series.hs b/src/Interactive/Plot/Series.hs new file mode 100644 --- /dev/null +++ b/src/Interactive/Plot/Series.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Interative.Plot.Series +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Create common serieses. +module Interactive.Plot.Series ( + Series, AutoSeries, SeriesF(..) + , PointStyle, AutoPointStyle, PointStyleF(..) + -- * Create common 'Series' + , listSeries + , tupleSeries + , funcSeries + , enumRange + -- * Create a 'Series' from an 'AutoSeries'. + , fromAutoSeries + , fromAutoSeriesIO + , fromAutoSeries_ + , defaultStyles + ) where + +import Control.Monad.Random +import Control.Monad.State +import Data.Foldable +import Data.Maybe +import Graphics.Vty +import Interactive.Plot.Core +import Lens.Micro +import qualified Data.Set as S + +-- | Construct a series from any foldable container of y-values. The +-- x-values are automatically assigned to 0, 1, 2, 3 ... etc. +-- +-- Note that this is polymorphic over both 'PointStyle' and +-- 'AutoPointStyle': +-- +-- @ +-- 'listSeries' :: Foldable t => t Double -> 'PointStyle' -> 'Series' +-- 'listSeries' :: Foldable t => t Double -> 'AutoPointStyle' -> 'AutoSeries' +-- @ +listSeries :: Foldable t => t Double -> PointStyleF f -> SeriesF f +listSeries xs = Series (toCoordMap . S.fromList . zipWith C [0..] . toList $ xs) + +-- | Construct a series from any foldable container of x-y tuples. +-- +-- Note that this is polymorphic over both 'PointStyle' and +-- 'AutoPointStyle': +-- +-- @ +-- 'tupleSeries' :: Foldable t => t (Double, Double) -> 'PointStyle' -> 'Series' +-- 'tupleSeries' :: Foldable t => t (Double, Double) -> 'AutoPointStyle' -> 'AutoSeries' +-- @ +tupleSeries :: Foldable t => t (Double, Double) -> PointStyleF f -> SeriesF f +tupleSeries xs = Series (toCoordMap . S.fromList . foldMap ((:[]) . uncurry C) $ xs) + +-- | @'enumRange' n ('R' a b)@ generates a list of @n@ equally spaced values +-- between @a@ and @b@. +enumRange + :: Fractional a + => Int -- ^ Number of points + -> Range a -- ^ Range to generate the points over + -> [a] +enumRange n r = (+ r ^. rMin) . (* s) . fromIntegral <$> [0 .. (n - 1)] + where + s = r ^. rSize / fromIntegral (n - 1) + +-- | Construct a series from a function x to y, given a foldable container +-- of x values. +-- +-- Note that this is polymorphic over both 'PointStyle' and +-- 'AutoPointStyle': +-- +-- @ +-- 'funcSeries' :: Foldable t => (Double -> Double) -> t Double -> 'PointStyle' -> 'Series' +-- 'funcSeries' :: Foldable t => (Double -> Double) -> t Double -> 'AutoPointStyle' -> 'AutoSeries' +-- @ +funcSeries + :: Foldable t + => (Double -> Double) + -> t Double + -> PointStyleF f + -> SeriesF f +funcSeries f xs = tupleSeries [ (x, f x) | x <- toList xs ] + +-- | A set of default markers. +defaultMarkers :: S.Set Char +defaultMarkers = S.fromList "o*+~.,=#`x-" + +-- | A set of default colors. +defaultColors :: S.Set OrdColor +defaultColors = S.fromList $ OC <$> [white, yellow, blue, red, green, cyan, magenta] + +-- | A set of default point styles +defaultStyles :: S.Set PointStyle +defaultStyles = combinePointStyles defaultMarkers defaultColors + +combinePointStyles + :: S.Set Char + -> S.Set OrdColor + -> S.Set PointStyle +combinePointStyles ms cs = combine `S.map` S.cartesianProduct ms cs + where + combine (m, OC c) = PointStyle m c + +-- | Turn an 'AutoSeries' into a 'Series', assigning styles from +-- a pre-specified "shuffled" order. +fromAutoSeries :: [AutoSeries] -> [Series] +fromAutoSeries = fromAutoSeries_ $ + fromMaybe (mkStdGen 28922710942259) (_poAutoMethod defaultPlotOpts) + +-- | Turn an 'AutoSeries' into a 'Series', drawing styles randomly in IO. +fromAutoSeriesIO :: [AutoSeries] -> IO [Series] +fromAutoSeriesIO as = (`fromAutoSeries_` as) <$> getStdGen + +-- | Turn an 'AutoSeries' into a 'Series', shuffling the default styles in +-- a deterministic way from a given seed. +fromAutoSeries_ :: StdGen -> [AutoSeries] -> [Series] +fromAutoSeries_ seed = flip evalRand seed . flip evalStateT S.empty . mapM go + where + go :: AutoSeries -> StateT (S.Set PointStyle) (Rand StdGen) Series + go (Series is ps) = Series is <$> pickPs + where + pickPs = case ps of + PointStyleF Auto Auto -> do + picked <- get + samp <- sampleSet $ defaultStyles S.\\ picked + case samp of + Nothing -> fromJust <$> sampleSet defaultStyles + Just s -> s <$ put (s `S.insert` picked) + PointStyleF (Given m) Auto -> do + picked <- get + let allDefaults = combinePointStyles (S.singleton m) defaultColors + samp <- sampleSet $ allDefaults S.\\ picked + case samp of + Nothing -> fromJust <$> sampleSet allDefaults + Just s -> s <$ put (s `S.insert` picked) + PointStyleF Auto (Given c) -> do + picked <- get + let allDefaults = combinePointStyles defaultMarkers (S.singleton (OC c)) + samp <- sampleSet $ allDefaults S.\\ picked + case samp of + Nothing -> fromJust <$> sampleSet allDefaults + Just s -> s <$ put (s `S.insert` picked) + PointStyleF (Given m) (Given c) -> pure $ PointStyle m c + +sampleSet + :: (MonadRandom m) + => S.Set a + -> m (Maybe a) +sampleSet xs + | S.null xs = pure Nothing + | otherwise = do + i <- getRandomR (0, S.size xs - 1) + pure $ Just (i `S.elemAt` xs) +