{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.ThreeD.Attributes
-- Copyright   :  (c) 2014 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 relevant in
-- 3D; 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.ThreeD.Attributes where

import           Control.Lens
import           Data.Semigroup
import           Data.Typeable

import           Data.Colour

import           Diagrams.Core

-- | @SurfaceColor@ is the inherent pigment of an object, assumed to
-- be opaque.
newtype SurfaceColor = SurfaceColor (Last (Colour Double))
  deriving (Typeable, NonEmpty SurfaceColor -> SurfaceColor
SurfaceColor -> SurfaceColor -> SurfaceColor
forall b. Integral b => b -> SurfaceColor -> SurfaceColor
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> SurfaceColor -> SurfaceColor
$cstimes :: forall b. Integral b => b -> SurfaceColor -> SurfaceColor
sconcat :: NonEmpty SurfaceColor -> SurfaceColor
$csconcat :: NonEmpty SurfaceColor -> SurfaceColor
<> :: SurfaceColor -> SurfaceColor -> SurfaceColor
$c<> :: SurfaceColor -> SurfaceColor -> SurfaceColor
Semigroup, Int -> SurfaceColor -> ShowS
[SurfaceColor] -> ShowS
SurfaceColor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SurfaceColor] -> ShowS
$cshowList :: [SurfaceColor] -> ShowS
show :: SurfaceColor -> String
$cshow :: SurfaceColor -> String
showsPrec :: Int -> SurfaceColor -> ShowS
$cshowsPrec :: Int -> SurfaceColor -> ShowS
Show)

instance AttributeClass SurfaceColor

_SurfaceColor :: Iso' SurfaceColor (Colour Double)
_SurfaceColor :: Iso' SurfaceColor (Colour Double)
_SurfaceColor = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(SurfaceColor (Last Colour Double
c)) -> Colour Double
c) (Last (Colour Double) -> SurfaceColor
SurfaceColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last)

-- | Set the surface color.
sc :: HasStyle d => Colour Double -> d -> d
sc :: forall d. HasStyle d => Colour Double -> d -> d
sc = forall a d. (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Iso' SurfaceColor (Colour Double)
_SurfaceColor

-- | Lens onto the surface colour of a style.
_sc :: Lens' (Style v n) (Maybe (Colour Double))
_sc :: forall (v :: * -> *) n. Lens' (Style v n) (Maybe (Colour Double))
_sc = forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (g :: * -> *) s t a b.
(Functor f, Functor g) =>
AnIso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping Iso' SurfaceColor (Colour Double)
_SurfaceColor

-- | @Diffuse@ is the fraction of incident light reflected diffusely,
-- that is, in all directions.  The actual light reflected is the
-- product of this value, the incident light, and the @SurfaceColor@
-- Attribute.  For physical reasonableness, @Diffuse@ should have a
-- value between 0 and 1; this is not checked.
newtype Diffuse = Diffuse (Last Double)
  deriving (Typeable, NonEmpty Diffuse -> Diffuse
Diffuse -> Diffuse -> Diffuse
forall b. Integral b => b -> Diffuse -> Diffuse
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Diffuse -> Diffuse
$cstimes :: forall b. Integral b => b -> Diffuse -> Diffuse
sconcat :: NonEmpty Diffuse -> Diffuse
$csconcat :: NonEmpty Diffuse -> Diffuse
<> :: Diffuse -> Diffuse -> Diffuse
$c<> :: Diffuse -> Diffuse -> Diffuse
Semigroup, Int -> Diffuse -> ShowS
[Diffuse] -> ShowS
Diffuse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Diffuse] -> ShowS
$cshowList :: [Diffuse] -> ShowS
show :: Diffuse -> String
$cshow :: Diffuse -> String
showsPrec :: Int -> Diffuse -> ShowS
$cshowsPrec :: Int -> Diffuse -> ShowS
Show)

instance AttributeClass Diffuse

-- | Isomorphism between 'Diffuse' and 'Double'
_Diffuse :: Iso' Diffuse Double
_Diffuse :: Iso' Diffuse Double
_Diffuse = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Diffuse (Last Double
d)) -> Double
d) (Last Double -> Diffuse
Diffuse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last)

-- | Set the diffuse reflectance.
diffuse :: HasStyle d => Double -> d -> d
diffuse :: forall d. HasStyle d => Double -> d -> d
diffuse = forall a d. (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Iso' Diffuse Double
_Diffuse

-- | Lens onto the possible diffuse reflectance in a style.
_diffuse :: Lens' (Style v n) (Maybe Double)
_diffuse :: forall (v :: * -> *) n. Lens' (Style v n) (Maybe Double)
_diffuse = forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (g :: * -> *) s t a b.
(Functor f, Functor g) =>
AnIso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping Iso' Diffuse Double
_Diffuse

-- | @Ambient@ is an ad-hoc representation of indirect lighting.  The
-- product of @Ambient@ and @SurfaceColor@ is added to the light
-- leaving an object due to diffuse and specular terms.  @Ambient@ can
-- be set per-object, and can be loosely thought of as the product of
-- indirect lighting incident on that object and the diffuse
-- reflectance.
newtype Ambient = Ambient (Last Double)
  deriving (Typeable, NonEmpty Ambient -> Ambient
Ambient -> Ambient -> Ambient
forall b. Integral b => b -> Ambient -> Ambient
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Ambient -> Ambient
$cstimes :: forall b. Integral b => b -> Ambient -> Ambient
sconcat :: NonEmpty Ambient -> Ambient
$csconcat :: NonEmpty Ambient -> Ambient
<> :: Ambient -> Ambient -> Ambient
$c<> :: Ambient -> Ambient -> Ambient
Semigroup, Int -> Ambient -> ShowS
[Ambient] -> ShowS
Ambient -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ambient] -> ShowS
$cshowList :: [Ambient] -> ShowS
show :: Ambient -> String
$cshow :: Ambient -> String
showsPrec :: Int -> Ambient -> ShowS
$cshowsPrec :: Int -> Ambient -> ShowS
Show)

instance AttributeClass Ambient

_Ambient :: Iso' Ambient Double
_Ambient :: Iso' Ambient Double
_Ambient = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Ambient (Last Double
d)) -> Double
d) (Last Double -> Ambient
Ambient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last)

-- | Set the emittance due to ambient light.
ambient :: HasStyle d => Double -> d -> d
ambient :: forall d. HasStyle d => Double -> d -> d
ambient = forall a d. (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Iso' Ambient Double
_Ambient

-- | Lens onto the possible ambience in a style.
_ambient :: Lens' (Style v n) (Maybe Double)
_ambient :: forall (v :: * -> *) n. Lens' (Style v n) (Maybe Double)
_ambient = forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (g :: * -> *) s t a b.
(Functor f, Functor g) =>
AnIso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping Iso' Ambient Double
_Ambient

-- | A specular highlight has two terms, the intensity, between 0 and
-- 1, and the size.  The highlight size is assumed to be the exponent
-- in a Phong shading model (though Backends are free to use a
-- different shading model).  In this model, reasonable values are
-- between 1 and 50 or so, with higher values for shinier objects.
-- Physically, the intensity and the value of @Diffuse@ must add up to
-- less than 1; this is not enforced.
data Specular = Specular
  { Specular -> Double
_specularIntensity :: Double
  , Specular -> Double
_specularSize      :: Double
  } deriving Int -> Specular -> ShowS
[Specular] -> ShowS
Specular -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Specular] -> ShowS
$cshowList :: [Specular] -> ShowS
show :: Specular -> String
$cshow :: Specular -> String
showsPrec :: Int -> Specular -> ShowS
$cshowsPrec :: Int -> Specular -> ShowS
Show

makeLenses ''Specular

newtype Highlight = Highlight (Last Specular)
  deriving (Typeable, NonEmpty Highlight -> Highlight
Highlight -> Highlight -> Highlight
forall b. Integral b => b -> Highlight -> Highlight
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Highlight -> Highlight
$cstimes :: forall b. Integral b => b -> Highlight -> Highlight
sconcat :: NonEmpty Highlight -> Highlight
$csconcat :: NonEmpty Highlight -> Highlight
<> :: Highlight -> Highlight -> Highlight
$c<> :: Highlight -> Highlight -> Highlight
Semigroup, Int -> Highlight -> ShowS
[Highlight] -> ShowS
Highlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Highlight] -> ShowS
$cshowList :: [Highlight] -> ShowS
show :: Highlight -> String
$cshow :: Highlight -> String
showsPrec :: Int -> Highlight -> ShowS
$cshowsPrec :: Int -> Highlight -> ShowS
Show)

instance AttributeClass Highlight

_Highlight :: Iso' Highlight Specular
_Highlight :: Iso' Highlight Specular
_Highlight = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Highlight (Last Specular
s)) -> Specular
s) (Last Specular -> Highlight
Highlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Last a
Last)

-- | Set the specular highlight.
highlight :: HasStyle d => Specular -> d -> d
highlight :: forall d. HasStyle d => Specular -> d -> d
highlight = forall a d. (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Iso' Highlight Specular
_Highlight

-- | Lens onto the possible specular highlight in a style
_highlight :: Lens' (Style v n) (Maybe Specular)
_highlight :: forall (v :: * -> *) n. Lens' (Style v n) (Maybe Specular)
_highlight = forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (g :: * -> *) s t a b.
(Functor f, Functor g) =>
AnIso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping Iso' Highlight Specular
_Highlight

-- | Traversal over the highlight intensity of a style. If the style has
--   no 'Specular', setting this will do nothing.
highlightIntensity :: Traversal' (Style v n) Double
highlightIntensity :: forall (v :: * -> *) n. Traversal' (Style v n) Double
highlightIntensity = forall (v :: * -> *) n. Lens' (Style v n) (Maybe Specular)
_highlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Specular Double
specularSize

-- | Traversal over the highlight size in a style. If the style has no
--   'Specular', setting this will do nothing.
highlightSize :: Traversal' (Style v n) Double
highlightSize :: forall (v :: * -> *) n. Traversal' (Style v n) Double
highlightSize = forall (v :: * -> *) n. Lens' (Style v n) (Maybe Specular)
_highlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Specular Double
specularSize