{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE EmptyDataDecls    #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE TemplateHaskell   #-}

module Diagrams.TwoD.Path.Metafont.Types where

import Control.Lens hiding (( # ))
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif

import Diagrams.Direction
import Diagrams.TwoD.Types

-- | A @PathJoin@ specifies the directions at both ends of a segment,
-- and a join which describes the control points explicitly or implicitly.
data PathJoin d j = PJ { forall d j. PathJoin d j -> d
_d1 :: d, forall d j. PathJoin d j -> j
_j :: j, forall d j. PathJoin d j -> d
_d2 :: d }
  deriving (forall a b. a -> PathJoin d b -> PathJoin d a
forall a b. (a -> b) -> PathJoin d a -> PathJoin d b
forall d a b. a -> PathJoin d b -> PathJoin d a
forall d a b. (a -> b) -> PathJoin d a -> PathJoin d b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PathJoin d b -> PathJoin d a
$c<$ :: forall d a b. a -> PathJoin d b -> PathJoin d a
fmap :: forall a b. (a -> b) -> PathJoin d a -> PathJoin d b
$cfmap :: forall d a b. (a -> b) -> PathJoin d a -> PathJoin d b
Functor, Int -> PathJoin d j -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j. (Show d, Show j) => Int -> PathJoin d j -> ShowS
forall d j. (Show d, Show j) => [PathJoin d j] -> ShowS
forall d j. (Show d, Show j) => PathJoin d j -> String
showList :: [PathJoin d j] -> ShowS
$cshowList :: forall d j. (Show d, Show j) => [PathJoin d j] -> ShowS
show :: PathJoin d j -> String
$cshow :: forall d j. (Show d, Show j) => PathJoin d j -> String
showsPrec :: Int -> PathJoin d j -> ShowS
$cshowsPrec :: forall d j. (Show d, Show j) => Int -> PathJoin d j -> ShowS
Show)

makeLenses ''PathJoin

-- | A direction can be specified at any point of a path.  A /curl/
-- should only be specified at the endpoints.  The endpoints default
-- to curl 1 if not set.
data PathDir n
  = PathDirCurl n
  | PathDirDir  (Dir n)
    deriving Int -> PathDir n -> ShowS
forall n. Show n => Int -> PathDir n -> ShowS
forall n. Show n => [PathDir n] -> ShowS
forall n. Show n => PathDir n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathDir n] -> ShowS
$cshowList :: forall n. Show n => [PathDir n] -> ShowS
show :: PathDir n -> String
$cshow :: forall n. Show n => PathDir n -> String
showsPrec :: Int -> PathDir n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> PathDir n -> ShowS
Show

-- | A predicate to determine the constructor used.
isCurl :: PathDir n -> Bool
isCurl :: forall n. PathDir n -> Bool
isCurl (PathDirDir Dir n
_) = Bool
False
isCurl (PathDirCurl n
_) = Bool
True

type Curl n = n
type Dir n = Direction V2 n

type BasicJoin n = Either (TensionJoin n) (ControlJoin n)

-- | Higher /Tension/ brings the path closer to a straight line
-- between segments.  Equivalently, it brings the control points
-- closer to the endpoints.  @TensionAmt@ introduces a fixed tension.
-- @TensionAtLeast@ introduces a tension which will be increased if by
-- so doing, an inflection point can be eliminated.
data Tension n
  = TensionAmt n
  | TensionAtLeast n
  deriving Int -> Tension n -> ShowS
forall n. Show n => Int -> Tension n -> ShowS
forall n. Show n => [Tension n] -> ShowS
forall n. Show n => Tension n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tension n] -> ShowS
$cshowList :: forall n. Show n => [Tension n] -> ShowS
show :: Tension n -> String
$cshow :: forall n. Show n => Tension n -> String
showsPrec :: Int -> Tension n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> Tension n -> ShowS
Show

getTension :: Tension n -> n
getTension :: forall n. Tension n -> n
getTension (TensionAmt n
t)     = n
t
getTension (TensionAtLeast n
t) = n
t

-- | Two tensions and two directions completely determine the control
-- points of a segment.
data TensionJoin n = TJ { forall n. TensionJoin n -> Tension n
_t1 :: Tension n, forall n. TensionJoin n -> Tension n
_t2 :: Tension n }
                 deriving Int -> TensionJoin n -> ShowS
forall n. Show n => Int -> TensionJoin n -> ShowS
forall n. Show n => [TensionJoin n] -> ShowS
forall n. Show n => TensionJoin n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TensionJoin n] -> ShowS
$cshowList :: forall n. Show n => [TensionJoin n] -> ShowS
show :: TensionJoin n -> String
$cshow :: forall n. Show n => TensionJoin n -> String
showsPrec :: Int -> TensionJoin n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> TensionJoin n -> ShowS
Show

-- | The two intermediate control points of a segment, specified directly.
data ControlJoin n = CJ { forall n. ControlJoin n -> P2 n
_c1 :: P2 n, forall n. ControlJoin n -> P2 n
_c2 :: P2 n}
                 deriving Int -> ControlJoin n -> ShowS
forall n. Show n => Int -> ControlJoin n -> ShowS
forall n. Show n => [ControlJoin n] -> ShowS
forall n. Show n => ControlJoin n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlJoin n] -> ShowS
$cshowList :: forall n. Show n => [ControlJoin n] -> ShowS
show :: ControlJoin n -> String
$cshow :: forall n. Show n => ControlJoin n -> String
showsPrec :: Int -> ControlJoin n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> ControlJoin n -> ShowS
Show

makeLenses ''TensionJoin
makeLenses ''ControlJoin

data P
data J

-- | @MFPathData@ is the type manipulated by the metafont combinators.
data MFPathData a n where
  MFPathCycle:: MFPathData P n
  MFPathEnd  :: P2 n -> MFPathData P n
  MFPathPt   :: P2 n -> MFPathData J n -> MFPathData P n
  MFPathJoin :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)) -> MFPathData P n -> MFPathData J n

-- | @MetafontSegment@ is used internally in solving the metafont
-- equations.  It represents a segment with two known endpoints, and a
-- /join/, which may be specified in various ways.
data MetafontSegment d j n = MFS { forall d j n. MetafontSegment d j n -> P2 n
_x1 :: P2 n, forall d j n. MetafontSegment d j n -> PathJoin d j
_pj :: (PathJoin d j ), forall d j n. MetafontSegment d j n -> P2 n
_x2 :: P2 n }
                         deriving (forall a b. a -> MetafontSegment d j b -> MetafontSegment d j a
forall a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
forall d j a b. a -> MetafontSegment d j b -> MetafontSegment d j a
forall d j a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MetafontSegment d j b -> MetafontSegment d j a
$c<$ :: forall d j a b. a -> MetafontSegment d j b -> MetafontSegment d j a
fmap :: forall a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
$cfmap :: forall d j a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
Functor, Int -> MetafontSegment d j n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j n.
(Show n, Show d, Show j) =>
Int -> MetafontSegment d j n -> ShowS
forall d j n.
(Show n, Show d, Show j) =>
[MetafontSegment d j n] -> ShowS
forall d j n.
(Show n, Show d, Show j) =>
MetafontSegment d j n -> String
showList :: [MetafontSegment d j n] -> ShowS
$cshowList :: forall d j n.
(Show n, Show d, Show j) =>
[MetafontSegment d j n] -> ShowS
show :: MetafontSegment d j n -> String
$cshow :: forall d j n.
(Show n, Show d, Show j) =>
MetafontSegment d j n -> String
showsPrec :: Int -> MetafontSegment d j n -> ShowS
$cshowsPrec :: forall d j n.
(Show n, Show d, Show j) =>
Int -> MetafontSegment d j n -> ShowS
Show)

-- | @MFPath@ is the type used internally in solving the metafont
-- equations.  The direction and join types are progressively refined
-- until all control points are known.  The @loop@ flag affects both
-- the equations to be solved and the type of 'Trail' in the result.
-- If constructing an @MFPath@ in new code, the responsibility rests
-- on the user to ensure that successive @MetafontSegment@s share an
-- endpoint.  If this is not true, the result is undefined.
data MFPath d j n = MFP { forall d j n. MFPath d j n -> Bool
_loop :: Bool, forall d j n. MFPath d j n -> [MetafontSegment d j n]
_segs :: [MetafontSegment d j n] }
                deriving Int -> MFPath d j n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j n.
(Show n, Show d, Show j) =>
Int -> MFPath d j n -> ShowS
forall d j n. (Show n, Show d, Show j) => [MFPath d j n] -> ShowS
forall d j n. (Show n, Show d, Show j) => MFPath d j n -> String
showList :: [MFPath d j n] -> ShowS
$cshowList :: forall d j n. (Show n, Show d, Show j) => [MFPath d j n] -> ShowS
show :: MFPath d j n -> String
$cshow :: forall d j n. (Show n, Show d, Show j) => MFPath d j n -> String
showsPrec :: Int -> MFPath d j n -> ShowS
$cshowsPrec :: forall d j n.
(Show n, Show d, Show j) =>
Int -> MFPath d j n -> ShowS
Show

-- | MFP is a type synonym to clarify signatures in Metafont.Internal.
-- Note that the type permits segments which are \"overspecified\",
-- having one or both directions specified, and also a 'ControlJoin'.
-- In this case, "Metafont.Internal" ignores the directions.
type MFP n = MFPath (Maybe (PathDir n)) (BasicJoin n) n

-- | MFS is a type synonym to clarify signatures in "Metafont.Internal".
type MFS n = MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n

makeLenses ''MetafontSegment
makeLenses ''MFPath

instance Monoid (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where
    -- | The default join, with no directions specified, and both tensions 1.
    mempty :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
mempty = forall d j. d -> j -> d -> PathJoin d j
PJ forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
l mappend :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
`mappend` PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
r = forall d j. d -> j -> d -> PathJoin d j
PJ (forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lforall s a. s -> Getting a s a -> a
^.forall d j. Lens' (PathJoin d j) d
d1) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rforall s a. s -> Getting a s a -> a
^.forall d j. Lens' (PathJoin d j) d
d1)) (forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lforall s a. s -> Getting a s a -> a
^.forall d j j. Lens (PathJoin d j) (PathJoin d j) j j
j) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rforall s a. s -> Getting a s a -> a
^.forall d j j. Lens (PathJoin d j) (PathJoin d j) j j
j)) (forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lforall s a. s -> Getting a s a -> a
^.forall d j. Lens' (PathJoin d j) d
d2) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rforall s a. s -> Getting a s a -> a
^.forall d j. Lens' (PathJoin d j) d
d2))
      where
        c :: Maybe a -> Maybe a -> Maybe a
c Maybe a
a Maybe a
b = case Maybe a
b of
            Maybe a
Nothing -> Maybe a
a
            Just a
_  -> Maybe a
b

instance Semigroup (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where
    <> :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
(<>) = forall a. Monoid a => a -> a -> a
mappend