{-# LANGUAGE DefaultSignatures         #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DeriveDataTypeable        #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Anchors
-- Copyright   :  (c) 2016 Bradley Hardy
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  bradleyhardy@live.com
--
-- An /anchor/ is a point on an object which can be used for alignment
-- by naming it, offering easier control over alignment compared to the
-- 'Diagrams.Align' module when aligning many objects.
--
-----------------------------------------------------------------------------

module Diagrams.Anchors
       (
         -- * Anchors
         Anchor
         -- * Anchored objects
       , Anchored
       , withAnchors
       , noAnchors
       , addAnchor
       , deleteAnchor
       , getAnchorOffset
       , alignAnchor
       , hasAnchor
       , unanchor
         -- * Positional anchors
       , PositionalAnchor (..)
       , rotateAnchors
       , rotatePosAnchors
         -- * Easily concatenate many anchored objects
       , anchorMany
       , anchorMany_
         -- * Debugging
       , showAnchor
       , showAnchor_)
       where

import           Diagrams.Names
import           Diagrams.Core
import           Diagrams.Path
import           Diagrams.TwoD.Model

import qualified Control.Lens     as Lens
import           Control.Lens     hiding (transform, (.>))
import           Data.List        (foldl')
import           Data.Map         (Map)
import qualified Data.Map         as Map
import           Data.Maybe       (fromJust, fromMaybe)
import qualified Data.Set         as Set
import           Data.Typeable    (Typeable)
import           Data.Semigroup

import           Linear.Vector
import           Linear.V2
import           Linear.Affine

--------------------------------------------------------------------------------
--  Anchors
--------------------------------------------------------------------------------

type Anchor = Name

--------------------------------------------------------------------------------
--  Anchored objects
--------------------------------------------------------------------------------

-- | An 'Anchored' object which can be aligned to anchor points before
-- concatenating with other 'Anchored' objects. Note that when concatenating,
-- any anchors with the same names in each of the left and right operands will
-- be retained in the left operand, and lost in the right. To avoid this, qualify
-- anchors in each object using '(\>>/)'.
data Anchored t =
  Anchored
  { _currentAnchor :: Maybe Anchor
  , _anchors :: Map Anchor (V t (N t))
  , _anchoredObj :: t
  }

makeLenses ''Anchored

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

instance (HasOrigin t, Additive (V t), Num (N t)) => HasOrigin (Anchored t) where
  moveOriginTo p@(P v) =
    (anchoredObj %~ moveOriginTo p) .
    (anchors . traverse %~ (^-^ v))

instance (Transformable t) => Transformable (Anchored t) where
  transform t =
    (anchors . traverse %~ apply t) .
    (anchoredObj %~ transform t)

instance (Additive (V t), Num (N t), HasOrigin t, Semigroup t) => Semigroup (Anchored t) where
  o1 <> o2 =
    let updateObj obj
          | Just anchor <- obj^.currentAnchor
            = moveOriginBy (getAnchorOffset anchor obj)
            . deleteAnchor anchor
            $ obj
          | otherwise = obj

        a1 <+> a2 = Anchored Nothing
                             ((a1 ^. anchors) <> (a2 ^. anchors))
                             ((a1 ^. anchoredObj) <> (a2 ^. anchoredObj))
    in updateObj o1 <+> updateObj o2

instance (Additive (V t), Num (N t), HasOrigin t, Monoid' t) => Monoid (Anchored t) where
  mempty = Anchored Nothing mempty mempty
  mappend = (<>)

instance (Show (V t (N t)), Show t) => Show (Anchored t) where
  showsPrec p anch =
    showsPrec p (anch^.anchors) . (", " ++) . showsPrec p (anch^.anchoredObj)

-- | Add another anchor to an already 'Anchored' object.
addAnchor :: IsName anchor => anchor -> V t (N t) -> Anchored t -> Anchored t
addAnchor anchor val = anchors . Lens.at (toName anchor) .~ Just val

-- | Attach a list of anchors to an object, making it 'Anchored'.
withAnchors :: IsName anchor => [(anchor, V t (N t))] -> t -> Anchored t
withAnchors = Anchored Nothing . Map.fromList . over (each . _1) toName

-- | Turn an object into a trivial 'Anchored' object with no anchors.
noAnchors :: t -> Anchored t
noAnchors = Anchored Nothing mempty

-- | Delete an anchor from an anchored object. Does nothing if the object does
-- not have the specified anchor.
deleteAnchor :: IsName anchor => anchor -> Anchored t -> Anchored t
deleteAnchor anchor = anchors . Lens.at (toName anchor) .~ Nothing

-- | Get the offset from the origin of a particular anchor, or 'zero' if the object
-- does not have the specified anchor.
getAnchorOffset :: (Num (N t), Additive (V t), IsName a) => a -> Anchored t -> V t (N t)
getAnchorOffset anchor = view $ anchors . Lens.at (toName anchor) . to (fromMaybe zero)

-- | Align an anchored object to an anchor. Subsequently concatening with '(<>)'
-- will take this into account.
alignAnchor :: (IsName a) => a -> Anchored t -> Anchored t
alignAnchor anch = currentAnchor .~ Just (toName anch)

-- | Does the given anchored object have the given anchor?
hasAnchor :: (IsName a) => a -> Anchored t -> Bool
hasAnchor anchor = view $ anchors . to (Map.member (toName anchor))

-- | Throw away anchors and get the underlying object.
unanchor
  :: Anchored t -> t
unanchor = view anchoredObj

--------------------------------------------------------------------------------
--  Positional Anchors
--------------------------------------------------------------------------------

-- | A convenient type of positional anchors.
data PositionalAnchor
  = AnchorL
  | AnchorTL
  | AnchorT
  | AnchorTR
  | AnchorR
  | AnchorBR
  | AnchorB
  | AnchorBL
  deriving (Eq, Ord, Show, Typeable, Enum)

instance IsName PositionalAnchor where

{-|
Given an 'Anchored' object containing the given list of anchors, rotate the
order of the given anchors clockwise by the given number of positions.

For example, given a diagram with positional anchors on it in these positions:

@
TL    T    TR

L          R

BL    B    BR
@

using @'rotatePosAnchors' 1 = 'rotateAnchors' (enumFrom AnchorL) 1@ will move
the anchors to these positions:

@
L     TL   T

BL         TR

B     BR   R
@

Using a parameter @n@ is equivalent to using @1@, @n@ times and a negative
number produces an anticlockwise rotation.

If any of the anchors do not exist, this function skips them.
-}
rotateAnchors :: (IsName anchor) => [anchor] -> Int -> Anchored t -> Anchored t
rotateAnchors allAnchorsList n t =
  let allAnchorsSet = Set.fromList . map toName $ allAnchorsList
      allObjAnchors = t ^. anchors
      presentAnchorsSet = Map.keysSet allObjAnchors `Set.intersection` allAnchorsSet
      presentAnchorsList = filter ((`Set.member` presentAnchorsSet) . toName) allAnchorsList
      rotateList k xs = drop k xs ++ take k xs
      rotatedList = rotateList ((-n) `mod` length presentAnchorsList) presentAnchorsList
      findOriginalPairing posAnch = fromJust $ Map.lookup (toName posAnch) allObjAnchors
      originalOffsets = map findOriginalPairing presentAnchorsList
      rotatedOffsets = zip (map toName rotatedList) originalOffsets
      newObjAnchors = Map.fromList rotatedOffsets `Map.union` allObjAnchors
  in t & anchors .~ newObjAnchors

-- | As 'rotateAnchors', but specialised to the list of all 'PositionalAnchor's.
rotatePosAnchors :: Int -> Anchored t -> Anchored t
rotatePosAnchors = rotateAnchors (enumFrom AnchorL)

--------------------------------------------------------------------------------
--  Qualifying Anchors
--------------------------------------------------------------------------------

instance Qualifiable t => Qualifiable (Anchored t) where
  (.>>) name =
    (currentAnchor . _Just %~ (name .>)) .
    (anchors %~ Map.mapKeys (name .>)) .
    (anchoredObj %~ (name .>>))

--------------------------------------------------------------------------------
--  Easily concatenate many anchored objects
--------------------------------------------------------------------------------

{-|
Starting from a base anchored object, recursively concatenate more objects to
the structure built up so far. Be sure to qualify anchors in the input so that
names aren't overwritten.

In each @(thatAnchor, thisAnchor, obj)@ triple, @thatAnchor@ refers to the
anchor point in the structure already constructed, and @thisAnchor@ refers to
the anchor point in the new object being added.
-}
anchorMany
  :: (Num (N t), Semigroup t, Additive (V t), HasOrigin t,
      IsName anchor) =>
     Anchored t -> [(anchor, anchor, Anchored t)] -> Anchored t
anchorMany = foldl' go
  where
    go base (thatAnch, thisAnch, obj)
      = alignAnchor thatAnch base <> alignAnchor thisAnch obj

-- | As 'anchorMany', but call 'unanchor' on the result. Convenient when you're
-- not going to be doing any more alignment using anchors with the result.
anchorMany_
  :: (Num (N c), Semigroup c, Additive (V c), HasOrigin c,
      IsName anchor) =>
     Anchored c -> [(anchor, anchor, Anchored c)] -> c
anchorMany_ base = unanchor . anchorMany base

--------------------------------------------------------------------------------
--  Debugging
--------------------------------------------------------------------------------

-- | Show a particular anchor in the 'Anchored' object.
showAnchor
  :: (RealFloat n, Typeable n, Monoid m, Semigroup m,
      Renderable (Path V2 n) b, IsName a) =>
     a -> Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
showAnchor anch = moveFromAnchor . over anchoredObj showOrigin . moveToAnchor
  where
    moveToAnchor   t = t & anchoredObj %~ moveOriginBy ( getAnchorOffset anch t)
    moveFromAnchor t = t & anchoredObj %~ moveOriginBy (-getAnchorOffset anch t)

-- | Show a particular anchor in the 'Anchored' object, then 'unanchor'.
showAnchor_
  :: (RealFloat n, Typeable n, Monoid m, Semigroup m,
      Renderable (Path V2 n) b, IsName a) =>
     a -> Anchored (QDiagram b V2 n m) -> QDiagram b V2 n m
showAnchor_ anch = unanchor . showAnchor anch