{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# 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
  { forall t. ScaleInv t -> t
_scaleInvObj :: t
  , forall t. ScaleInv t -> Vn t
_scaleInvDir :: Vn t
  , forall 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 :: forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, Additive v, Num n) =>
t -> v n -> ScaleInv t
scaleInv t
t v n
d = forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
ScaleInv t
t v n
d 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 Point (V (ScaleInv t)) (N (ScaleInv t))
p (ScaleInv t
t Vn t
v Point (V t) (N t)
l) = forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
ScaleInv (forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (ScaleInv t)) (N (ScaleInv t))
p t
t) Vn t
v (forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (ScaleInv t)) (N (ScaleInv t))
p 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 Transformation (V (ScaleInv t)) (N (ScaleInv t))
tr (ScaleInv t
t Vn t
v Point (V t) (N t)
l) = forall t. t -> Vn t -> Point (V t) (N t) -> ScaleInv t
ScaleInv (t -> t
trans forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. (V k ~ V t, N k ~ N t, Transformable k) => k -> k
rot forall a b. (a -> b) -> a -> b
$ t
t) (forall k. (V k ~ V t, N k ~ N t, Transformable k) => k -> k
rot Vn t
v) Point V2 n
l'
    where
      angle :: Angle n
angle = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (ScaleInv t)) (N (ScaleInv t))
tr Vn t
v forall s a. s -> Getting a s a -> a
^. 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 :: forall k. (V k ~ V t, N k ~ N t, Transformable k) => k -> k
rot = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
P2 n -> Angle n -> t -> t
rotateAround Point (V t) (N t)
l Angle n
angle

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

      trans :: t -> t
trans = forall t. Transformable t => Vn t -> t -> t
translate (Point V2 n
l' forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point (V t) (N t)
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 = forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render b
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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 :: forall t n b m.
(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
t V2 n
d = 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 (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim forall a b. (a -> b) -> a -> b
$ 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) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty