{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Attributes
-- Copyright   :  (c) 2011-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 some common attributes; particular
-- backends may also define more backend-specific attributes.
--
-- Every attribute type must have a /semigroup/ structure, that is, an
-- associative binary operation for combining two attributes into one.
-- Unless otherwise noted, all the attributes defined here use the
-- 'Last' structure, that is, combining two attributes simply keeps
-- the second one and throws away the first.  This means that child
-- attributes always override parent attributes.
--
-----------------------------------------------------------------------------

module Diagrams.Attributes (
    -- ** Standard measures
    ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none
  , tiny, verySmall, small, normal, large, veryLarge, huge

    -- ** Line width
  , LineWidth, getLineWidth
  , _LineWidth, _LineWidthM
  , lineWidth, lineWidthM
  , _lineWidth, _lw, _lineWidthU
  , lw, lwN, lwO, lwL, lwG

    -- ** Dashing
  , Dashing(..), getDashing
  , dashing, dashingN, dashingO, dashingL, dashingG
  , _dashing, _dashingU

  -- * Color
  -- $color

  , Color(..), SomeColor(..), _SomeColor, someToAlpha

  -- ** Opacity
  , Opacity, _Opacity
  , getOpacity, opacity, _opacity

  -- ** Converting colors
  , colorToSRGBA, colorToRGBA

  -- * Line stuff
  -- ** Cap style
  , LineCap(..)
  , getLineCap, lineCap, _lineCap

  -- ** Join style
  , LineJoin(..)
  , getLineJoin, lineJoin, _lineJoin

  -- ** Miter limit
  , LineMiterLimit(..), _LineMiterLimit
  , getLineMiterLimit, lineMiterLimit, lineMiterLimitA, _lineMiterLimit

  -- * Recommend optics

  , _Recommend
  , _Commit
  , _recommend
  , isCommitted
  , committed

  ) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
#endif
import           Control.Lens          hiding (none, over)
import           Data.Colour
import           Data.Colour.RGBSpace  (RGB (..))
import           Data.Colour.SRGB      (toSRGB)
import           Data.Default.Class
import           Data.Distributive
import           Data.Monoid.Recommend
import           Data.Semigroup
import           Data.Typeable

import           Diagrams.Core

------------------------------------------------------------------------
-- Standard measures
------------------------------------------------------------------------

none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick,
  tiny, verySmall, small, normal, large, veryLarge, huge
  :: OrderedField n => Measure n
none       = output 0
ultraThin  = normalized 0.0005 `atLeast` output 0.5
veryThin   = normalized 0.001  `atLeast` output 0.5
thin       = normalized 0.002  `atLeast` output 0.5
medium     = normalized 0.004  `atLeast` output 0.5
thick      = normalized 0.0075 `atLeast` output 0.5
veryThick  = normalized 0.01   `atLeast` output 0.5
ultraThick = normalized 0.02   `atLeast` output 0.5

tiny      = normalized 0.01
verySmall = normalized 0.015
small     = normalized 0.023
normal    = normalized 0.035
large     = normalized 0.05
veryLarge = normalized 0.07
huge      = normalized 0.10

------------------------------------------------------------------------
-- Line width
------------------------------------------------------------------------

-- | Line widths specified on child nodes always override line widths
--   specified at parent nodes.
newtype LineWidth n = LineWidth (Last n)
  deriving (Typeable, Semigroup)

_LineWidth :: Iso' (LineWidth n) n
_LineWidth = iso getLineWidth (LineWidth . Last)

_LineWidthM :: Iso' (LineWidthM n) (Measure n)
_LineWidthM = mapping _LineWidth

instance Typeable n => AttributeClass (LineWidth n)

type LineWidthM n = Measured n (LineWidth n)

instance OrderedField n => Default (LineWidthM n) where
  def = fmap (LineWidth . Last) medium

getLineWidth :: LineWidth n -> n
getLineWidth (LineWidth (Last w)) = w

-- | Set the line (stroke) width.
lineWidth :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a
lineWidth = applyMAttr . fmap (LineWidth . Last)

-- | Apply a 'LineWidth' attribute.
lineWidthM :: (N a ~ n, HasStyle a, Typeable n) => LineWidthM n -> a -> a
lineWidthM = applyMAttr

-- | Default for 'lineWidth'.
lw :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a
lw = lineWidth

-- | A convenient synonym for 'lineWidth (global w)'.
lwG :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG = lw . global

-- | A convenient synonym for 'lineWidth (normalized w)'.
lwN :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwN = lw . normalized

-- | A convenient synonym for 'lineWidth (output w)'.
lwO :: (N a ~ n, HasStyle a, Typeable n) => n -> a -> a
lwO = lw . output

-- | A convenient sysnonym for 'lineWidth (local w)'.
lwL :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL = lw . local

-- | Lens onto a measured line width in a style.
_lineWidth, _lw :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n)
_lineWidth = atMAttr . anon def (const False) . _LineWidthM
_lw = _lineWidth

-- | Lens onto the unmeasured linewith attribute. This is useful for
--   backends to use on styles once they have been unmeasured. Using on
--   a diagram style could lead to unexpected results.
_lineWidthU :: Typeable n => Lens' (Style v n) (Maybe n)
_lineWidthU = atAttr . mapping _LineWidth

------------------------------------------------------------------------
-- Dashing
------------------------------------------------------------------------

-- | Create lines that are dashing... er, dashed.
data Dashing n = Dashing [n] n
  deriving (Functor, Typeable, Eq)

instance Semigroup (Dashing n) where
  _ <> b = b

instance Typeable n => AttributeClass (Dashing n)

getDashing :: Dashing n -> Dashing n
getDashing = id

-- | Set the line dashing style.
dashing :: (N a ~ n, HasStyle a, Typeable n)
        => [Measure n]  -- ^ A list specifying alternate lengths of on
                        --   and off portions of the stroke.  The empty
                        --   list indicates no dashing.
        -> Measure n    -- ^ An offset into the dash pattern at which the
                        --   stroke should start.
        -> a -> a
dashing ds offs = applyMAttr . distribute $ Dashing ds offs

-- | A convenient synonym for 'dashing (global w)'.
dashingG :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a
dashingG w v = dashing (map global w) (global v)

-- | A convenient synonym for 'dashing (normalized w)'.
dashingN :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a
dashingN w v = dashing (map normalized w) (normalized v)

-- | A convenient synonym for 'dashing (output w)'.
dashingO :: (N a ~ n, HasStyle a, Typeable n) => [n] -> n -> a -> a
dashingO w v = dashing (map output w) (output v)

-- | A convenient sysnonym for 'dashing (local w)'.
dashingL :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a
dashingL w v = dashing (map local w) (local v)

-- | Lens onto a measured dashing attribute in a style.
_dashing :: Typeable n
         => Lens' (Style v n) (Maybe (Measured n (Dashing n)))
_dashing = atMAttr

-- | Lens onto the unmeasured 'Dashing' attribute. This is useful for
--   backends to use on styles once they have been unmeasured. Using on
--   a diagram style could lead to unexpected results.
_dashingU :: Typeable n => Lens' (Style v n) (Maybe (Dashing n))
_dashingU = atAttr

------------------------------------------------------------------------
-- Color
------------------------------------------------------------------------

-- $color
-- Diagrams outsources all things color-related to Russell O\'Connor\'s
-- very nice colour package
-- (<http://hackage.haskell.org/package/colour>).  For starters, it
-- provides a large collection of standard color names.  However, it
-- also provides a rich set of combinators for combining and
-- manipulating colors; see its documentation for more information.

-- | The 'Color' type class encompasses color representations which
--   can be used by the Diagrams library.  Instances are provided for
--   both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types
--   from the "Data.Colour" library.
class Color c where
  -- | Convert a color to its standard representation, AlphaColour.
  toAlphaColour :: c -> AlphaColour Double

  -- | Convert from an AlphaColour Double.  Note that this direction
  --   may lose some information. For example, the instance for
  --   'Colour' drops the alpha channel.
  fromAlphaColour :: AlphaColour Double -> c

-- | An existential wrapper for instances of the 'Color' class.
data SomeColor = forall c. Color c => SomeColor c
  deriving Typeable

instance Show SomeColor where
  showsPrec d (colorToSRGBA -> (r,g,b,a)) =
    showParen (d > 10) $ showString "SomeColor " .
      if a == 0
        then showString "transparent"
        else showString "(sRGB " . showsPrec 11 r . showChar ' '
                                 . showsPrec 11 g . showChar ' '
                                 . showsPrec 11 b .
                        (if a /= 1
                           then showString " `withOpacity` " . showsPrec 11 a
                           else id) . showChar ')'

-- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'.
_SomeColor :: Iso' SomeColor (AlphaColour Double)
_SomeColor = iso toAlphaColour fromAlphaColour

someToAlpha :: SomeColor -> AlphaColour Double
someToAlpha (SomeColor c) = toAlphaColour c

instance a ~ Double => Color (Colour a) where
  toAlphaColour   = opaque
  fromAlphaColour = (`over` black)

instance a ~ Double => Color (AlphaColour a) where
  toAlphaColour   = id
  fromAlphaColour = id

instance Color SomeColor where
  toAlphaColour (SomeColor c) = toAlphaColour c
  fromAlphaColour             = SomeColor

-- | Convert to sRGBA.
colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double)
colorToSRGBA col = (r, g, b, a)
  where
    c' = toAlphaColour col
    c = alphaToColour c'
    a = alphaChannel c'
    RGB r g b = toSRGB c

colorToRGBA = colorToSRGBA
{-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-}

alphaToColour :: (Floating a, Ord a) => AlphaColour a -> Colour a
alphaToColour ac | alphaChannel ac == 0 = ac `over` black
                 | otherwise = darken (recip (alphaChannel ac)) (ac `over` black)

------------------------------------------------------------------------
-- Opacity
------------------------------------------------------------------------

-- | Although the individual colors in a diagram can have
--   transparency, the opacity/transparency of a diagram as a whole
--   can be specified with the @Opacity@ attribute.  The opacity is a
--   value between 1 (completely opaque, the default) and 0
--   (completely transparent).  Opacity is multiplicative, that is,
--   @'opacity' o1 . 'opacity' o2 === 'opacity' (o1 * o2)@.  In other
--   words, for example, @opacity 0.8@ means \"decrease this diagram's
--   opacity to 80% of its previous opacity\".
newtype Opacity = Opacity (Product Double)
  deriving (Typeable, Semigroup)
instance AttributeClass Opacity

_Opacity :: Iso' Opacity Double
_Opacity = iso getOpacity (Opacity . Product)

getOpacity :: Opacity -> Double
getOpacity (Opacity (Product d)) = d

-- | Multiply the opacity (see 'Opacity') by the given value.  For
--   example, @opacity 0.8@ means \"decrease this diagram's opacity to
--   80% of its previous opacity\".
opacity :: HasStyle a => Double -> a -> a
opacity = applyAttr . Opacity . Product

-- | Lens onto the opacity in a style.
_opacity :: Lens' (Style v n) Double
_opacity = atAttr . mapping _Opacity . non 1

------------------------------------------------------------------------
-- Line stuff
------------------------------------------------------------------------

-- line cap ------------------------------------------------------------

-- | What sort of shape should be placed at the endpoints of lines?
data LineCap = LineCapButt   -- ^ Lines end precisely at their endpoints.
             | LineCapRound  -- ^ Lines are capped with semicircles
                             --   centered on endpoints.
             | LineCapSquare -- ^ Lines are capped with a squares
                             --   centered on endpoints.
  deriving (Eq, Ord, Show, Typeable)

instance Default LineCap where
  def = LineCapButt

instance AttributeClass LineCap

-- | Last semigroup structure.
instance Semigroup LineCap where
  _ <> b = b

getLineCap :: LineCap -> LineCap
getLineCap = id

-- | Set the line end cap attribute.
lineCap :: HasStyle a => LineCap -> a -> a
lineCap = applyAttr

-- | Lens onto the line cap in a style.
_lineCap :: Lens' (Style v n) LineCap
_lineCap = atAttr . non def

-- line join -----------------------------------------------------------

-- | How should the join points between line segments be drawn?
data LineJoin = LineJoinMiter    -- ^ Use a \"miter\" shape (whatever that is).
              | LineJoinRound    -- ^ Use rounded join points.
              | LineJoinBevel    -- ^ Use a \"bevel\" shape (whatever
                                 --   that is).  Are these...
                                 --   carpentry terms?
  deriving (Eq, Ord, Show, Typeable)

instance AttributeClass LineJoin

-- | Last semigroup structure.
instance Semigroup LineJoin where
  _ <> b = b

instance Default LineJoin where
  def = LineJoinMiter

getLineJoin :: LineJoin -> LineJoin
getLineJoin = id

-- | Set the segment join style.
lineJoin :: HasStyle a => LineJoin -> a -> a
lineJoin = applyAttr

-- | Lens onto the line join type in a style.
_lineJoin :: Lens' (Style v n) LineJoin
_lineJoin = atAttr . non def

-- miter limit ---------------------------------------------------------

-- | Miter limit attribute affecting the 'LineJoinMiter' joins.
--   For some backends this value may have additional effects.
newtype LineMiterLimit = LineMiterLimit (Last Double)
  deriving (Typeable, Semigroup, Eq, Ord)
instance AttributeClass LineMiterLimit

_LineMiterLimit :: Iso' LineMiterLimit Double
_LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last)

instance Default LineMiterLimit where
  def = LineMiterLimit (Last 10)

getLineMiterLimit :: LineMiterLimit -> Double
getLineMiterLimit (LineMiterLimit (Last l)) = l

-- | Set the miter limit for joins with 'LineJoinMiter'.
lineMiterLimit :: HasStyle a => Double -> a -> a
lineMiterLimit = applyAttr . LineMiterLimit . Last

-- | Apply a 'LineMiterLimit' attribute.
lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a
lineMiterLimitA = applyAttr

-- | Lens onto the line miter limit in a style.
_lineMiterLimit :: Lens' (Style v n) Double
_lineMiterLimit = atAttr . non def . _LineMiterLimit

------------------------------------------------------------------------
-- Recommend optics
------------------------------------------------------------------------

-- | Prism onto a 'Recommend'.
_Recommend :: Prism' (Recommend a) a
_Recommend = prism' Recommend $ \case (Recommend a) -> Just a; _ -> Nothing

-- | Prism onto a 'Commit'.
_Commit :: Prism' (Recommend a) a
_Commit = prism' Commit $ \case (Commit a) -> Just a; _ -> Nothing

-- | Lens onto the value inside either a 'Recommend' or 'Commit'. Unlike
--   'committed', this is a valid lens.
_recommend :: Lens (Recommend a) (Recommend b) a b
_recommend f (Recommend a) = Recommend <$> f a
_recommend f (Commit a)    = Commit <$> f a

-- | Lens onto whether something is committed or not.
isCommitted :: Lens' (Recommend a) Bool
isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r
isCommitted f r@(Commit a)    = f True  <&> \b -> if b then r else Recommend a

-- | 'Commit' a value for any 'Recommend'. This is *not* a valid 'Iso'
--   because the resulting @Recommend b@ is always a 'Commit'. This is
--   useful because it means any 'Recommend' styles set with a lens will
--   not be accidentally overridden. If you want a valid lens onto a
--   recommend value use '_recommend'.
--
--   Other lenses that use this are labeled with a warning.
committed :: Iso (Recommend a) (Recommend b) a b
committed = iso getRecommend Commit