{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Attributes
-- Copyright   :  (c) 2013-2015 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Diagrams may have /attributes/ which affect the way they are
-- rendered. This module defines /Textures/ (Gradients and Colors) in two
-- dimensions. Like the attributes defined in the Diagrams.Attributes module,
-- all attributes defined here use the 'Last' or 'Recommend' /semigroup/ structure.
-- 'FillColor' and 'LineColor' attributes are provided so that backends that
-- don't support gradients need not be concerned with using textures. Backends
-- should only implement color attributes or textures attributes, not both.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Attributes (
  -- * Textures
    Texture(..), solid, _SC, _AC, _LG, _RG, defaultLG, defaultRG
  , GradientStop(..), stopColor, stopFraction, mkStops
  , SpreadMethod(..), lineLGradient, lineRGradient

  -- ** Linear Gradients
  , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd
  , lGradSpreadMethod, mkLinearGradient

  -- ** Radial Gradients
  , RGradient(..), rGradStops, rGradTrans
  , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1
  , rGradSpreadMethod, mkRadialGradient

  -- ** Line texture
  , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA
  , mkLineTexture, _lineTexture

  -- ** Line color
  , lineColor, lc, lcA

  -- ** Fill texture
  , FillTexture(..), _FillTexture, getFillTexture, fillTexture
  , mkFillTexture, _fillTexture, _fillTextureR

  -- ** Fill color
  , fillColor, fc, fcA, recommendFillColor

  -- * Compilation utilities
  , splitTextureFills

  ) where

import           Control.Lens                hiding (transform)
import           Data.Colour                 hiding (AffineSpace, over)
import           Data.Data
import           Data.Default.Class
import           Data.Monoid.Recommend
import           Data.Semigroup

import           Diagrams.Attributes
import           Diagrams.Attributes.Compile
import           Diagrams.Core
import           Diagrams.Core.Types         (RTree)
import           Diagrams.Located            (unLoc)
import           Diagrams.Path               (Path, pathTrails)
import           Diagrams.Trail              (isLoop)
import           Diagrams.TwoD.Types
import           Diagrams.Util


-----------------------------------------------------------------
--  Gradients  --------------------------------------------------
-----------------------------------------------------------------

-- | A gradient stop contains a color and fraction (usually between 0 and 1)
data GradientStop d = GradientStop
  { forall d. GradientStop d -> SomeColor
_stopColor    :: SomeColor
  , forall d. GradientStop d -> d
_stopFraction :: d
  }

makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop

-- | A color for the stop.
stopColor :: Lens' (GradientStop n) SomeColor

-- | The fraction for stop.
stopFraction :: Lens' (GradientStop n) n

-- | The 'SpreadMethod' determines what happens before 'lGradStart' and after
--   'lGradEnd'. 'GradPad' fills the space before the start of the gradient
--   with the color of the first stop and the color after end of the gradient
--   with the color of the last stop. 'GradRepeat' restarts the gradient and
--   'GradReflect' restarts the gradient with the stops in reverse order.
data SpreadMethod = GradPad | GradReflect | GradRepeat

-- | Linear Gradient
data LGradient n = LGradient
  { forall n. LGradient n -> [GradientStop n]
_lGradStops        :: [GradientStop n]
  , forall n. LGradient n -> Point V2 n
_lGradStart        :: Point V2 n
  , forall n. LGradient n -> Point V2 n
_lGradEnd          :: Point V2 n
  , forall n. LGradient n -> Transformation V2 n
_lGradTrans        :: Transformation V2 n
  , forall n. LGradient n -> SpreadMethod
_lGradSpreadMethod :: SpreadMethod }

type instance V (LGradient n) = V2
type instance N (LGradient n) = n

makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient

instance Fractional n => Transformable (LGradient n) where
  transform :: Transformation (V (LGradient n)) (N (LGradient n))
-> LGradient n -> LGradient n
transform = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

-- | A list of stops (colors and fractions).
lGradStops :: Lens' (LGradient n) [GradientStop n]

-- | A transformation to be applied to the gradient. Usually this field will
--   start as the identity transform and capture the transforms that are applied
--   to the gradient.
lGradTrans :: Lens' (LGradient n) (Transformation V2 n)

-- | The starting point for the first gradient stop. The coordinates are in
--   'local' units and the default is (-0.5, 0).
lGradStart :: Lens' (LGradient n) (Point V2 n)

-- | The ending point for the last gradient stop.The coordinates are in
--   'local' units and the default is (0.5, 0).
lGradEnd :: Lens' (LGradient n) (Point V2 n)

-- | For setting the spread method.
lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod

-- | Radial Gradient
data RGradient n = RGradient
  { forall n. RGradient n -> [GradientStop n]
_rGradStops        :: [GradientStop n]
  , forall n. RGradient n -> Point V2 n
_rGradCenter0      :: Point V2 n
  , forall n. RGradient n -> n
_rGradRadius0      :: n
  , forall n. RGradient n -> Point V2 n
_rGradCenter1      :: Point V2 n
  , forall n. RGradient n -> n
_rGradRadius1      :: n
  , forall n. RGradient n -> Transformation V2 n
_rGradTrans        :: Transformation V2 n
  , forall n. RGradient n -> SpreadMethod
_rGradSpreadMethod :: SpreadMethod }

makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient

type instance V (RGradient n) = V2
type instance N (RGradient n) = n

instance Fractional n => Transformable (RGradient n) where
  transform :: Transformation (V (RGradient n)) (N (RGradient n))
-> RGradient n -> RGradient n
transform = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

-- | A list of stops (colors and fractions).
rGradStops :: Lens' (RGradient n) [GradientStop n]

-- | The center point of the inner circle.
rGradCenter0 :: Lens' (RGradient n) (Point V2 n)

-- | The radius of the inner cirlce in 'local' coordinates.
rGradRadius0 :: Lens' (RGradient n) n

-- | The center of the outer circle.
rGradCenter1  :: Lens' (RGradient n) (Point V2 n)

-- | The radius of the outer circle in 'local' coordinates.
rGradRadius1 :: Lens' (RGradient n) n

-- | A transformation to be applied to the gradient. Usually this field will
--   start as the identity transform and capture the transforms that are applied
--   to the gradient.
rGradTrans :: Lens' (RGradient n) (Transformation V2 n)

-- | For setting the spread method.
rGradSpreadMethod :: Lens' (RGradient n) SpreadMethod

-----------------------------------------------------------------
--  Textures  ---------------------------------------------------
-----------------------------------------------------------------

-- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'.
--   An object can have only one texture which is determined by the 'Last'
--   semigroup structure.
data Texture n = SC SomeColor | LG (LGradient n) | RG (RGradient n)
  deriving Typeable

type instance V (Texture n) = V2
type instance N (Texture n) = n

makePrisms ''Texture

-- | Prism onto an 'AlphaColour' 'Double' of a 'SC' texture.
_AC :: Prism' (Texture n) (AlphaColour Double)
_AC :: forall n. Prism' (Texture n) (AlphaColour Double)
_AC = forall n. Prism' (Texture n) SomeColor
_SC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' SomeColor (AlphaColour Double)
_SomeColor

instance Floating n => Transformable (Texture n) where
  transform :: Transformation (V (Texture n)) (N (Texture n))
-> Texture n -> Texture n
transform Transformation (V (Texture n)) (N (Texture n))
t (LG LGradient n
lg) = forall n. LGradient n -> Texture n
LG forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Texture n)) (N (Texture n))
t LGradient n
lg
  transform Transformation (V (Texture n)) (N (Texture n))
t (RG RGradient n
rg) = forall n. RGradient n -> Texture n
RG forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Texture n)) (N (Texture n))
t RGradient n
rg
  transform Transformation (V (Texture n)) (N (Texture n))
_ Texture n
sc      = Texture n
sc

-- | Convert a solid colour into a texture.
solid :: Color a => a -> Texture n
solid :: forall a n. Color a => a -> Texture n
solid = forall n. SomeColor -> Texture n
SC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> SomeColor
SomeColor

-- | A default is provided so that linear gradients can easily be created using
--   lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that
--   no default value is provided for @lGradStops@, this must be set before
--   the gradient value is used, otherwise the object will appear transparent.
defaultLG :: Fractional n => Texture n
defaultLG :: forall n. Fractional n => Texture n
defaultLG = forall n. LGradient n -> Texture n
LG LGradient
  { _lGradStops :: [GradientStop n]
_lGradStops        = []
  , _lGradStart :: Point V2 n
_lGradStart        = forall n. n -> n -> P2 n
mkP2 (-n
0.5) n
0
  , _lGradEnd :: Point V2 n
_lGradEnd          = forall n. n -> n -> P2 n
mkP2 n
0.5 n
0
  , _lGradTrans :: Transformation V2 n
_lGradTrans        = forall a. Monoid a => a
mempty
  , _lGradSpreadMethod :: SpreadMethod
_lGradSpreadMethod = SpreadMethod
GradPad
  }

-- | A default is provided so that radial gradients can easily be created using
--   lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that
--   no default value is provided for @rGradStops@, this must be set before
--   the gradient value is used, otherwise the object will appear transparent.
defaultRG :: Fractional n => Texture n
defaultRG :: forall n. Fractional n => Texture n
defaultRG = forall n. RGradient n -> Texture n
RG RGradient
  { _rGradStops :: [GradientStop n]
_rGradStops        = []
  , _rGradCenter0 :: Point V2 n
_rGradCenter0      = forall n. n -> n -> P2 n
mkP2 n
0 n
0
  , _rGradRadius0 :: n
_rGradRadius0      = n
0.0
  , _rGradCenter1 :: Point V2 n
_rGradCenter1      = forall n. n -> n -> P2 n
mkP2 n
0 n
0
  , _rGradRadius1 :: n
_rGradRadius1      = n
0.5
  , _rGradTrans :: Transformation V2 n
_rGradTrans        = forall a. Monoid a => a
mempty
  , _rGradSpreadMethod :: SpreadMethod
_rGradSpreadMethod = SpreadMethod
GradPad
  }

-- | A convenient function for making gradient stops from a list of triples.
--   (An opaque color, a stop fraction, an opacity).
mkStops :: [(Colour Double, d, Double)] -> [GradientStop d]
mkStops :: forall d. [(Colour Double, d, Double)] -> [GradientStop d]
mkStops = forall a b. (a -> b) -> [a] -> [b]
map (\(Colour Double
x, d
y, Double
z) -> forall d. SomeColor -> d -> GradientStop d
GradientStop (forall c. Color c => c -> SomeColor
SomeColor (forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity Colour Double
x Double
z)) d
y)

-- | Make a linear gradient texture from a stop list, start point, end point,
--   and 'SpreadMethod'. The 'lGradTrans' field is set to the identity
--   transfrom, to change it use the 'lGradTrans' lens.
mkLinearGradient :: Num n => [GradientStop n] -> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n
mkLinearGradient :: forall n.
Num n =>
[GradientStop n]
-> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n
mkLinearGradient [GradientStop n]
stops  Point V2 n
start Point V2 n
end SpreadMethod
spreadMethod
  = forall n. LGradient n -> Texture n
LG (forall n.
[GradientStop n]
-> Point V2 n
-> Point V2 n
-> Transformation V2 n
-> SpreadMethod
-> LGradient n
LGradient [GradientStop n]
stops Point V2 n
start Point V2 n
end forall a. Monoid a => a
mempty SpreadMethod
spreadMethod)

-- | Make a radial gradient texture from a stop list, radius, start point,
--   end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity
--   transfrom, to change it use the 'rGradTrans' lens.
mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n
                  -> Point V2 n -> n -> SpreadMethod -> Texture n
mkRadialGradient :: forall n.
Num n =>
[GradientStop n]
-> Point V2 n -> n -> Point V2 n -> n -> SpreadMethod -> Texture n
mkRadialGradient [GradientStop n]
stops Point V2 n
c0 n
r0 Point V2 n
c1 n
r1 SpreadMethod
spreadMethod
  = forall n. RGradient n -> Texture n
RG (forall n.
[GradientStop n]
-> Point V2 n
-> n
-> Point V2 n
-> n
-> Transformation V2 n
-> SpreadMethod
-> RGradient n
RGradient [GradientStop n]
stops Point V2 n
c0 n
r0 Point V2 n
c1 n
r1 forall a. Monoid a => a
mempty SpreadMethod
spreadMethod)

-- Line Texture --------------------------------------------------------

-- | The texture with which lines are drawn.  Note that child
--   textures always override parent textures.
--   More precisely, the semigroup structure on line texture attributes
--   is that of 'Last'.
newtype LineTexture n = LineTexture (Last (Texture n))
  deriving (Typeable, NonEmpty (LineTexture n) -> LineTexture n
LineTexture n -> LineTexture n -> LineTexture n
forall b. Integral b => b -> LineTexture n -> LineTexture n
forall n. NonEmpty (LineTexture n) -> LineTexture n
forall n. LineTexture n -> LineTexture n -> LineTexture n
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall n b. Integral b => b -> LineTexture n -> LineTexture n
stimes :: forall b. Integral b => b -> LineTexture n -> LineTexture n
$cstimes :: forall n b. Integral b => b -> LineTexture n -> LineTexture n
sconcat :: NonEmpty (LineTexture n) -> LineTexture n
$csconcat :: forall n. NonEmpty (LineTexture n) -> LineTexture n
<> :: LineTexture n -> LineTexture n -> LineTexture n
$c<> :: forall n. LineTexture n -> LineTexture n -> LineTexture n
Semigroup)
instance (Typeable n) => AttributeClass (LineTexture n)

type instance V (LineTexture n) = V2
type instance N (LineTexture n) = n

_LineTexture :: Iso (LineTexture n) (LineTexture n')
                    (Texture n)     (Texture n')
_LineTexture :: forall n n'.
Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n')
_LineTexture = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso forall n. LineTexture n -> Texture n
getLineTexture (forall n. Last (Texture n) -> LineTexture n
LineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last)

-- Only gradients get transformed. The transform is applied to the gradients
-- transform field. Colors are left unchanged.
instance Floating n => Transformable (LineTexture n) where
  transform :: Transformation (V (LineTexture n)) (N (LineTexture n))
-> LineTexture n -> LineTexture n
transform Transformation (V (LineTexture n)) (N (LineTexture n))
t (LineTexture (Last Texture n
tx)) = forall n. Last (Texture n) -> LineTexture n
LineTexture (forall a. a -> Last a
Last forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (LineTexture n)) (N (LineTexture n))
t Texture n
tx)

instance Default (LineTexture n) where
  def :: LineTexture n
def = forall n n'.
Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n')
_LineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Prism' (Texture n) SomeColor
_SC forall t b. AReview t b -> b -> t
## forall c. Color c => c -> SomeColor
SomeColor forall a. Num a => Colour a
black

mkLineTexture :: Texture n -> LineTexture n
mkLineTexture :: forall n. Texture n -> LineTexture n
mkLineTexture = forall n. Last (Texture n) -> LineTexture n
LineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last

getLineTexture :: LineTexture n -> Texture n
getLineTexture :: forall n. LineTexture n -> Texture n
getLineTexture (LineTexture (Last Texture n
t)) = Texture n
t

lineTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a
lineTexture :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
lineTexture = forall a d.
(AttributeClass a, Transformable a, V a ~ V d, N a ~ N d,
 HasStyle d) =>
a -> d -> d
applyTAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Last (Texture n) -> LineTexture n
LineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last

lineTextureA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LineTexture n -> a -> a
lineTextureA :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
LineTexture n -> a -> a
lineTextureA = forall a d.
(AttributeClass a, Transformable a, V a ~ V d, N a ~ N d,
 HasStyle d) =>
a -> d -> d
applyTAttr

_lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n)
_lineTexture :: forall n.
(Floating n, Typeable n) =>
Lens' (Style V2 n) (Texture n)
_lineTexture = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Lens' (Style v n) (Maybe a)
atTAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> (a -> Bool) -> Iso' (Maybe a) a
anon forall a. Default a => a
def forall {n'}. LineTexture n' -> Bool
isDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n n'.
Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n')
_LineTexture
  where
    isDef :: LineTexture n' -> Bool
isDef = forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (forall n n'.
Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n')
_LineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Prism' (Texture n) (AlphaColour Double)
_AC) (forall a. Eq a => a -> a -> Bool
== forall a. Num a => Colour a -> AlphaColour a
opaque forall a. Num a => Colour a
black)

-- | Set the line (stroke) color.  This function is polymorphic in the
--   color type (so it can be used with either 'Colour' or
--   'AlphaColour'), but this can sometimes create problems for type
--   inference, so the 'lc' and 'lcA' variants are provided with more
--   concrete types.
lineColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a
lineColor :: forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
lineColor = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
lineTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. SomeColor -> Texture n
SC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> SomeColor
SomeColor

-- | A synonym for 'lineColor', specialized to @'Colour' Double@
--   (i.e. opaque colors).  See comment in 'lineColor' about backends.
lc :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Colour Double -> a -> a
lc :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc = forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
lineColor

-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@
--   (i.e. colors with transparency).  See comment in 'lineColor'
--   about backends.
lcA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => AlphaColour Double -> a -> a
lcA :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
AlphaColour Double -> a -> a
lcA = forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
lineColor

-- | Apply a linear gradient.
lineLGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LGradient n -> a -> a
lineLGradient :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
LGradient n -> a -> a
lineLGradient LGradient n
g = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
lineTexture (forall n. LGradient n -> Texture n
LG LGradient n
g)

-- | Apply a radial gradient.
lineRGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => RGradient n -> a -> a
lineRGradient :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
RGradient n -> a -> a
lineRGradient RGradient n
g = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
lineTexture (forall n. RGradient n -> Texture n
RG RGradient n
g)

-- Fill Texture --------------------------------------------------------

-- | The texture with which objects are filled.
--   The semigroup structure on fill texture attributes
--   is that of 'Recommed . Last'.
newtype FillTexture n = FillTexture (Recommend (Last (Texture n)))
  deriving (Typeable, NonEmpty (FillTexture n) -> FillTexture n
FillTexture n -> FillTexture n -> FillTexture n
forall b. Integral b => b -> FillTexture n -> FillTexture n
forall n. NonEmpty (FillTexture n) -> FillTexture n
forall n. FillTexture n -> FillTexture n -> FillTexture n
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall n b. Integral b => b -> FillTexture n -> FillTexture n
stimes :: forall b. Integral b => b -> FillTexture n -> FillTexture n
$cstimes :: forall n b. Integral b => b -> FillTexture n -> FillTexture n
sconcat :: NonEmpty (FillTexture n) -> FillTexture n
$csconcat :: forall n. NonEmpty (FillTexture n) -> FillTexture n
<> :: FillTexture n -> FillTexture n -> FillTexture n
$c<> :: forall n. FillTexture n -> FillTexture n -> FillTexture n
Semigroup)

instance Typeable n => AttributeClass (FillTexture n)

_FillTexture :: Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture :: forall n. Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso forall {n}. FillTexture n -> Recommend (Texture n)
getter forall {n}. Recommend (Texture n) -> FillTexture n
setter
  where
    getter :: FillTexture n -> Recommend (Texture n)
getter (FillTexture (Recommend (Last Texture n
t))) = forall a. a -> Recommend a
Recommend Texture n
t
    getter (FillTexture (Commit    (Last Texture n
t))) = forall a. a -> Recommend a
Commit Texture n
t
    setter :: Recommend (Texture n) -> FillTexture n
setter (Recommend Texture n
t) = forall n. Recommend (Last (Texture n)) -> FillTexture n
FillTexture (forall a. a -> Recommend a
Recommend (forall a. a -> Last a
Last Texture n
t))
    setter (Commit Texture n
t)    = forall n. Recommend (Last (Texture n)) -> FillTexture n
FillTexture (forall a. a -> Recommend a
Commit (forall a. a -> Last a
Last Texture n
t))
  -- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped
  -- -- once we depend on monoid-extras-0.4

type instance V (FillTexture n) = V2
type instance N (FillTexture n) = n

-- Only gradients get transformed. The transform is applied to the gradients
-- transform field. Colors are left unchanged.
instance Floating n => Transformable (FillTexture n) where
  transform :: Transformation (V (FillTexture n)) (N (FillTexture n))
-> FillTexture n -> FillTexture n
transform = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall n. Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Lens (Recommend a) (Recommend b) a b
_recommend) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

instance Default (FillTexture n) where
  def :: FillTexture n
def = forall n. Texture n -> FillTexture n
mkFillTexture forall a b. (a -> b) -> a -> b
$ forall n. Prism' (Texture n) (AlphaColour Double)
_AC forall t b. AReview t b -> b -> t
## forall a. Num a => AlphaColour a
transparent

getFillTexture :: FillTexture n -> Texture n
getFillTexture :: forall n. FillTexture n -> Texture n
getFillTexture (FillTexture Recommend (Last (Texture n))
tx) = forall a. Last a -> a
getLast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Recommend a -> a
getRecommend forall a b. (a -> b) -> a -> b
$ Recommend (Last (Texture n))
tx

fillTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a
fillTexture :: forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
fillTexture = forall a d.
(AttributeClass a, Transformable a, V a ~ V d, N a ~ N d,
 HasStyle d) =>
a -> d -> d
applyTAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Texture n -> FillTexture n
mkFillTexture

mkFillTexture :: Texture n -> FillTexture n
mkFillTexture :: forall n. Texture n -> FillTexture n
mkFillTexture = forall n. Recommend (Last (Texture n)) -> FillTexture n
FillTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Recommend a
Commit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last

-- | Lens onto the 'Recommend' of a fill texture in a style.
_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n))
_fillTextureR :: forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Recommend (Texture n))
_fillTextureR = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Lens' (Style v n) (Maybe a)
atTAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> (a -> Bool) -> Iso' (Maybe a) a
anon forall a. Default a => a
def forall {n}. FillTexture n -> Bool
isDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture
  where
    isDef :: FillTexture n -> Bool
isDef = forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (forall n. Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Prism' (Recommend a) a
_Recommend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Prism' (Texture n) (AlphaColour Double)
_AC) (forall a. Eq a => a -> a -> Bool
== forall a. Num a => AlphaColour a
transparent)

-- | Commit a fill texture in a style. This is /not/ a valid setter
--   because it doesn't abide the functor law (see 'committed').
_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n)
_fillTexture :: forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Texture n)
_fillTexture = forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Recommend (Texture n))
_fillTextureR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Iso (Recommend a) (Recommend b) a b
committed

-- | Set the fill color.  This function is polymorphic in the color
--   type (so it can be used with either 'Colour' or 'AlphaColour'),
--   but this can sometimes create problems for type inference, so the
--   'fc' and 'fcA' variants are provided with more concrete types.
fillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a
fillColor :: forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
fillColor = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
fillTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. SomeColor -> Texture n
SC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> SomeColor
SomeColor

-- | Set a \"recommended\" fill color, to be used only if no explicit
--   calls to 'fillColor' (or 'fc', or 'fcA') are used.
--   See comment after 'fillColor' about backends.
recommendFillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a
recommendFillColor :: forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor =
  forall a d.
(AttributeClass a, Transformable a, V a ~ V d, N a ~ N d,
 HasStyle d) =>
a -> d -> d
applyTAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Recommend (Last (Texture n)) -> FillTexture n
FillTexture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Recommend a
Recommend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. SomeColor -> Texture n
SC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> SomeColor
SomeColor

-- | A synonym for 'fillColor', specialized to @'Colour' Double@
--   (i.e. opaque colors). See comment after 'fillColor' about backends.
fc :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => Colour Double -> a -> a
fc :: forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc = forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
fillColor

-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@
--   (i.e. colors with transparency). See comment after 'fillColor' about backends.
fcA :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => AlphaColour Double -> a -> a
fcA :: forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
AlphaColour Double -> a -> a
fcA = forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
fillColor

-- Split fills ---------------------------------------------------------

data FillTextureLoops n = FillTextureLoops

instance Typeable n => SplitAttribute (FillTextureLoops n) where
  type AttrType (FillTextureLoops n) = FillTexture n
  type PrimType (FillTextureLoops n) = Path V2 n

  primOK :: FillTextureLoops n -> PrimType (FillTextureLoops n) -> Bool
primOK FillTextureLoops n
_ = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (v :: * -> *) n. Trail v n -> Bool
isLoop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unLoc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Path v n -> [Located (Trail v n)]
pathTrails

-- | Push fill attributes down until they are at the root of subtrees
--   containing only loops. This makes life much easier for backends,
--   which typically have a semantics where fill attributes are
--   applied to lines/non-closed paths as well as loops/closed paths,
--   whereas in the semantics of diagrams, fill attributes only apply
--   to loops.
splitTextureFills
  :: forall b v n a. (
                     Typeable n) => RTree b v n a -> RTree b v n a
splitTextureFills :: forall b (v :: * -> *) n a.
Typeable n =>
RTree b v n a -> RTree b v n a
splitTextureFills = forall code b (v :: * -> *) n a.
SplitAttribute code =>
code -> RTree b v n a -> RTree b v n a
splitAttr (forall n. FillTextureLoops n
FillTextureLoops :: FillTextureLoops n)