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

module Diagrams.TwoD.Path.Metafont.Types where

import Control.Lens hiding (( # ))

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 -> b) -> PathJoin d a -> PathJoin d b)
-> (forall a b. a -> PathJoin d b -> PathJoin d a)
-> Functor (PathJoin d)
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
$cfmap :: forall d a b. (a -> b) -> PathJoin d a -> PathJoin d b
fmap :: forall a b. (a -> b) -> PathJoin d a -> PathJoin d b
$c<$ :: forall d a b. a -> PathJoin d b -> PathJoin d a
<$ :: forall a b. a -> PathJoin d b -> PathJoin d a
Functor, Int -> PathJoin d j -> ShowS
[PathJoin d j] -> ShowS
PathJoin d j -> String
(Int -> PathJoin d j -> ShowS)
-> (PathJoin d j -> String)
-> ([PathJoin d j] -> ShowS)
-> Show (PathJoin d j)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j. (Show j, Show d) => Int -> PathJoin d j -> ShowS
forall d j. (Show j, Show d) => [PathJoin d j] -> ShowS
forall d j. (Show j, Show d) => PathJoin d j -> String
$cshowsPrec :: forall d j. (Show j, Show d) => Int -> PathJoin d j -> ShowS
showsPrec :: Int -> PathJoin d j -> ShowS
$cshow :: forall d j. (Show j, Show d) => PathJoin d j -> String
show :: PathJoin d j -> String
$cshowList :: forall d j. (Show j, Show d) => [PathJoin d j] -> ShowS
showList :: [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
[PathDir n] -> ShowS
PathDir n -> String
(Int -> PathDir n -> ShowS)
-> (PathDir n -> String)
-> ([PathDir n] -> ShowS)
-> Show (PathDir n)
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
$cshowsPrec :: forall n. Show n => Int -> PathDir n -> ShowS
showsPrec :: Int -> PathDir n -> ShowS
$cshow :: forall n. Show n => PathDir n -> String
show :: PathDir n -> String
$cshowList :: forall n. Show n => [PathDir n] -> ShowS
showList :: [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
[Tension n] -> ShowS
Tension n -> String
(Int -> Tension n -> ShowS)
-> (Tension n -> String)
-> ([Tension n] -> ShowS)
-> Show (Tension n)
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
$cshowsPrec :: forall n. Show n => Int -> Tension n -> ShowS
showsPrec :: Int -> Tension n -> ShowS
$cshow :: forall n. Show n => Tension n -> String
show :: Tension n -> String
$cshowList :: forall n. Show n => [Tension n] -> ShowS
showList :: [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
[TensionJoin n] -> ShowS
TensionJoin n -> String
(Int -> TensionJoin n -> ShowS)
-> (TensionJoin n -> String)
-> ([TensionJoin n] -> ShowS)
-> Show (TensionJoin n)
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
$cshowsPrec :: forall n. Show n => Int -> TensionJoin n -> ShowS
showsPrec :: Int -> TensionJoin n -> ShowS
$cshow :: forall n. Show n => TensionJoin n -> String
show :: TensionJoin n -> String
$cshowList :: forall n. Show n => [TensionJoin n] -> ShowS
showList :: [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
[ControlJoin n] -> ShowS
ControlJoin n -> String
(Int -> ControlJoin n -> ShowS)
-> (ControlJoin n -> String)
-> ([ControlJoin n] -> ShowS)
-> Show (ControlJoin n)
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
$cshowsPrec :: forall n. Show n => Int -> ControlJoin n -> ShowS
showsPrec :: Int -> ControlJoin n -> ShowS
$cshow :: forall n. Show n => ControlJoin n -> String
show :: ControlJoin n -> String
$cshowList :: forall n. Show n => [ControlJoin n] -> ShowS
showList :: [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 -> b) -> MetafontSegment d j a -> MetafontSegment d j b)
-> (forall a b.
    a -> MetafontSegment d j b -> MetafontSegment d j a)
-> Functor (MetafontSegment d j)
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
$cfmap :: forall d j a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
fmap :: forall a b.
(a -> b) -> MetafontSegment d j a -> MetafontSegment d j b
$c<$ :: forall d j a b. a -> MetafontSegment d j b -> MetafontSegment d j a
<$ :: forall a b. a -> MetafontSegment d j b -> MetafontSegment d j a
Functor, Int -> MetafontSegment d j n -> ShowS
[MetafontSegment d j n] -> ShowS
MetafontSegment d j n -> String
(Int -> MetafontSegment d j n -> ShowS)
-> (MetafontSegment d j n -> String)
-> ([MetafontSegment d j n] -> ShowS)
-> Show (MetafontSegment d j n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j n.
(Show n, Show j, Show d) =>
Int -> MetafontSegment d j n -> ShowS
forall d j n.
(Show n, Show j, Show d) =>
[MetafontSegment d j n] -> ShowS
forall d j n.
(Show n, Show j, Show d) =>
MetafontSegment d j n -> String
$cshowsPrec :: forall d j n.
(Show n, Show j, Show d) =>
Int -> MetafontSegment d j n -> ShowS
showsPrec :: Int -> MetafontSegment d j n -> ShowS
$cshow :: forall d j n.
(Show n, Show j, Show d) =>
MetafontSegment d j n -> String
show :: MetafontSegment d j n -> String
$cshowList :: forall d j n.
(Show n, Show j, Show d) =>
[MetafontSegment d j n] -> ShowS
showList :: [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
[MFPath d j n] -> ShowS
MFPath d j n -> String
(Int -> MFPath d j n -> ShowS)
-> (MFPath d j n -> String)
-> ([MFPath d j n] -> ShowS)
-> Show (MFPath d j n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall d j n.
(Show n, Show j, Show d) =>
Int -> MFPath d j n -> ShowS
forall d j n. (Show n, Show j, Show d) => [MFPath d j n] -> ShowS
forall d j n. (Show n, Show j, Show d) => MFPath d j n -> String
$cshowsPrec :: forall d j n.
(Show n, Show j, Show d) =>
Int -> MFPath d j n -> ShowS
showsPrec :: Int -> MFPath d j n -> ShowS
$cshow :: forall d j n. (Show n, Show j, Show d) => MFPath d j n -> String
show :: MFPath d j n -> String
$cshowList :: forall d j n. (Show n, Show j, Show d) => [MFPath d j n] -> ShowS
showList :: [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 = Maybe (PathDir n)
-> Maybe (BasicJoin n)
-> Maybe (PathDir n)
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
forall a. Maybe a
Nothing Maybe (BasicJoin n)
forall a. Maybe a
Nothing Maybe (PathDir n)
forall a. Maybe a
Nothing

instance Semigroup (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where
    PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
l <> :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
<> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
r = Maybe (PathDir n)
-> Maybe (BasicJoin n)
-> Maybe (PathDir n)
-> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
forall d j. d -> j -> d -> PathJoin d j
PJ (Maybe (PathDir n) -> Maybe (PathDir n) -> Maybe (PathDir n)
forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (PathDir n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (PathDir n))
-> Maybe (PathDir n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (PathDir n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (PathDir n))
forall d j (f :: * -> *).
Functor f =>
(d -> f d) -> PathJoin d j -> f (PathJoin d j)
d1) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (PathDir n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (PathDir n))
-> Maybe (PathDir n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (PathDir n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (PathDir n))
forall d j (f :: * -> *).
Functor f =>
(d -> f d) -> PathJoin d j -> f (PathJoin d j)
d1)) (Maybe (BasicJoin n) -> Maybe (BasicJoin n) -> Maybe (BasicJoin n)
forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (BasicJoin n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (BasicJoin n))
-> Maybe (BasicJoin n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (BasicJoin n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (BasicJoin n))
forall d j j (f :: * -> *).
Functor f =>
(j -> f j) -> PathJoin d j -> f (PathJoin d j)
j) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (BasicJoin n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (BasicJoin n))
-> Maybe (BasicJoin n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (BasicJoin n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (BasicJoin n))
forall d j j (f :: * -> *).
Functor f =>
(j -> f j) -> PathJoin d j -> f (PathJoin d j)
j)) (Maybe (PathDir n) -> Maybe (PathDir n) -> Maybe (PathDir n)
forall {a}. Maybe a -> Maybe a -> Maybe a
c (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
lPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (PathDir n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (PathDir n))
-> Maybe (PathDir n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (PathDir n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (PathDir n))
forall d j (f :: * -> *).
Functor f =>
(d -> f d) -> PathJoin d j -> f (PathJoin d j)
d2) (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
rPathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
-> Getting
     (Maybe (PathDir n))
     (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
     (Maybe (PathDir n))
-> Maybe (PathDir n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (PathDir n))
  (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)))
  (Maybe (PathDir n))
forall d j (f :: * -> *).
Functor f =>
(d -> f d) -> PathJoin d j -> f (PathJoin d j)
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