{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Parametric.Adjust
-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Tools for adjusting the length of parametric objects such as
-- segments and trails.
--
-----------------------------------------------------------------------------
module Diagrams.Parametric.Adjust
    ( adjust
    , AdjustOpts(_adjMethod, _adjSide, _adjEps)
    , adjMethod, adjSide, adjEps
    , AdjustMethod(..), AdjustSide(..)

    ) where

import           Control.Lens        (Lens', generateSignatures, lensRules, makeLensesWith, (&),
                                      (.~), (^.))
import           Data.Proxy

import           Data.Default.Class

import           Diagrams.Core.V
import           Diagrams.Parametric

-- | What method should be used for adjusting a segment, trail, or
--   path?
data AdjustMethod n = ByParam n     -- ^ Extend by the given parameter value
                                    --   (use a negative parameter to shrink)
                    | ByAbsolute n  -- ^ Extend by the given arc length
                                    --   (use a negative length to shrink)
                    | ToAbsolute n  -- ^ Extend or shrink to the given
                                    --   arc length

-- | Which side of a segment, trail, or path should be adjusted?
data AdjustSide = Start  -- ^ Adjust only the beginning
                | End    -- ^ Adjust only the end
                | Both   -- ^ Adjust both sides equally
  deriving (Int -> AdjustSide -> ShowS
[AdjustSide] -> ShowS
AdjustSide -> String
(Int -> AdjustSide -> ShowS)
-> (AdjustSide -> String)
-> ([AdjustSide] -> ShowS)
-> Show AdjustSide
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AdjustSide -> ShowS
showsPrec :: Int -> AdjustSide -> ShowS
$cshow :: AdjustSide -> String
show :: AdjustSide -> String
$cshowList :: [AdjustSide] -> ShowS
showList :: [AdjustSide] -> ShowS
Show, ReadPrec [AdjustSide]
ReadPrec AdjustSide
Int -> ReadS AdjustSide
ReadS [AdjustSide]
(Int -> ReadS AdjustSide)
-> ReadS [AdjustSide]
-> ReadPrec AdjustSide
-> ReadPrec [AdjustSide]
-> Read AdjustSide
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS AdjustSide
readsPrec :: Int -> ReadS AdjustSide
$creadList :: ReadS [AdjustSide]
readList :: ReadS [AdjustSide]
$creadPrec :: ReadPrec AdjustSide
readPrec :: ReadPrec AdjustSide
$creadListPrec :: ReadPrec [AdjustSide]
readListPrec :: ReadPrec [AdjustSide]
Read, AdjustSide -> AdjustSide -> Bool
(AdjustSide -> AdjustSide -> Bool)
-> (AdjustSide -> AdjustSide -> Bool) -> Eq AdjustSide
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdjustSide -> AdjustSide -> Bool
== :: AdjustSide -> AdjustSide -> Bool
$c/= :: AdjustSide -> AdjustSide -> Bool
/= :: AdjustSide -> AdjustSide -> Bool
Eq, Eq AdjustSide
Eq AdjustSide =>
(AdjustSide -> AdjustSide -> Ordering)
-> (AdjustSide -> AdjustSide -> Bool)
-> (AdjustSide -> AdjustSide -> Bool)
-> (AdjustSide -> AdjustSide -> Bool)
-> (AdjustSide -> AdjustSide -> Bool)
-> (AdjustSide -> AdjustSide -> AdjustSide)
-> (AdjustSide -> AdjustSide -> AdjustSide)
-> Ord AdjustSide
AdjustSide -> AdjustSide -> Bool
AdjustSide -> AdjustSide -> Ordering
AdjustSide -> AdjustSide -> AdjustSide
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AdjustSide -> AdjustSide -> Ordering
compare :: AdjustSide -> AdjustSide -> Ordering
$c< :: AdjustSide -> AdjustSide -> Bool
< :: AdjustSide -> AdjustSide -> Bool
$c<= :: AdjustSide -> AdjustSide -> Bool
<= :: AdjustSide -> AdjustSide -> Bool
$c> :: AdjustSide -> AdjustSide -> Bool
> :: AdjustSide -> AdjustSide -> Bool
$c>= :: AdjustSide -> AdjustSide -> Bool
>= :: AdjustSide -> AdjustSide -> Bool
$cmax :: AdjustSide -> AdjustSide -> AdjustSide
max :: AdjustSide -> AdjustSide -> AdjustSide
$cmin :: AdjustSide -> AdjustSide -> AdjustSide
min :: AdjustSide -> AdjustSide -> AdjustSide
Ord, AdjustSide
AdjustSide -> AdjustSide -> Bounded AdjustSide
forall a. a -> a -> Bounded a
$cminBound :: AdjustSide
minBound :: AdjustSide
$cmaxBound :: AdjustSide
maxBound :: AdjustSide
Bounded, Int -> AdjustSide
AdjustSide -> Int
AdjustSide -> [AdjustSide]
AdjustSide -> AdjustSide
AdjustSide -> AdjustSide -> [AdjustSide]
AdjustSide -> AdjustSide -> AdjustSide -> [AdjustSide]
(AdjustSide -> AdjustSide)
-> (AdjustSide -> AdjustSide)
-> (Int -> AdjustSide)
-> (AdjustSide -> Int)
-> (AdjustSide -> [AdjustSide])
-> (AdjustSide -> AdjustSide -> [AdjustSide])
-> (AdjustSide -> AdjustSide -> [AdjustSide])
-> (AdjustSide -> AdjustSide -> AdjustSide -> [AdjustSide])
-> Enum AdjustSide
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: AdjustSide -> AdjustSide
succ :: AdjustSide -> AdjustSide
$cpred :: AdjustSide -> AdjustSide
pred :: AdjustSide -> AdjustSide
$ctoEnum :: Int -> AdjustSide
toEnum :: Int -> AdjustSide
$cfromEnum :: AdjustSide -> Int
fromEnum :: AdjustSide -> Int
$cenumFrom :: AdjustSide -> [AdjustSide]
enumFrom :: AdjustSide -> [AdjustSide]
$cenumFromThen :: AdjustSide -> AdjustSide -> [AdjustSide]
enumFromThen :: AdjustSide -> AdjustSide -> [AdjustSide]
$cenumFromTo :: AdjustSide -> AdjustSide -> [AdjustSide]
enumFromTo :: AdjustSide -> AdjustSide -> [AdjustSide]
$cenumFromThenTo :: AdjustSide -> AdjustSide -> AdjustSide -> [AdjustSide]
enumFromThenTo :: AdjustSide -> AdjustSide -> AdjustSide -> [AdjustSide]
Enum)

-- | How should a segment, trail, or path be adjusted?
data AdjustOpts n = AO { forall n. AdjustOpts n -> AdjustMethod n
_adjMethod    :: AdjustMethod n
                       , forall n. AdjustOpts n -> AdjustSide
_adjSide      :: AdjustSide
                       , forall n. AdjustOpts n -> n
_adjEps       :: n
                       , forall n. AdjustOpts n -> Proxy n
adjOptsvProxy :: Proxy n
                       }

-- See Diagrams.Combinators for reasoning behind 'Proxy'.

makeLensesWith (lensRules & generateSignatures .~ False) ''AdjustOpts

-- | Which method should be used for adjusting?
adjMethod :: Lens' (AdjustOpts n) (AdjustMethod n)

-- | Which end(s) of the object should be adjusted?
adjSide :: Lens' (AdjustOpts n) AdjustSide

-- | Tolerance to use when doing adjustment.
adjEps :: Lens' (AdjustOpts n) n

instance Fractional n => Default (AdjustMethod n) where
  def :: AdjustMethod n
def = n -> AdjustMethod n
forall n. n -> AdjustMethod n
ByParam n
0.2

instance Default AdjustSide where
  def :: AdjustSide
def = AdjustSide
Both

instance Fractional n => Default (AdjustOpts n) where
  def :: AdjustOpts n
def = AO { _adjMethod :: AdjustMethod n
_adjMethod    = AdjustMethod n
forall a. Default a => a
def
           , _adjSide :: AdjustSide
_adjSide      = AdjustSide
forall a. Default a => a
def
           , _adjEps :: n
_adjEps       = n
forall a. Fractional a => a
stdTolerance
           , adjOptsvProxy :: Proxy n
adjOptsvProxy = Proxy n
forall {k} (t :: k). Proxy t
Proxy
           }

-- | Adjust the length of a parametric object such as a segment or
--   trail.  The second parameter is an option record which controls how
--   the adjustment should be performed; see 'AdjustOpts'.
adjust :: (N t ~ n, Sectionable t, HasArcLength t, Fractional n)
       => t -> AdjustOpts n -> t
adjust :: forall t n.
(N t ~ n, Sectionable t, HasArcLength t, Fractional n) =>
t -> AdjustOpts n -> t
adjust t
s AdjustOpts n
opts = t -> N t -> N t -> t
forall p. Sectionable p => p -> N p -> N p -> p
section t
s
  (if AdjustOpts n
optsAdjustOpts n
-> Getting AdjustSide (AdjustOpts n) AdjustSide -> AdjustSide
forall s a. s -> Getting a s a -> a
^.Getting AdjustSide (AdjustOpts n) AdjustSide
forall n (f :: * -> *).
Functor f =>
(AdjustSide -> f AdjustSide) -> AdjustOpts n -> f (AdjustOpts n)
adjSide AdjustSide -> AdjustSide -> Bool
forall a. Eq a => a -> a -> Bool
== AdjustSide
End   then t -> N t
forall p. DomainBounds p => p -> N p
domainLower t
s else t -> n
getParam t
s)
  (if AdjustOpts n
optsAdjustOpts n
-> Getting AdjustSide (AdjustOpts n) AdjustSide -> AdjustSide
forall s a. s -> Getting a s a -> a
^.Getting AdjustSide (AdjustOpts n) AdjustSide
forall n (f :: * -> *).
Functor f =>
(AdjustSide -> f AdjustSide) -> AdjustOpts n -> f (AdjustOpts n)
adjSide AdjustSide -> AdjustSide -> Bool
forall a. Eq a => a -> a -> Bool
== AdjustSide
Start then t -> N t
forall p. DomainBounds p => p -> N p
domainUpper t
s else t -> N t
forall p. DomainBounds p => p -> N p
domainUpper t
s n -> n -> n
forall a. Num a => a -> a -> a
- t -> n
getParam (t -> t
forall p. Sectionable p => p -> p
reverseDomain t
s))
 where
  getParam :: t -> n
getParam t
seg = case AdjustOpts n
optsAdjustOpts n
-> Getting (AdjustMethod n) (AdjustOpts n) (AdjustMethod n)
-> AdjustMethod n
forall s a. s -> Getting a s a -> a
^.Getting (AdjustMethod n) (AdjustOpts n) (AdjustMethod n)
forall n (f :: * -> *).
Functor f =>
(AdjustMethod n -> f (AdjustMethod n))
-> AdjustOpts n -> f (AdjustOpts n)
adjMethod of
    ByParam n
p -> -n
p n -> n -> n
forall a. Num a => a -> a -> a
* n
bothCoef
    ByAbsolute n
len -> N t -> N t
param (-n
len n -> n -> n
forall a. Num a => a -> a -> a
* n
bothCoef)
    ToAbsolute n
len -> N t -> N t
param (n -> n
absDelta n
len n -> n -> n
forall a. Num a => a -> a -> a
* n
bothCoef)
   where
    param :: N t -> N t
param        = N t -> t -> N t -> N t
forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam n
N t
eps t
seg
    absDelta :: n -> n
absDelta n
len = N t -> t -> N t
forall p. HasArcLength p => N p -> p -> N p
arcLength n
N t
eps t
s n -> n -> n
forall a. Num a => a -> a -> a
- n
len
  bothCoef :: n
bothCoef = if AdjustOpts n
optsAdjustOpts n
-> Getting AdjustSide (AdjustOpts n) AdjustSide -> AdjustSide
forall s a. s -> Getting a s a -> a
^.Getting AdjustSide (AdjustOpts n) AdjustSide
forall n (f :: * -> *).
Functor f =>
(AdjustSide -> f AdjustSide) -> AdjustOpts n -> f (AdjustOpts n)
adjSide AdjustSide -> AdjustSide -> Bool
forall a. Eq a => a -> a -> Bool
== AdjustSide
Both then n
0.5 else n
1
  eps :: n
eps = AdjustOpts n
optsAdjustOpts n -> Getting n (AdjustOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (AdjustOpts n) n
forall n (f :: * -> *).
Functor f =>
(n -> f n) -> AdjustOpts n -> f (AdjustOpts n)
adjEps