{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NegativeLiterals #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module Chart.Core
(
Chart
, range
, projectss
, aspect
, asquare
, sixbyfour
, golden
, widescreen
, skinny
, AlignH(..)
, AlignV(..)
, alignHU
, alignHTU
, alignVU
, alignVTU
, Orientation(..)
, Place(..)
, positioned
, p_
, r_
, stack
, vert
, hori
, sepVert
, sepHori
, UColor(..)
, acolor
, ucolor
, ccolor
, ublue
, ugrey
, utrans
, ublack
, uwhite
, scaleX
, scaleY
, scale
) where
import Diagrams.Prelude
hiding (Color, D, aspect, project, scale, scaleX, scaleY, zero, over)
import qualified Diagrams.Prelude as Diagrams
import qualified Diagrams.TwoD.Text
import NumHask.Pair
import NumHask.Prelude
import NumHask.Rect
import NumHask.Space
import Data.Colour (over)
type Chart b =
( Renderable (Path V2 Double) b
, Renderable (Diagrams.TwoD.Text.Text Double) b) =>
QDiagram b V2 Double Any
projectss ::
(Functor f, Functor g)
=> Rect Double
-> Rect Double
-> g (f (Pair Double))
-> g (f (Pair Double))
projectss r0 r1 xyss = map (project r0 r1) <$> xyss
range :: (Foldable f, Foldable g) => g (f (Pair Double)) -> Rect Double
range xyss = foldMap space xyss
aspect :: (BoundedField a, Ord a, Multiplicative a, FromInteger a) => a -> Rect a
aspect a = Ranges ((a *) <$> one) one
asquare :: Rect Double
asquare = aspect 1
sixbyfour :: Rect Double
sixbyfour = aspect 1.5
golden :: Rect Double
golden = aspect 1.61803398875
widescreen :: Rect Double
widescreen = aspect 3
skinny :: Rect Double
skinny = aspect 5
data AlignH
= AlignLeft
| AlignCenter
| AlignRight
deriving (Eq, Show, Generic)
data AlignV
= AlignTop
| AlignMid
| AlignBottom
deriving (Eq, Show, Generic)
alignHU :: AlignH -> Double
alignHU a =
case a of
AlignLeft -> 0.5
AlignCenter -> 0
AlignRight -> -0.5
alignHTU :: AlignH -> Double
alignHTU a =
case a of
AlignLeft -> 0
AlignCenter -> -0.5
AlignRight -> -1
alignVU :: AlignV -> Double
alignVU a =
case a of
AlignTop -> -0.5
AlignMid -> 0
AlignBottom -> 0.5
alignVTU :: AlignV -> Double
alignVTU a =
case a of
AlignTop -> 0.5
AlignMid -> 0
AlignBottom -> -0.5
data Orientation
= Hori
| Vert
deriving (Eq, Show, Generic)
data Place
= PlaceLeft
| PlaceRight
| PlaceTop
| PlaceBottom
deriving (Eq, Show, Generic)
positioned :: (R2 r) => r Double -> Chart b -> Chart b
positioned p = moveTo (p_ p)
p_ :: (R2 r) => r Double -> Point V2 Double
p_ r = curry p2 (r ^. _x) (r ^. _y)
r_ :: R2 r => r a -> V2 a
r_ r = V2 (r ^. _x) (r ^. _y)
stack ::
( R2 r
, V a ~ V2
, Foldable t
, Juxtaposable a
, Semigroup a
, N a ~ Double
, Monoid a
)
=> r Double
-> (b -> a)
-> t b
-> a
stack dir f xs = foldr (\a x -> beside (r_ dir) (f a) x) mempty xs
vert ::
(V a ~ V2, Foldable t, Juxtaposable a, Semigroup a, N a ~ Double, Monoid a)
=> (b -> a)
-> t b
-> a
vert = stack (Pair 0 -1)
hori ::
(V a ~ V2, Foldable t, Juxtaposable a, Semigroup a, N a ~ Double, Monoid a)
=> (b -> a)
-> t b
-> a
hori = stack (Pair 1 0)
sepHori :: Double -> Chart b -> Chart b
sepHori s x = beside (r2 (0, -1)) x (strutX s)
sepVert :: Double -> Chart b -> Chart b
sepVert s x = beside (r2 (1, 0)) x (strutY s)
data UColor a =
UColor
{ ucred :: a
, ucgreen :: a
, ucblue :: a
, ucopacity :: a
} deriving (Eq, Ord, Show, Generic)
acolor :: (Floating a, Num a, Ord a) => UColor a -> AlphaColour a
acolor (UColor r g b o) = withOpacity (sRGB r g b) o
ucolor :: (Floating a, Num a, Ord a) => AlphaColour a -> UColor a
ucolor a = let (RGB r g b) = toSRGB (a `over` black) in UColor r g b (alphaChannel a)
ccolor :: (Floating a, Num a, Ord a) => Colour a -> UColor a
ccolor (toSRGB -> RGB r g b) = UColor r g b 1
ublue :: UColor Double
ublue = UColor 0.365 0.647 0.855 0.5
ugrey :: UColor Double
ugrey = UColor 0.4 0.4 0.4 1
utrans :: UColor Double
utrans = UColor 0 0 0 0
ublack :: UColor Double
ublack = UColor 0 0 0 1
uwhite :: UColor Double
uwhite = UColor 1 1 1 1
instance R1 Pair where
_x f (Pair a b) = (`Pair` b) <$> f a
instance R2 Pair where
_y f (Pair a b) = Pair a <$> f b
_xy f p = fmap (\(V2 a b) -> Pair a b) . f . (\(Pair a b) -> V2 a b) $ p
eps :: N [Point V2 Double]
eps = 1e-8
scaleX ::
(N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t))
=> Double
-> t
-> t
scaleX s =
Diagrams.scaleX
(if s == zero
then eps
else s)
scaleY ::
(N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t))
=> Double
-> t
-> t
scaleY s =
Diagrams.scaleY
(if s == zero
then eps
else s)
scale ::
(N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t))
=> Double
-> t
-> t
scale s =
Diagrams.scale
(if s == zero
then eps
else s)