    {-# LANGUAGE ConstraintKinds       #-}
    {-# LANGUAGE DeriveDataTypeable    #-}
    {-# LANGUAGE FlexibleContexts      #-}
    {-# LANGUAGE FlexibleInstances     #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE ScopedTypeVariables   #-}
    {-# LANGUAGE StandaloneDeriving    #-}
    {-# LANGUAGE TemplateHaskell       #-}
    {-# LANGUAGE TypeFamilies          #-}
    {-# LANGUAGE UndecidableInstances  #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Diagrams.TwoD.Transform.ScaleInv
    -- Copyright   :  (c) 2012-2013 diagrams-lib team (see LICENSE)
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  diagrams-discuss@googlegroups.com
    --
    -- Wrapper for creating scale-invariant objects in two dimensions.
    --
    -----------------------------------------------------------------------------

    module Diagrams.Transform.ScaleInv
        ( ScaleInv(..)
        , scaleInvObj, scaleInvDir, scaleInvLoc
        , scaleInv, scaleInvPrim)
        where

    import           Control.Lens            (makeLenses, view, (^.))
    import           Data.Typeable

    import           Diagrams.Angle
    import           Diagrams.Core
    import           Diagrams.TwoD.Transform
    import           Diagrams.TwoD.Types

    import           Linear.Affine
    import           Linear.Vector

    -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/
    --   objects.  Intuitively, a scale-invariant object is affected by
    --   transformations like translations and rotations, but not by scales.
    --
    --   However, this is problematic when it comes to /non-uniform/
    --   scales (/e.g./ @scaleX 2 . scaleY 3@) since they can introduce a
    --   perceived rotational component.  The prototypical example is an
    --   arrowhead on the end of a path, which should be scale-invariant.
    --   However, applying a non-uniform scale to the path but not the
    --   arrowhead would leave the arrowhead pointing in the wrong
    --   direction.
    --
    --   Moreover, for objects whose local origin is not at the local
    --   origin of the parent diagram, any scale can result in a
    --   translational component as well.
    --
    --   The solution is to also store a point (indicating the location,
    --   /i.e./ the local origin) and a unit vector (indicating the
    --   /direction/) along with a scale-invariant object.  A
    --   transformation to be applied is decomposed into rotational and
    --   translational components as follows:
    --
    --   * The transformation is applied to the direction vector, and the
    --   difference in angle between the original direction vector and its
    --   image under the transformation determines the rotational
    --   component.  The rotation is applied with respect to the stored
    --   location, rather than the global origin.
    --
    --   * The vector from the location to the image of the location under
    --   the transformation determines the translational component.

    data ScaleInv t =
      ScaleInv
      { ScaleInv t -> t
    _scaleInvObj :: t
      , ScaleInv t -> Vn t
    _scaleInvDir :: Vn t
      , ScaleInv t -> Point (V t) (N t)
    _scaleInvLoc :: Point (V t) (N t)
      }
      deriving Typeable

    deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t)

    makeLenses ''ScaleInv

    -- | Create a scale-invariant object pointing in the given direction,
    --   located at the origin.
    scaleInv :: (V t ~ v, N t ~ n, Additive v, Num n) => t -> v n -> ScaleInv t
    scaleInv :: t -> v n -> ScaleInv t
    scaleInv t :: t
    t d :: v n
    d = t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    ScaleInv t
    t v n
    Vn t
    d Point (V t) (N t)
    forall (f :: * -> *) a. (Additive f, Num a) => Point f a
    origin

    type instance V (ScaleInv t) = V t
    type instance N (ScaleInv t) = N t

    instance (V t ~ v, N t ~ n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where
      moveOriginTo :: Point (V (ScaleInv t)) (N (ScaleInv t)) -> ScaleInv t -> ScaleInv t
    moveOriginTo p :: Point (V (ScaleInv t)) (N (ScaleInv t))
    p (ScaleInv t :: t
    t v :: Vn t
    v l :: Point (V t) (N t)
    l) = t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    ScaleInv (Point (V t) (N t) -> t -> t
    forall t. HasOrigin t => Point (V t) (N t) -> t -> t
    moveOriginTo Point (V t) (N t)
    Point (V (ScaleInv t)) (N (ScaleInv t))
    p t
    t) Vn t
    v (Point (V (Point v n)) (N (Point v n)) -> Point v n -> Point v n
    forall t. HasOrigin t => Point (V t) (N t) -> t -> t
    moveOriginTo Point (V (Point v n)) (N (Point v n))
    Point (V (ScaleInv t)) (N (ScaleInv t))
    p Point v n
    Point (V t) (N t)
    l)

    instance (V t ~ V2, N t ~ n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where
      transform :: Transformation (V (ScaleInv t)) (N (ScaleInv t))
    -> ScaleInv t -> ScaleInv t
    transform tr :: Transformation (V (ScaleInv t)) (N (ScaleInv t))
    tr (ScaleInv t :: t
    t v :: Vn t
    v l :: Point (V t) (N t)
    l) = t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
    ScaleInv (t -> t
    trans (t -> t) -> (t -> t) -> t -> t
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . t -> t
    forall k. (V k ~ V t, N k ~ N t, Transformable k) => k -> k
    rot (t -> t) -> t -> t
    forall a b. (a -> b) -> a -> b
    $ t
    t) (V2 n -> V2 n
    forall k. (V k ~ V t, N k ~ N t, Transformable k) => k -> k
    rot Vn t
    V2 n
    v) Point (V t) (N t)
    Point V2 n
    l'
        where
          angle :: Angle n
    angle = Transformation (V (V2 n)) (N (V2 n)) -> V2 n -> V2 n
    forall t. Transformable t => Transformation (V t) (N t) -> t -> t
    transform Transformation (V (V2 n)) (N (V2 n))
    Transformation (V (ScaleInv t)) (N (ScaleInv t))
    tr Vn t
    V2 n
    v V2 n -> Getting (Angle n) (V2 n) (Angle n) -> Angle n
    forall s a. s -> Getting a s a -> a
    ^. Getting (Angle n) (V2 n) (Angle n)
    forall (t :: * -> *) n.
    (HasTheta t, RealFloat n) =>
    Lens' (t n) (Angle n)
    _theta

          rot :: (V k ~ V t, N k ~ N t, Transformable k) => k -> k
          rot :: k -> k
    rot = Point V2 n -> Angle n -> k -> k
    forall n t.
    (InSpace V2 n t, Transformable t, Floating n) =>
    P2 n -> Angle n -> t -> t
    rotateAround Point (V t) (N t)
    Point V2 n
    l Angle n
    angle

          l' :: Point V2 n
    l'  = Transformation (V (Point V2 n)) (N (Point V2 n))
    -> Point V2 n -> Point V2 n
    forall t. Transformable t => Transformation (V t) (N t) -> t -> t
    transform Transformation (V (Point V2 n)) (N (Point V2 n))
    Transformation (V (ScaleInv t)) (N (ScaleInv t))
    tr Point (V t) (N t)
    Point V2 n
    l

          trans :: t -> t
    trans = Vn t -> t -> t
    forall t. Transformable t => Vn t -> t -> t
    translate (Point V2 n
    l' Point V2 n -> Point V2 n -> Diff (Point V2) n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
    .-. Point (V t) (N t)
    Point V2 n
    l)

    {- Proof that the above satisfies the monoid action laws.

       1. transform mempty (ScaleInv t v l)
          = ScaleInv (trans . rot $ t) (rot v) l'
            { l'    = transform mempty l = l }
            { trans = translate (l' .-. l)
                    = translate (l .-. l)
                    = translate zeroV
                    = id
            }
            { rot   = rotateAround l angle
                    = rotateAround l (direction (transform mempty v) - direction v)
                    = rotateAround l (direction v - direction v)
                    = rotateAround l 0
                    = id
            }
          = ScaleInv t v l

      2. transform t1 (transform t2 (ScaleInv t v l))
         = let angle = direction (transform t2 v) - direction v
               rot   = rotateAround l angle
               l'    = transform t2 l
               trans = translate (l' .-. l)
           in
               transform t1 (ScaleInv (trans . rot $ t) (rot v) l')

         = let angle  = direction (transform t2 v) - direction v
               rot    = rotateAround l angle
               l'     = transform t2 l
               trans  = translate (l' .-. l)
               angle2 = direction (transform t1 (rot v)) - direction (rot v)
               rot2   = rotateAround l' angle2
               l'2    = transform t1 l'
               trans2 = translate (l'2 .-. l')
           in
               ScaleInv (trans2 . rot2 . trans . rot $ t) (rot2 . rot $ v) l'2

           { l'2 = transform t1 l'
                 = transform t1 (transform t2 l)
                 = transform (t1 <> t2) l
           }
           { trans2 = translate (l'2 .-. l')
                    = translate (transform (t1 <> t2) l .-. transform t2 l)
                    = translate (transform t1 l .-. l)
           }
           { rot v  = rotateAround l angle v
                    = rotate angle `under` translation (origin .-. l) $ v
                    = rotate angle v
           }
           { angle2 = direction (transform t1 (rot v)) - direction (rot v)
                    = direction (transform t1 (rotate angle v)) - direction (rotate angle v)
                    = direction (transform t1 (rotate angle v)) - direction v - angle
           }
           { rot2   = rotateAround l' angle2
                    = ???
           }

    -}

    instance (V t ~ V2, N t ~ n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where
      render :: b -> ScaleInv t -> Render b (V (ScaleInv t)) (N (ScaleInv t))
    render b :: b
    b = b -> t -> Render b (V t) (N t)
    forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
    render b
    b (t -> Render b (V t) (N t))
    -> (ScaleInv t -> t) -> ScaleInv t -> Render b (V t) (N t)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Getting t (ScaleInv t) t -> ScaleInv t -> t
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting t (ScaleInv t) t
    forall t. Lens' (ScaleInv t) t
    scaleInvObj

    -- | Create a diagram from a single scale-invariant primitive.  The
    --   vector argument specifies the direction in which the primitive is
    --   \"pointing\" (for the purpose of keeping it rotated correctly
    --   under non-uniform scaling).  The primitive is assumed to be
    --   \"located\" at the origin (for the purpose of translating it
    --   correctly under scaling).
    --
    --   Note that the resulting diagram will have an /empty/ envelope,
    --   trace, and query.  The reason is that the envelope, trace, and
    --   query cannot be cached---applying a transformation would cause
    --   the cached envelope, etc. to get \"out of sync\" with the
    --   scale-invariant object.  The intention, at any rate, is that
    --   scale-invariant things will be used only as \"decorations\" (/e.g./
    --   arrowheads) which should not affect the envelope, trace, and
    --   query.
    scaleInvPrim :: (V t ~ V2, N t ~ n, RealFloat n, Typeable t, Renderable t b, Monoid m)
                 => t -> V2 n -> QDiagram b (V t) (N t) m
    scaleInvPrim :: t -> V2 n -> QDiagram b (V t) (N t) m
    scaleInvPrim t :: t
    t d :: V2 n
    d = Prim b V2 n
    -> Envelope V2 n
    -> Trace V2 n
    -> SubMap b V2 n m
    -> Query V2 n m
    -> QDiagram b V2 n m
    forall b (v :: * -> *) n m.
    Prim b v n
    -> Envelope v n
    -> Trace v n
    -> SubMap b v n m
    -> Query v n m
    -> QDiagram b v n m
    mkQD (ScaleInv t -> Prim b V2 n
    forall p b.
    (Transformable p, Typeable p, Renderable p b) =>
    p -> Prim b (V p) (N p)
    Prim (ScaleInv t -> Prim b V2 n) -> ScaleInv t -> Prim b V2 n
    forall a b. (a -> b) -> a -> b
    $ t -> V2 n -> ScaleInv t
    forall t (v :: * -> *) n.
    (V t ~ v, N t ~ n, Additive v, Num n) =>
    t -> v n -> ScaleInv t
    scaleInv t
    t V2 n
    d) Envelope V2 n
    forall a. Monoid a => a
    mempty Trace V2 n
    forall a. Monoid a => a
    mempty SubMap b V2 n m
    forall a. Monoid a => a
    mempty Query V2 n m
    forall a. Monoid a => a
    mempty