content: {-# 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
  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
    { _stopColor    :: SomeColor
    , _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
    { _lGradStops        :: [GradientStop n]
    , _lGradStart        :: Point V2 n
    , _lGradEnd          :: Point V2 n
    , _lGradTrans        :: Transformation V2 n
    , _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 = over lGradTrans . 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
    { _rGradStops        :: [GradientStop n]
    , _rGradCenter0      :: Point V2 n
    , _rGradRadius0      :: n
    , _rGradCenter1      :: Point V2 n
    , _rGradRadius1      :: n
    , _rGradTrans        :: Transformation V2 n
    , _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 = over rGradTrans . 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 = _SC . _SomeColor
  
  instance Floating n => Transformable (Texture n) where
    transform t (LG lg) = LG $ transform t lg
    transform t (RG rg) = RG $ transform t rg
    transform _ sc      = sc
  
  -- | Convert a solid colour into a texture.
  solid :: Color a => a -> Texture n
  solid = SC . 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 = LG LGradient
    { _lGradStops        = []
    , _lGradStart        = mkP2 (-0.5) 0
    , _lGradEnd          = mkP2 0.5 0
    , _lGradTrans        = mempty
    , _lGradSpreadMethod = 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 = RG RGradient
    { _rGradStops        = []
    , _rGradCenter0      = mkP2 0 0
    , _rGradRadius0      = 0.0
    , _rGradCenter1      = mkP2 0 0
    , _rGradRadius1      = 0.5
    , _rGradTrans        = mempty
    , _rGradSpreadMethod = 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 = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) 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 stops  start end spreadMethod
    = LG (LGradient stops start end mempty 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 stops c0 r0 c1 r1 spreadMethod
    = RG (RGradient stops c0 r0 c1 r1 mempty 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, 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 = iso getLineTexture (LineTexture . 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 t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx)
  
  instance Default (LineTexture n) where
    def = _LineTexture . _SC ## SomeColor black
  
  mkLineTexture :: Texture n -> LineTexture n
  mkLineTexture = LineTexture . Last
  
  getLineTexture :: LineTexture n -> Texture n
  getLineTexture (LineTexture (Last t)) = t
  
  lineTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a
  lineTexture = applyTAttr . LineTexture . Last
  
  lineTextureA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LineTexture n -> a -> a
  lineTextureA = applyTAttr
  
  _lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n)
  _lineTexture = atTAttr . anon def isDef . _LineTexture
    where
      isDef = anyOf (_LineTexture . _AC) (== opaque 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 = lineTexture . SC . 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 = 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 = lineColor
  
  -- | Apply a linear gradient.
  lineLGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LGradient n -> a -> a
  lineLGradient g = lineTexture (LG g)
  
  -- | Apply a radial gradient.
  lineRGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => RGradient n -> a -> a
  lineRGradient g = lineTexture (RG 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, Semigroup)
  
  instance Typeable n => AttributeClass (FillTexture n)
  
  _FillTexture :: Iso' (FillTexture n) (Recommend (Texture n))
  _FillTexture = iso getter setter
    where
      getter (FillTexture (Recommend (Last t))) = Recommend t
      getter (FillTexture (Commit    (Last t))) = Commit t
      setter (Recommend t) = FillTexture (Recommend (Last t))
      setter (Commit t)    = FillTexture (Commit (Last 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 = over (_FillTexture . _recommend) . transform
  
  instance Default (FillTexture n) where
    def = mkFillTexture $ _AC ## transparent
  
  getFillTexture :: FillTexture n -> Texture n
  getFillTexture (FillTexture tx) = getLast . getRecommend $ tx
  
  fillTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a
  fillTexture = applyTAttr . mkFillTexture
  
  mkFillTexture :: Texture n -> FillTexture n
  mkFillTexture = FillTexture . Commit . 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 = atTAttr . anon def isDef . _FillTexture
    where
      isDef = anyOf (_FillTexture . _Recommend . _AC) (== 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 = _fillTextureR . 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 = fillTexture . SC . 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 =
    applyTAttr . FillTexture . Recommend . Last . SC . 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 = 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 = 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 _ = all (isLoop . unLoc) . 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 = splitAttr (FillTextureLoops :: FillTextureLoops n)
  