{-# LANGUAGE BangPatterns           #-}
{-# LANGUAGE ViewPatterns           #-}
{-# LANGUAGE DeriveDataTypeable     #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Plots.Types.HeatMap
-- Copyright   :  (C) 2016 Christopher Chalmers
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Christopher Chalmers
-- Stability   :  experimental
-- Portability :  non-portable
--
-- A heat map is a graphical representation of data where the individual
-- values contained in a matrix are represented as colours.
--
-- <<diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample.svg#diagram=heatMapIndexedExample&height=350>>
--
-- (see 'heatMapIndexed' example for code to make this plot)
--
----------------------------------------------------------------------------

module Plots.Types.HeatMap
  ( -- * Heat map
    HeatMap
  , heatMap
  , heatMap'
  , heatMapIndexed
  , heatMapIndexed'

  -- * Lenses
  , HasHeatMap (..)

  -- ** Rendering functions
  , pathHeatRender
  , pixelHeatRender
  , pixelHeatRender'

  -- * Heat matrix
  , HeatMatrix
  , heatImage
  , hmPoints
  , hmSize

  -- * Low level construction
  , mkHeatMap
  , mkHeatMatrix
  , mkHeatMatrix'

  ) where

import           Control.Lens                    hiding (transform, ( # ))

import           Control.Monad.ST
import           Control.Monad.State
import qualified Data.Foldable                   as F
import           Data.Typeable
import qualified Data.Vector.Generic.Mutable     as M
import qualified Data.Vector.Storable            as S
import qualified Data.Vector.Unboxed             as V
import           Data.Word                       (Word8)

import           Codec.Picture
import           Diagrams.Coordinates.Isomorphic
import           Diagrams.Prelude

import           Plots.Axis
import           Plots.Style
import           Plots.Types

------------------------------------------------------------------------
-- Heatmap
------------------------------------------------------------------------

-- | 2D Array of 'Double's.
data HeatMatrix = HeatMatrix
  { HeatMatrix -> V2 Int
hmSize       :: {-# UNPACK #-} !(V2 Int)
    -- ^ The size of heat matrix.
  , HeatMatrix -> Vector Double
_hmVector    :: {-# UNPACK #-} !(V.Vector Double)
  , HeatMatrix -> Double
hmBoundLower :: {-# UNPACK #-} !Double
  , HeatMatrix -> Double
hmBoundUpper :: {-# UNPACK #-} !Double
  }

-- | Construct a heat matrix from a size and a generating function.
mkHeatMatrix :: V2 Int -> (V2 Int -> Double) -> HeatMatrix
mkHeatMatrix :: V2 Int -> (V2 Int -> Double) -> HeatMatrix
mkHeatMatrix s :: V2 Int
s@(V2 Int
x Int
y) V2 Int -> Double
f = (forall s. ST s HeatMatrix) -> HeatMatrix
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s HeatMatrix) -> HeatMatrix)
-> (forall s. ST s HeatMatrix) -> HeatMatrix
forall a b. (a -> b) -> a -> b
$ do
  MVector s Double
mv <- Int -> ST s (MVector (PrimState (ST s)) Double)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
M.new (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y)

  let go :: Int -> Double -> Double -> Int -> Int -> ST s HeatMatrix
go !Int
q !Double
a !Double
b !Int
i !Int
j
        | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y    = do Vector Double
v <- MVector (PrimState (ST s)) Double -> ST s (Vector Double)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Double
MVector (PrimState (ST s)) Double
mv
                         HeatMatrix -> ST s HeatMatrix
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (V2 Int -> Vector Double -> Double -> Double -> HeatMatrix
HeatMatrix V2 Int
s Vector Double
v Double
a Double
b)
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x    = Int -> Double -> Double -> Int -> Int -> ST s HeatMatrix
go Int
q Double
a Double
b Int
0 (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = do let !d :: Double
d = V2 Int -> Double
f (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
i Int
j)
                         MVector (PrimState (ST s)) Double -> Int -> Double -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Double
MVector (PrimState (ST s)) Double
mv Int
q Double
d
                         Int -> Double -> Double -> Int -> Int -> ST s HeatMatrix
go (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
a Double
d) (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
b Double
d) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
j

  Int -> Double -> Double -> Int -> Int -> ST s HeatMatrix
go Int
0 (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) Int
0 Int
0
{-# INLINE mkHeatMatrix #-}

min' :: Double -> Double -> Double
min' :: Double -> Double -> Double
min' !Double
a !Double
b
  | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
b      = Double
a
  | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
b = Double
a
  | Bool
otherwise    = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
a Double
b
{-# INLINE min' #-}

max' :: Double -> Double -> Double
max' :: Double -> Double -> Double
max' !Double
a !Double
b
  | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
b      = Double
a
  | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
b = Double
a
  | Bool
otherwise    = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
a Double
b
{-# INLINE max' #-}

data MM = MM {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | Compute the minimum and maximum of a vector in one pass. This
--   ignores any @Infinity@ or @NaN@ values (since these make no sense
--   for colour bar ranges).
minMax :: V.Vector Double -> (Double, Double)
minMax :: Vector Double -> (Double, Double)
minMax = MM -> (Double, Double)
fini (MM -> (Double, Double))
-> (Vector Double -> MM) -> Vector Double -> (Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MM -> Double -> MM) -> MM -> Vector Double -> MM
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
V.foldl' MM -> Double -> MM
go (Double -> Double -> MM
MM (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0))
  where
    go :: MM -> Double -> MM
go (MM Double
lo Double
hi) Double
k = Double -> Double -> MM
MM (Double -> Double -> Double
min' Double
lo Double
k) (Double -> Double -> Double
max' Double
hi Double
k)
    fini :: MM -> (Double, Double)
fini (MM Double
lo Double
hi) = (Double
lo, Double
hi)
{-# INLINE minMax #-}

-- | Construct a heat matrix from a foldable of foldables.
--
-- @
-- 'mkHeatMatrix'' :: [['Double']] -> 'HeatMatrix'
-- 'mkHeatMatrix'' :: ['Vector' 'Double'] -> 'HeatMatrix'
-- @
mkHeatMatrix' :: (F.Foldable f, F.Foldable g) => f (g Double) -> HeatMatrix
mkHeatMatrix' :: forall (f :: * -> *) (g :: * -> *).
(Foldable f, Foldable g) =>
f (g Double) -> HeatMatrix
mkHeatMatrix' f (g Double)
xss = V2 Int -> Vector Double -> Double -> Double -> HeatMatrix
HeatMatrix (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
x Int
y) Vector Double
vd Double
a Double
b
  where
  (Double
a,Double
b) = Vector Double -> (Double, Double)
minMax Vector Double
vd
  vd :: Vector Double
vd = (forall s. ST s (MVector s Double)) -> Vector Double
forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s Double)) -> Vector Double)
-> (forall s. ST s (MVector s Double)) -> Vector Double
forall a b. (a -> b) -> a -> b
$ do
    MVector s Double
mv <- Int -> ST s (MVector (PrimState (ST s)) Double)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
M.new (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y)
    let go :: Int -> [Vector Double] -> ST s (MVector s Double)
go !Int
_ []     = MVector s Double -> ST s (MVector s Double)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Double
mv
        go  Int
j (Vector Double
r:[Vector Double]
rs) = MVector (PrimState (ST s)) Double -> Vector Double -> ST s ()
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> Vector a -> m ()
V.unsafeCopy (Int -> Int -> MVector s Double -> MVector s Double
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
M.unsafeSlice (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x) Int
x MVector s Double
mv) Vector Double
r ST s () -> ST s (MVector s Double) -> ST s (MVector s Double)
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> [Vector Double] -> ST s (MVector s Double)
go (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Vector Double]
rs
    Int -> [Vector Double] -> ST s (MVector s Double)
go (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Vector Double]
vs
  -- vs is in reverse since we used foldl' to build it
  (!Int
x,!Int
y,![Vector Double]
vs) = ((Int, Int, [Vector Double])
 -> g Double -> (Int, Int, [Vector Double]))
-> (Int, Int, [Vector Double])
-> f (g Double)
-> (Int, Int, [Vector Double])
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (Int, Int, [Vector Double])
-> g Double -> (Int, Int, [Vector Double])
forall {a} {t :: * -> *} {b}.
(Unbox a, Foldable t, Num b) =>
(Int, b, [Vector a]) -> t a -> (Int, b, [Vector a])
f (Int
forall a. Bounded a => a
maxBound,Int
0,[]) f (g Double)
xss
  f :: (Int, b, [Vector a]) -> t a -> (Int, b, [Vector a])
f (!Int
i,!b
j,![Vector a]
ss) t a
xs = let !v :: Vector a
v = [a] -> Vector a
forall a. Unbox a => [a] -> Vector a
V.fromList (t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
xs)
                     in  (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
i (Vector a -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector a
v), b
jb -> b -> b
forall a. Num a => a -> a -> a
+b
1, Vector a
v Vector a -> [Vector a] -> [Vector a]
forall a. a -> [a] -> [a]
: [Vector a]
ss)

-- | Indexed traversal over the values of a 'HeatMatrix'.
hmPoints :: IndexedTraversal' (V2 Int) HeatMatrix Double
hmPoints :: IndexedTraversal' (V2 Int) HeatMatrix Double
hmPoints p Double (f Double)
f (HeatMatrix e :: V2 Int
e@(V2 Int
x Int
y) Vector Double
v Double
a Double
b) =
  Int -> Int -> Int -> f [Double]
go Int
0 Int
0 Int
0 f [Double] -> ([Double] -> HeatMatrix) -> f HeatMatrix
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Double]
vs ->
    let v' :: Vector Double
v'= Int -> [Double] -> Vector Double
forall a. Unbox a => Int -> [a] -> Vector a
V.fromListN (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y) [Double]
vs
    in  V2 Int -> Vector Double -> Double -> Double -> HeatMatrix
HeatMatrix V2 Int
e Vector Double
v' Double
a Double
b
  where
    -- V2 x y = hmExtent
    go :: Int -> Int -> Int -> f [Double]
go !Int
s !Int
i !Int
j
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x    = Int -> Int -> Int -> f [Double]
go Int
s Int
0 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
y    = [Double] -> f [Double]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = (:) (Double -> [Double] -> [Double])
-> f Double -> f ([Double] -> [Double])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p Double (f Double) -> V2 Int -> Double -> f Double
forall a b. p a b -> V2 Int -> a -> b
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p Double (f Double)
f (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
i Int
j) (Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Double
v Int
s)
                        f ([Double] -> [Double]) -> f [Double] -> f [Double]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> Int -> f [Double]
go (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j
{-# INLINE [0] hmPoints #-}

{-# RULES
  "hmPoints/foldr"
  hmPoints = ifoldring hmFold :: Getting (Endo r) HeatMatrix Double;
  "hmPoints/ifoldr"
  hmPoints = ifoldring hmFold :: IndexedGetting (V2 Int) (Endo r) HeatMatrix Double
 #-}

hmFold :: (V2 Int -> Double -> b -> b) -> b -> HeatMatrix -> b
hmFold :: forall b. (V2 Int -> Double -> b -> b) -> b -> HeatMatrix -> b
hmFold V2 Int -> Double -> b -> b
f b
b0 (HeatMatrix (V2 Int
x Int
y) Vector Double
v Double
_ Double
_) = Int -> Int -> Int -> b -> b
go Int
0 Int
0 Int
0 b
b0 where
  go :: Int -> Int -> Int -> b -> b
go !Int
s !Int
i !Int
j b
b
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x    = Int -> Int -> Int -> b -> b
go Int
s Int
0 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) b
b
    | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
y    = b
b
    | Bool
otherwise = V2 Int -> Double -> b -> b
f (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
i Int
j) (Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Double
v Int
s) (Int -> Int -> Int -> b -> b
go (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j b
b)
{-# INLINE hmFold #-}

-- Rendering heat matrices --------------------------------------------

-- | Render an heatmap as an 'ImageRGB8'.
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample.svg#diagram=pixelHeatRenderExample&height=350>>
--
-- > import Plots
-- >
-- > pixelHeatRenderExample =
-- >   let f (V2 x y) = fromIntegral x + fromIntegral y
-- >       myHM       = mkHeatMatrix (V2 5 5) f
-- >   in  pixelHeatRender myHM viridis
--
pixelHeatRender
  :: (Renderable (DImage n Embedded) b, TypeableFloat n)
  => HeatMatrix
  -> ColourMap
  -> QDiagram b V2 n Any
pixelHeatRender :: forall n b.
(Renderable (DImage n Embedded) b, TypeableFloat n) =>
HeatMatrix -> ColourMap -> QDiagram b V2 n Any
pixelHeatRender HeatMatrix
hm ColourMap
cm =
  QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignBL (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (DImage n Embedded -> QDiagram b V2 n Any)
-> DImage n Embedded
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DImage n Embedded -> QDiagram b V2 n Any
forall n a b.
(TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>
DImage n a -> QDiagram b V2 n Any
image (DImage n Embedded -> QDiagram b V2 n Any)
-> DImage n Embedded -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ ImageData Embedded
-> Int -> Int -> Transformation V2 n -> DImage n Embedded
forall b a.
ImageData b -> Int -> Int -> Transformation V2 a -> DImage a b
DImage (DynamicImage -> ImageData Embedded
ImageRaster (Image PixelRGB8 -> DynamicImage
ImageRGB8 Image PixelRGB8
img)) Int
x Int
y Transformation V2 n
forall a. Monoid a => a
mempty
  where
    img :: Image PixelRGB8
img    = HeatMatrix -> ColourMap -> Image PixelRGB8
heatImage HeatMatrix
hm ColourMap
cm
    V2 Int
x Int
y = HeatMatrix -> V2 Int
hmSize HeatMatrix
hm

-- | Render an heatmap as an 'ImageRGB8' with @n@ pixels per heat matrix
--   point.
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample'.svg#diagram=pixelHeatRenderExample'&height=350>>
--
-- > import Plots
-- >
-- > pixelHeatRenderExample' =
-- >   let f (V2 x y) = fromIntegral x + fromIntegral y
-- >       myHM       = mkHeatMatrix (V2 5 5) f
-- >   in  pixelHeatRender' 10 myHM viridis
--
pixelHeatRender'
  :: (Renderable (DImage n Embedded) b, TypeableFloat n)
  => Int
  -> HeatMatrix
  -> ColourMap
  -> QDiagram b V2 n Any
pixelHeatRender' :: forall n b.
(Renderable (DImage n Embedded) b, TypeableFloat n) =>
Int -> HeatMatrix -> ColourMap -> QDiagram b V2 n Any
pixelHeatRender' Int
n HeatMatrix
hm ColourMap
cm =
  n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale (n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (DImage n Embedded -> QDiagram b V2 n Any)
-> DImage n Embedded
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignBL (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (DImage n Embedded -> QDiagram b V2 n Any)
-> DImage n Embedded
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DImage n Embedded -> QDiagram b V2 n Any
forall n a b.
(TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>
DImage n a -> QDiagram b V2 n Any
image (DImage n Embedded -> QDiagram b V2 n Any)
-> DImage n Embedded -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ ImageData Embedded
-> Int -> Int -> Transformation V2 n -> DImage n Embedded
forall b a.
ImageData b -> Int -> Int -> Transformation V2 a -> DImage a b
DImage (DynamicImage -> ImageData Embedded
ImageRaster (Image PixelRGB8 -> DynamicImage
ImageRGB8 Image PixelRGB8
img)) (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) Transformation V2 n
forall a. Monoid a => a
mempty
  where
    img :: Image PixelRGB8
img    = Int -> Image PixelRGB8 -> Image PixelRGB8
scaleImage Int
n (Image PixelRGB8 -> Image PixelRGB8)
-> Image PixelRGB8 -> Image PixelRGB8
forall a b. (a -> b) -> a -> b
$ HeatMatrix -> ColourMap -> Image PixelRGB8
heatImage HeatMatrix
hm ColourMap
cm
    V2 Int
x Int
y = HeatMatrix -> V2 Int
hmSize HeatMatrix
hm

-- | Scale an image so each pixel takes (n*n) pixels. This can be
--   useful for using 'heatImage' on small heat matrices to give a
--   sharper image.
scaleImage :: Int -> Image PixelRGB8 -> Image PixelRGB8
scaleImage :: Int -> Image PixelRGB8 -> Image PixelRGB8
scaleImage Int
n Image PixelRGB8
img | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  = Image PixelRGB8
img
                 | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
0 Int
0 Vector Word8
Vector (PixelBaseComponent PixelRGB8)
forall a. Storable a => Vector a
S.empty
                 | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0  = [Char] -> Image PixelRGB8
forall a. HasCallStack => [Char] -> a
error [Char]
"scaleImage: negative scale"
scaleImage Int
n (Image Int
x Int
y Vector (PixelBaseComponent PixelRGB8)
v) = Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y) Vector Word8
Vector (PixelBaseComponent PixelRGB8)
vn where
  !refV :: Vector Int
refV = [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
V.fromList ([Int] -> Vector Int) -> [Int] -> Vector Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
3) [ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
j | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
  !n3 :: Int
n3 = Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n
  vn :: Vector Word8
vn = (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
S.create ((forall s. ST s (MVector s Word8)) -> Vector Word8)
-> (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
    MVector s Word8
mv <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
M.new (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Vector Word8 -> Int
forall a. Storable a => Vector a -> Int
S.length Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v)
    let go :: Int -> Int -> Int -> ST s (MVector s Word8)
go !Int
q !Int
i !Int
s | Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y = MVector s Word8 -> ST s (MVector s Word8)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Word8
mv
                    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x     = Int -> Int -> Int -> ST s (MVector s Word8)
go Int
q Int
0 (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
        go  Int
q  Int
i  Int
s              = do
          let !r :: Word8
r = Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
S.unsafeIndex Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v  Int
q
              !g :: Word8
g = Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
S.unsafeIndex Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              !b :: Word8
b = Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
S.unsafeIndex Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
          Vector Int -> (Int -> ST s ()) -> ST s ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Vector a -> (a -> m b) -> m ()
V.forM_ Vector Int
refV ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
ds -> do
            MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ds    ) Word8
r
            MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
g
            MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8
b
          Int -> Int -> Int -> ST s (MVector s Word8)
go (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n3)

    Int -> Int -> Int -> ST s (MVector s Word8)
go Int
0 Int
0 Int
0

-- | Create an image of 'PixelsRGB8' using the heat matrix.
heatImage :: HeatMatrix -> ColourMap -> Image PixelRGB8
heatImage :: HeatMatrix -> ColourMap -> Image PixelRGB8
heatImage (HeatMatrix (V2 Int
x Int
y) Vector Double
dv Double
a Double
b) ColourMap
cm = Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
x Int
y Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v where
  !cv :: Vector Word8
cv = ColourMap -> Vector Word8
mkColourVector ColourMap
cm

  v :: S.Vector Word8
  v :: Vector Word8
v = (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
S.create ((forall s. ST s (MVector s Word8)) -> Vector Word8)
-> (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
    MVector s Word8
mv <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
M.new (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y)
    let !m :: Double
m = Double
256 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a)
        writeColour :: Int -> Colour Double -> ST s ()
writeColour Int
q (Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 -> RGB Word8
rr Word8
gg Word8
bb) = do
          MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv  Int
q    Word8
rr
          MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Word8
gg
          MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Word8
bb

        colourValue :: Int -> Double -> ST s ()
colourValue !Int
q !Double
d
          | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d      = Int -> Colour Double -> ST s ()
writeColour Int
q (ColourMap
cmColourMap
-> Getting (Colour Double) ColourMap (Colour Double)
-> Colour Double
forall s a. s -> Getting a s a -> a
^.Getting (Colour Double) ColourMap (Colour Double)
forall a. HasNanColours a => Lens' a (Colour Double)
Lens' ColourMap (Colour Double)
nanColour)
          | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d = Int -> Colour Double -> ST s ()
writeColour Int
q (if Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then ColourMap
cmColourMap
-> Getting (Colour Double) ColourMap (Colour Double)
-> Colour Double
forall s a. s -> Getting a s a -> a
^.Getting (Colour Double) ColourMap (Colour Double)
forall a. HasNanColours a => Lens' a (Colour Double)
Lens' ColourMap (Colour Double)
negInfColour else ColourMap
cmColourMap
-> Getting (Colour Double) ColourMap (Colour Double)
-> Colour Double
forall s a. s -> Getting a s a -> a
^.Getting (Colour Double) ColourMap (Colour Double)
forall a. HasNanColours a => Lens' a (Colour Double)
Lens' ColourMap (Colour Double)
infColour)
          | Bool
otherwise    = do
              let !o :: Int
o = Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (Int -> Int) -> (Double -> Int) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (Double -> Int) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m)
              MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv  Int
q    (Vector Word8 -> Int -> Word8
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Word8
cv  Int
o   )
              MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Vector Word8 -> Int -> Word8
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Word8
cv (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
              MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) (Vector Word8 -> Int -> Word8
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Word8
cv (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2))

        go :: Int -> Int -> Int -> ST s (MVector s Word8)
go Int
s Int
i Int
q
          | Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1  = do
              let d :: Double
d = Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Double
dv Int
s
              Int -> Double -> ST s ()
colourValue Int
q Double
d
              MVector s Word8 -> ST s (MVector s Word8)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Word8
mv
          | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x    = Int -> Int -> Int -> ST s (MVector s Word8)
go (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x) Int
0 Int
q
          | Bool
otherwise = do
              let d :: Double
d = Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
V.unsafeIndex Vector Double
dv Int
s
              Int -> Double -> ST s ()
colourValue Int
q Double
d
              Int -> Int -> Int -> ST s (MVector s Word8)
go (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3)
    Int -> Int -> Int -> ST s (MVector s Word8)
go (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int
0 Int
0

-- Make an unboxed colour map using 256 samples.
mkColourVector :: ColourMap -> V.Vector Word8
mkColourVector :: ColourMap -> Vector Word8
mkColourVector ColourMap
cm = (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s Word8)) -> Vector Word8)
-> (forall s. ST s (MVector s Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
  MVector s Word8
mv <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
M.new (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
256)

  let go :: Int -> ST s (MVector s Word8)
go Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
256 = MVector s Word8 -> ST s (MVector s Word8)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Word8
mv
           | Bool
otherwise  = do
               let x :: Rational
x = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
3Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
256)
                   RGB Word8
r Word8
g Word8
b = ColourMap
cm ColourMap -> Getting (RGB Word8) ColourMap (RGB Word8) -> RGB Word8
forall s a. s -> Getting a s a -> a
^. Rational -> Lens' ColourMap (Colour Double)
ixColourR Rational
x ((Colour Double -> Const (RGB Word8) (Colour Double))
 -> ColourMap -> Const (RGB Word8) ColourMap)
-> ((RGB Word8 -> Const (RGB Word8) (RGB Word8))
    -> Colour Double -> Const (RGB Word8) (Colour Double))
-> Getting (RGB Word8) ColourMap (RGB Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Colour Double -> RGB Word8)
-> (RGB Word8 -> Const (RGB Word8) (RGB Word8))
-> Colour Double
-> Const (RGB Word8) (Colour Double)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24
               MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv  Int
i    Word8
r
               MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Word8
g
               MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
M.unsafeWrite MVector s Word8
MVector (PrimState (ST s)) Word8
mv (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Word8
b
               Int -> ST s (MVector s Word8)
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3)

  Int -> ST s (MVector s Word8)
go Int
0

-- | Render the heat map as a collection squares made up of 'Trail's.
--   This method is compatible with all backends and should always look
--   sharp. However it can become slow and large for large heat maps.
--
--   It is recommended to use 'pathHeatRender' for small heat maps and
--   'pixelHeatRender' for larger ones.
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_pathHeatRenderExample.svg#diagram=pathHeatRenderExample&height=350>>
--
-- > import Plots
-- >
-- > pathHeatRenderExample =
-- >   let f (V2 x y) = fromIntegral x + fromIntegral y
-- >       myHM       = mkHeatMatrix (V2 5 5) f
-- >   in  pathHeatRender myHM viridis
--
pathHeatRender
  :: (Renderable (Path V2 n) b, TypeableFloat n)
  => HeatMatrix
  -> ColourMap
  -> QDiagram b V2 n Any
pathHeatRender :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
HeatMatrix -> ColourMap -> QDiagram b V2 n Any
pathHeatRender hm :: HeatMatrix
hm@(HeatMatrix V2 Int
_ Vector Double
_ Double
a Double
b) ColourMap
cm = IndexedGetting (V2 Int) (QDiagram b V2 n Any) HeatMatrix Double
-> (V2 Int -> Double -> QDiagram b V2 n Any)
-> HeatMatrix
-> QDiagram b V2 n Any
forall i m s a. IndexedGetting i m s a -> (i -> a -> m) -> s -> m
ifoldMapOf IndexedGetting (V2 Int) (QDiagram b V2 n Any) HeatMatrix Double
IndexedTraversal' (V2 Int) HeatMatrix Double
hmPoints V2 Int -> Double -> QDiagram b V2 n Any
mk HeatMatrix
hm QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a n. (N a ~ n, HasStyle a, Typeable n) => n -> a -> a
lwO n
0
  where
    normalise :: Double -> Double
normalise Double
d = (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a)
    mk :: V2 Int -> Double -> QDiagram b V2 n Any
mk v :: V2 Int
v@(V2 Int
i Int
j) Double
d =
      n -> n -> QDiagram b V2 n Any
forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
w n
h
        # alignTR
        # translate (fromIntegral <$> v ^+^ 1)
        # fc (cm ^. ixColour (normalise d))
      where
        -- Squares that are not on the top left edge are slightly
        -- bigger to remove phantom gaps
        w :: n
w | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = n
1
          | Bool
otherwise = n
1.5
        h :: n
h | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = n
1
          | Bool
otherwise = n
1.5

------------------------------------------------------------------------
-- Heat matrix
------------------------------------------------------------------------

-- | A mapping from points in a 2D axis do 'Double's. These 'Double's
--   are converted to colours using the axis 'ColourMap'.
data HeatMap b n = HeatMap
  { forall b n. HeatMap b n -> HeatMatrix
hMatrix      :: HeatMatrix
  , forall b n. HeatMap b n -> P2 n
hStart       :: P2 n
  , forall b n. HeatMap b n -> V2 n
hSize        :: V2 n
  , forall b n. HeatMap b n -> Style V2 n
hGridSty     :: Style V2 n
  , forall b n. HeatMap b n -> Bool
hGridVisible :: Bool
  , forall b n. HeatMap b n -> Maybe (Double, Double)
hLimits      :: Maybe (Double,Double)
  , forall b n.
HeatMap b n -> HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hDraw        :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any
  } deriving Typeable

type instance V (HeatMap b n) = V2
type instance N (HeatMap b n) = n

-- | Class of things that let you change the heatmap options.
class HasHeatMap f a b | a -> b where
  -- | Lens onto the heatmap options.
  heatMapOptions :: LensLike' f a (HeatMap b (N a))

  -- | Whether there should be grid lines draw for the heat map.
  --
  --   Default is 'False'.
  heatMapGridVisible :: Functor f => LensLike' f a Bool
  heatMapGridVisible = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((Bool -> f Bool) -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> Bool)
-> (HeatMap b (N a) -> Bool -> HeatMap b (N a))
-> Lens (HeatMap b (N a)) (HeatMap b (N a)) Bool Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a) -> Bool
forall b n. HeatMap b n -> Bool
hGridVisible (\HeatMap b (N a)
s Bool
b -> (HeatMap b (N a)
s {hGridVisible = b}))

  -- | The style applied to the grid lines for the heat map, if they're
  --   visible.
  --
  --   Default is 'mempty'.
  heatMapGridStyle :: Functor f => LensLike' f a (Style V2 (N a))
  heatMapGridStyle = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((Style V2 (N a) -> f (Style V2 (N a)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (Style V2 (N a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> Style V2 (N a))
-> (HeatMap b (N a) -> Style V2 (N a) -> HeatMap b (N a))
-> Lens
     (HeatMap b (N a))
     (HeatMap b (N a))
     (Style V2 (N a))
     (Style V2 (N a))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a) -> Style V2 (N a)
forall b n. HeatMap b n -> Style V2 n
hGridSty (\HeatMap b (N a)
s Style V2 (N a)
b -> (HeatMap b (N a)
s {hGridSty = b}))

  -- | The size of each individual square in the heat map.
  --
  --   Default is @'V2' 1 1@.
  heatMapSize :: Functor f => LensLike' f a (V2 (N a))
  heatMapSize = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((V2 (N a) -> f (V2 (N a)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (V2 (N a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> V2 (N a))
-> (HeatMap b (N a) -> V2 (N a) -> HeatMap b (N a))
-> Lens (HeatMap b (N a)) (HeatMap b (N a)) (V2 (N a)) (V2 (N a))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a) -> V2 (N a)
forall b n. HeatMap b n -> V2 n
hSize (\HeatMap b (N a)
s V2 (N a)
b -> (HeatMap b (N a)
s {hSize = b}))

  -- | The size of the full extent of the heat map.
  --
  --   Default is extent of the heat matrix.
  heatMapExtent :: (Functor f, Fractional (N a)) => LensLike' f a (V2 (N a))
  heatMapExtent = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((V2 (N a) -> f (V2 (N a)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (V2 (N a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 (N a) -> f (V2 (N a)))
-> HeatMap b (N a) -> f (HeatMap b (N a))
forall {n} {f :: * -> *} {b}.
(Functor f, Fractional n) =>
(V2 n -> f (V2 n)) -> HeatMap b n -> f (HeatMap b n)
l where
    l :: (V2 n -> f (V2 n)) -> HeatMap b n -> f (HeatMap b n)
l V2 n -> f (V2 n)
f HeatMap b n
hm = V2 n -> f (V2 n)
f (HeatMap b n -> V2 n
forall b n. HeatMap b n -> V2 n
hSize HeatMap b n
hm V2 n -> V2 n -> V2 n
forall a. Num a => a -> a -> a
* V2 n
s) f (V2 n) -> (V2 n -> HeatMap b n) -> f (HeatMap b n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \V2 n
x -> HeatMap b n
hm { hSize = x / s }
      where s :: V2 n
s = (Int -> n) -> V2 Int -> V2 n
forall a b. (a -> b) -> V2 a -> V2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HeatMatrix -> V2 Int
hmSize (HeatMatrix -> V2 Int) -> HeatMatrix -> V2 Int
forall a b. (a -> b) -> a -> b
$ HeatMap b n -> HeatMatrix
forall b n. HeatMap b n -> HeatMatrix
hMatrix HeatMap b n
hm)

  -- | The starting point at the bottom left corner of the heat map.
  --
  --   Default is 'origin'
  heatMapStart :: Functor f => LensLike' f a (P2 (N a))
  heatMapStart = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((P2 (N a) -> f (P2 (N a)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (P2 (N a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> P2 (N a))
-> (HeatMap b (N a) -> P2 (N a) -> HeatMap b (N a))
-> Lens (HeatMap b (N a)) (HeatMap b (N a)) (P2 (N a)) (P2 (N a))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a) -> P2 (N a)
forall b n. HeatMap b n -> P2 n
hStart (\HeatMap b (N a)
s P2 (N a)
b -> (HeatMap b (N a)
s {hStart = b}))

  -- | The center point of the heat map.
  heatMapCentre :: (Functor f, Fractional (N a)) => LensLike' f a (P2 (N a))
  heatMapCentre = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((P2 (N a) -> f (P2 (N a)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (P2 (N a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (P2 (N a) -> f (P2 (N a)))
-> HeatMap b (N a) -> f (HeatMap b (N a))
forall {n} {f :: * -> *} {b}.
(Fractional n, Functor f) =>
(Point V2 n -> f (Point V2 n)) -> HeatMap b n -> f (HeatMap b n)
l where
    l :: (Point V2 n -> f (Point V2 n)) -> HeatMap b n -> f (HeatMap b n)
l Point V2 n -> f (Point V2 n)
f HeatMap b n
hm = Point V2 n -> f (Point V2 n)
f (HeatMap b n -> Point V2 n
forall b n. HeatMap b n -> P2 n
hStart HeatMap b n
hm Point V2 n -> Diff (Point V2) n -> Point V2 n
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 n
Diff (Point V2) n
v) f (Point V2 n) -> (Point V2 n -> HeatMap b n) -> f (HeatMap b n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Point V2 n
p -> HeatMap b n
hm { hStart = p .-^ v }
      where v :: V2 n
v = (Int -> n) -> V2 Int -> V2 n
forall a b. (a -> b) -> V2 a -> V2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HeatMatrix -> V2 Int
hmSize (HeatMatrix -> V2 Int) -> HeatMatrix -> V2 Int
forall a b. (a -> b) -> a -> b
$ HeatMap b n -> HeatMatrix
forall b n. HeatMap b n -> HeatMatrix
hMatrix HeatMap b n
hm) V2 n -> V2 n -> V2 n
forall a. Num a => a -> a -> a
* HeatMap b n -> V2 n
forall b n. HeatMap b n -> V2 n
hSize HeatMap b n
hm V2 n -> V2 n -> V2 n
forall a. Fractional a => a -> a -> a
/ V2 n
2

  -- | Limits @(a,b)@ used on the data such that @a@ is the start of the
  --   'ColourMap' and @b@ is the end of the 'ColourMap'. Default is @(0,1)@.
  heatMapLimits :: Functor f => LensLike' f a (Maybe (Double, Double))
  heatMapLimits = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> ((Maybe (Double, Double) -> f (Maybe (Double, Double)))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike' f a (Maybe (Double, Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> Maybe (Double, Double))
-> (HeatMap b (N a) -> Maybe (Double, Double) -> HeatMap b (N a))
-> Lens
     (HeatMap b (N a))
     (HeatMap b (N a))
     (Maybe (Double, Double))
     (Maybe (Double, Double))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a) -> Maybe (Double, Double)
forall b n. HeatMap b n -> Maybe (Double, Double)
hLimits (\HeatMap b (N a)
s Maybe (Double, Double)
b -> (HeatMap b (N a)
s {hLimits = b}))

  -- | Funtion used to render the heat map. See 'pathHeatRender' and
  --   'pixelHeatRender'.
  --
  --   Default is 'pathHeatRender'.
  heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
  heatMapRender = LensLike' f a (HeatMap b (N a))
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions LensLike' f a (HeatMap b (N a))
-> (((HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
     -> f (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any))
    -> HeatMap b (N a) -> f (HeatMap b (N a)))
-> LensLike'
     f a (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a)
 -> HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
-> (HeatMap b (N a)
    -> (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
    -> HeatMap b (N a))
-> Lens
     (HeatMap b (N a))
     (HeatMap b (N a))
     (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
     (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HeatMap b (N a)
-> HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any
forall b n.
HeatMap b n -> HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hDraw (\HeatMap b (N a)
s HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any
b -> (HeatMap b (N a)
s {hDraw = b}))

instance HasHeatMap f (HeatMap b n) b where
  heatMapOptions :: LensLike' f (HeatMap b n) (HeatMap b (N (HeatMap b n)))
heatMapOptions = (HeatMap b n -> f (HeatMap b n)) -> HeatMap b n -> f (HeatMap b n)
LensLike' f (HeatMap b n) (HeatMap b (N (HeatMap b n)))
forall a. a -> a
id

instance (Functor f, HasHeatMap f a b) => HasHeatMap f (Plot a b) b where
  heatMapOptions :: LensLike' f (Plot a b) (HeatMap b (N (Plot a b)))
heatMapOptions = (a -> f a) -> Plot a b -> f (Plot a b)
forall p p' b. SameSpace p p' => Lens (Plot p b) (Plot p' b) p p'
Lens (Plot a b) (Plot a b) a a
rawPlot ((a -> f a) -> Plot a b -> f (Plot a b))
-> ((HeatMap b (N a) -> f (HeatMap b (N a))) -> a -> f a)
-> (HeatMap b (N a) -> f (HeatMap b (N a)))
-> Plot a b
-> f (Plot a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeatMap b (N a) -> f (HeatMap b (N a))) -> a -> f a
forall (f :: * -> *) a b.
HasHeatMap f a b =>
LensLike' f a (HeatMap b (N a))
heatMapOptions

instance OrderedField n => Enveloped (HeatMap b n) where
  getEnvelope :: HeatMap b n -> Envelope (V (HeatMap b n)) (N (HeatMap b n))
getEnvelope HeatMap b n
hm = BoundingBox V2 (N (HeatMap b n))
-> Envelope
     (V (BoundingBox V2 (N (HeatMap b n))))
     (N (BoundingBox V2 (N (HeatMap b n))))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope (Point V2 (N (HeatMap b n))
-> Point V2 (N (HeatMap b n)) -> BoundingBox V2 (N (HeatMap b n))
forall (v :: * -> *) n.
(Additive v, Foldable v, Ord n) =>
Point v n -> Point v n -> BoundingBox v n
fromCorners Point V2 (N (HeatMap b n))
p (Point V2 (N (HeatMap b n))
p Point V2 (N (HeatMap b n))
-> Diff (Point V2) (N (HeatMap b n)) -> Point V2 (N (HeatMap b n))
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 (N (HeatMap b n))
Diff (Point V2) (N (HeatMap b n))
v))
    where p :: Point V2 (N (HeatMap b n))
p = Getting
  (Point V2 (N (HeatMap b n)))
  (HeatMap b n)
  (Point V2 (N (HeatMap b n)))
-> HeatMap b n -> Point V2 (N (HeatMap b n))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Point V2 (N (HeatMap b n)))
  (HeatMap b n)
  (Point V2 (N (HeatMap b n)))
forall (f :: * -> *) a b.
(HasHeatMap f a b, Functor f) =>
LensLike' f a (P2 (N a))
heatMapStart HeatMap b n
hm
          v :: V2 (N (HeatMap b n))
v = Getting (V2 (N (HeatMap b n))) (HeatMap b n) (V2 (N (HeatMap b n)))
-> HeatMap b n -> V2 (N (HeatMap b n))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V2 (N (HeatMap b n))) (HeatMap b n) (V2 (N (HeatMap b n)))
forall (f :: * -> *) a b.
(HasHeatMap f a b, Functor f, Fractional (N a)) =>
LensLike' f a (V2 (N a))
heatMapExtent HeatMap b n
hm

instance (Typeable b, TypeableFloat n, Renderable (Path V2 n) b)
    => Plotable (HeatMap b n) b where
  renderPlotable :: forall (v :: * -> *) n.
InSpace v n (HeatMap b n) =>
AxisSpec v n
-> PlotStyle b v n -> HeatMap b n -> QDiagram b v n Any
renderPlotable AxisSpec v n
s PlotStyle b v n
_sty HeatMap {Bool
Maybe (Double, Double)
P2 n
Style V2 n
V2 n
HeatMatrix
HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hMatrix :: forall b n. HeatMap b n -> HeatMatrix
hStart :: forall b n. HeatMap b n -> P2 n
hSize :: forall b n. HeatMap b n -> V2 n
hGridSty :: forall b n. HeatMap b n -> Style V2 n
hGridVisible :: forall b n. HeatMap b n -> Bool
hLimits :: forall b n. HeatMap b n -> Maybe (Double, Double)
hDraw :: forall b n.
HeatMap b n -> HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hMatrix :: HeatMatrix
hStart :: P2 n
hSize :: V2 n
hGridSty :: Style V2 n
hGridVisible :: Bool
hLimits :: Maybe (Double, Double)
hDraw :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any
..} =
      Transformation (V (QDiagram b v n Any)) (N (QDiagram b v n Any))
-> QDiagram b v n Any -> QDiagram b v n Any
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (AxisSpec v n
sAxisSpec v n
-> Getting (Transformation v n) (AxisSpec v n) (Transformation v n)
-> Transformation v n
forall s a. s -> Getting a s a -> a
^.Getting (Transformation v n) (AxisSpec v n) (Transformation v n)
forall (v :: * -> *) n (f :: * -> *).
Functor f =>
(Transformation v n -> f (Transformation v n))
-> AxisSpec v n -> f (AxisSpec v n)
specTrans) (QDiagram b v n Any -> QDiagram b v n Any)
-> QDiagram b v n Any -> QDiagram b v n Any
forall a b. (a -> b) -> a -> b
$
        QDiagram b v n Any
grid QDiagram b v n Any -> QDiagram b v n Any -> QDiagram b v n Any
forall a. Semigroup a => a -> a -> a
<> HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hDraw HeatMatrix
matrix' (AxisSpec v n
sAxisSpec v n
-> Getting ColourMap (AxisSpec v n) ColourMap -> ColourMap
forall s a. s -> Getting a s a -> a
^.Getting ColourMap (AxisSpec v n) ColourMap
forall (v :: * -> *) n (f :: * -> *).
Functor f =>
(ColourMap -> f ColourMap) -> AxisSpec v n -> f (AxisSpec v n)
specColourMap)
                  # transform (scaleV hSize)
                  # moveTo hStart
    where
      --- TODO
      grid :: QDiagram b v n Any
grid = QDiagram b v n Any
forall a. Monoid a => a
mempty

      --- XXX need to give _range to the axis somehow (for colour bar range)
      matrix' :: HeatMatrix
matrix' = case Maybe (Double, Double)
hLimits of
        -- Just r@(a,b) -> (r, hMatrix { hmFun = (/ (b - a)) . (+a) . hmFun hMatrix })
        -- Nothing      -> normaliseHeatMatrix hMatrix
        Just (Double
a,Double
b) -> HeatMatrix
hMatrix { hmBoundLower = a, hmBoundUpper = b }
        Maybe (Double, Double)
Nothing     -> HeatMatrix
hMatrix

  -- XXX make better
  defLegendPic :: forall (v :: * -> *) n.
InSpace v n (HeatMap b n) =>
PlotStyle b v n -> HeatMap b n -> QDiagram b v n Any
defLegendPic PlotStyle b v n
sty HeatMap {} = n -> QDiagram b v n Any
forall n t. (InSpace V2 n t, TrailLike t) => n -> t
square n
5 QDiagram b v n Any
-> (QDiagram b v n Any -> QDiagram b v n Any) -> QDiagram b v n Any
forall a b. a -> (a -> b) -> b
# PlotStyle b v n -> QDiagram b v n Any -> QDiagram b v n Any
forall a t b.
(SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b,
 HasStyle t) =>
a -> t -> t
applyAreaStyle PlotStyle b v n
sty

scaleV :: (Additive v, Fractional n) => v n -> Transformation v n
scaleV :: forall (v :: * -> *) n.
(Additive v, Fractional n) =>
v n -> Transformation v n
scaleV v n
v = (v n :-: v n) -> (v n :-: v n) -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
(v n :-: v n) -> (v n :-: v n) -> Transformation v n
fromLinear v n :-: v n
f v n :-: v n
f
  where f :: v n :-: v n
f = ((n -> n -> n) -> v n -> v n -> v n
forall a. (a -> a -> a) -> v a -> v a -> v a
forall (f :: * -> *) a.
Additive f =>
(a -> a -> a) -> f a -> f a -> f a
liftU2 n -> n -> n
forall a. Num a => a -> a -> a
(*) v n
v) (v n -> v n) -> (v n -> v n) -> v n :-: v n
forall u v. (u -> v) -> (v -> u) -> u :-: v
<-> (\v n
u -> (n -> n -> n) -> v n -> v n -> v n
forall a. (a -> a -> a) -> v a -> v a -> v a
forall (f :: * -> *) a.
Additive f =>
(a -> a -> a) -> f a -> f a -> f a
liftU2 n -> n -> n
forall a. Fractional a => a -> a -> a
(/) v n
u v n
v)

-- | Construct a 'Heatmap' using the given 'HeatMatrix'.
mkHeatMap :: (Renderable (Path V2 n) b, TypeableFloat n)
          => HeatMatrix -> HeatMap b n
mkHeatMap :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
HeatMatrix -> HeatMap b n
mkHeatMap HeatMatrix
mat = HeatMap
  { hMatrix :: HeatMatrix
hMatrix      = HeatMatrix
mat
  , hStart :: P2 n
hStart       = P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
  , hSize :: V2 n
hSize        = n -> n -> V2 n
forall a. a -> a -> V2 a
V2 n
1 n
1
  , hGridSty :: Style V2 n
hGridSty     = Style V2 n
forall a. Monoid a => a
mempty
  , hGridVisible :: Bool
hGridVisible = Bool
False
  , hLimits :: Maybe (Double, Double)
hLimits      = Maybe (Double, Double)
forall a. Maybe a
Nothing
  , hDraw :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any
hDraw        = HeatMatrix -> ColourMap -> QDiagram b V2 n Any
forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
HeatMatrix -> ColourMap -> QDiagram b V2 n Any
pathHeatRender
  }

-- Adding to axis ------------------------------------------------------

-- | Add a 'HeatMap' plot using the extent of the heatmap and a
--   generating function.
--
-- @
-- 'heatMap' :: [['Double']] -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) ()
-- @
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_heatMapExample.svg#diagram=heatMapExample&height=350>>
--
-- > import Plots
-- > heatMapAxis :: Axis B V2 Double
-- > heatMapAxis = r2Axis &~ do
-- >   display colourBar
-- >   axisExtend .= noExtend
-- >
-- >   let xs = [[1,2,3],[4,5,6]]
-- >   heatMap xs $ heatMapSize .= V2 10 10
--
-- > heatMapExample = renderAxis heatMapAxis
--
heatMap
  :: (F.Foldable f,
      F.Foldable g,
      TypeableFloat n,
      Typeable b,
      MonadState (Axis b V2 n) m,
      Renderable (Path V2 n) b)
  => f (g Double)
  -> State (Plot (HeatMap b n) b) ()
                   -- ^ changes to plot options
  -> m ()          -- ^ add plot to 'Axis'
heatMap :: forall (f :: * -> *) (g :: * -> *) n b (m :: * -> *).
(Foldable f, Foldable g, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
f (g Double) -> State (Plot (HeatMap b n) b) () -> m ()
heatMap f (g Double)
xss State (Plot (HeatMap b n) b) ()
s = do
  let hm :: HeatMatrix
hm@(HeatMatrix V2 Int
_ Vector Double
_ Double
a Double
b) = f (g Double) -> HeatMatrix
forall (f :: * -> *) (g :: * -> *).
(Foldable f, Foldable g) =>
f (g Double) -> HeatMatrix
mkHeatMatrix' f (g Double)
xss
  HeatMap b n -> State (Plot (HeatMap b n) b) () -> m ()
forall (c :: * -> *) n p b (m :: * -> *).
(InSpace (BaseSpace c) n p, MonadState (Axis b c n) m,
 Plotable p b) =>
p -> State (Plot p b) () -> m ()
addPlotable (HeatMatrix -> HeatMap b n
forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
HeatMatrix -> HeatMap b n
mkHeatMap HeatMatrix
hm) State (Plot (HeatMap b n) b) ()
s

  -- (don't like this way of doing it)
  ((n, n) -> Identity (n, n))
-> Axis b V2 n -> Identity (Axis b V2 n)
forall b (v :: * -> *) n (f :: * -> *).
Functor f =>
((n, n) -> f (n, n)) -> Axis b v n -> f (Axis b v n)
colourBarRange (((n, n) -> Identity (n, n))
 -> Axis b V2 n -> Identity (Axis b V2 n))
-> (n, n) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ASetter (Double, Double) (n, n) Double n
-> (Double -> n) -> (Double, Double) -> (n, n)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Double, Double) (n, n) Double n
Traversal (Double, Double) (n, n) Double n
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both Double -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
a,Double
b)

-- | Add a 'HeatMap' plot using the extent of the heatmap and a
--   generating function.
--
-- @
-- 'heatMap'' :: [['Double']] -> 'State' ('Axis' b 'V2' n) ()
-- @
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_heatMapExample'.svg#diagram=heatMapExample'&height=350>>
--
-- > import Plots
-- > heatMapAxis' :: Axis B V2 Double
-- > heatMapAxis' = r2Axis &~ do
-- >   display colourBar
-- >   axisExtend .= noExtend
-- >   axisColourMap .= Plots.magma
-- >
-- >   let xs = [[1,2,3],[4,5,6]]
-- >   heatMap' xs
--
-- > heatMapExample' = renderAxis heatMapAxis'
--
heatMap'
  :: (F.Foldable f,
      F.Foldable g,
      TypeableFloat n,
      Typeable b,
      MonadState (Axis b V2 n) m,
      Renderable (Path V2 n) b)
  => f (g Double)
  -> m ()          -- ^ add plot to 'Axis'
heatMap' :: forall (f :: * -> *) (g :: * -> *) n b (m :: * -> *).
(Foldable f, Foldable g, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
f (g Double) -> m ()
heatMap' f (g Double)
xss = f (g Double) -> State (Plot (HeatMap b n) b) () -> m ()
forall (f :: * -> *) (g :: * -> *) n b (m :: * -> *).
(Foldable f, Foldable g, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
f (g Double) -> State (Plot (HeatMap b n) b) () -> m ()
heatMap f (g Double)
xss (() -> State (Plot (HeatMap b n) b) ()
forall a. a -> StateT (Plot (HeatMap b n) b) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Add a 'HeatMap' plot using the extent of the heatmap and a
--   generating function.
--
-- @
-- 'heatMapIndexed' :: 'V2' 'Int'     -> ('V2' 'Int' -> 'Double')     -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) ()
-- 'heatMapIndexed' :: ('Int', 'Int') -> (('Int', 'Int') -> 'Double') -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) ()
-- @
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample.svg#diagram=heatMapIndexedExample&height=350>>
--
-- > import Plots
-- > heatMapIndexedAxis :: Axis B V2 Double
-- > heatMapIndexedAxis = r2Axis &~ do
-- >   display colourBar
-- >   axisExtend .= noExtend
-- >
-- >   let f (V2 x y) = fromIntegral x + fromIntegral y
-- >   heatMapIndexed (V2 3 3) f $ heatMapSize .= V2 10 10
--
-- > heatMapIndexedExample = renderAxis heatMapIndexedAxis
--
heatMapIndexed
  :: (VectorLike V2 Int i,
      TypeableFloat n,
      Typeable b,
      MonadState (Axis b V2 n) m,
      Renderable (Path V2 n) b)
  => i             -- ^ extent of array
  -> (i -> Double) -- ^ heat from index
  -> State (Plot (HeatMap b n) b) ()
                   -- ^ changes to plot options
  -> m ()          -- ^ add plot to 'Axis'
heatMapIndexed :: forall i n b (m :: * -> *).
(VectorLike V2 Int i, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
i -> (i -> Double) -> State (Plot (HeatMap b n) b) () -> m ()
heatMapIndexed i
i i -> Double
f State (Plot (HeatMap b n) b) ()
s = do
  let hm :: HeatMatrix
hm@(HeatMatrix V2 Int
_ Vector Double
_ Double
a Double
b) = V2 Int -> (V2 Int -> Double) -> HeatMatrix
mkHeatMatrix (Getting (V2 Int) i (V2 Int) -> i -> V2 Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V2 Int) i (V2 Int)
forall (v :: * -> *) n a. VectorLike v n a => Iso' a (v n)
Iso' i (V2 Int)
unvectorLike i
i) (i -> Double
f (i -> Double) -> (V2 Int -> i) -> V2 Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting i (V2 Int) i -> V2 Int -> i
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting i (V2 Int) i
forall (v :: * -> *) n a. VectorLike v n a => Iso' (v n) a
Iso' (V2 Int) i
vectorLike)
  HeatMap b n -> State (Plot (HeatMap b n) b) () -> m ()
forall (c :: * -> *) n p b (m :: * -> *).
(InSpace (BaseSpace c) n p, MonadState (Axis b c n) m,
 Plotable p b) =>
p -> State (Plot p b) () -> m ()
addPlotable (HeatMatrix -> HeatMap b n
forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
HeatMatrix -> HeatMap b n
mkHeatMap HeatMatrix
hm) State (Plot (HeatMap b n) b) ()
s

  -- (don't like this way of doing it)
  ((n, n) -> Identity (n, n))
-> Axis b V2 n -> Identity (Axis b V2 n)
forall b (v :: * -> *) n (f :: * -> *).
Functor f =>
((n, n) -> f (n, n)) -> Axis b v n -> f (Axis b v n)
colourBarRange (((n, n) -> Identity (n, n))
 -> Axis b V2 n -> Identity (Axis b V2 n))
-> (n, n) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ASetter (Double, Double) (n, n) Double n
-> (Double -> n) -> (Double, Double) -> (n, n)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Double, Double) (n, n) Double n
Traversal (Double, Double) (n, n) Double n
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both Double -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
a,Double
b)

-- | Add a 'HeatMap' plot using the extent of the heatmap and a
-- generating function without changes to the heap map options.
--
-- @
-- 'heatMapIndexed' :: 'V2' 'Int'     -> ('V2' 'Int' -> 'Double')     -> 'State' ('Axis' b 'V2' n) ()
-- 'heatMapIndexed' :: ('Int', 'Int') -> (('Int', 'Int') -> 'Double') -> 'State' ('Axis' b 'V2' n) ()
-- @
--
-- === __Example__
--
-- <<diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample'.svg#diagram=heatMapIndexedExample'&height=350>>
--
-- > import Plots
-- > heatMapIndexedAxis' :: Axis B V2 Double
-- > heatMapIndexedAxis' = r2Axis &~ do
-- >   display colourBar
-- >   axisExtend .= noExtend
-- >   axisColourMap .= Plots.magma
-- >
-- >   let f (V2 x y) = fromIntegral x + fromIntegral y
-- >   heatMapIndexed' (V2 3 3) f
--
-- > heatMapIndexedExample' = renderAxis heatMapIndexedAxis'
--
heatMapIndexed'
  :: (VectorLike V2 Int i,
      TypeableFloat n,
      Typeable b,
      MonadState (Axis b V2 n) m,
      Renderable (Path V2 n) b)
  => i             -- ^ extent of array
  -> (i -> Double) -- ^ heat from index
  -> m ()          -- ^ add plot to 'Axis'
heatMapIndexed' :: forall i n b (m :: * -> *).
(VectorLike V2 Int i, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
i -> (i -> Double) -> m ()
heatMapIndexed' i
i i -> Double
f = i -> (i -> Double) -> State (Plot (HeatMap b n) b) () -> m ()
forall i n b (m :: * -> *).
(VectorLike V2 Int i, TypeableFloat n, Typeable b,
 MonadState (Axis b V2 n) m, Renderable (Path V2 n) b) =>
i -> (i -> Double) -> State (Plot (HeatMap b n) b) () -> m ()
heatMapIndexed i
i i -> Double
f (() -> State (Plot (HeatMap b n) b) ()
forall a. a -> StateT (Plot (HeatMap b n) b) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ())