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

module Diagrams.TwoD.Path.Metafont.Types where

import Control.Lens hiding ((#))
import Data.Monoid
import Data.Semigroup

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 { _d1 :: d, _j :: j, _d2 :: d }
  deriving (Functor, 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
  = PathDirCurl Curl
  | PathDirDir  Dir
    deriving Show

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

type Curl = Double
type Dir  = R2

type BasicJoin = Either TensionJoin ControlJoin

-- | 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
  = TensionAmt Double
  | TensionAtLeast Double
  deriving Show

getTension :: Tension -> Double
getTension (TensionAmt t)     = t
getTension (TensionAtLeast t) = t

-- | Two tensions and two directions completely determine the control
-- points of a segment.
data TensionJoin = TJ { _t1 :: Tension, _t2 :: Tension }
                 deriving Show

-- | The two intermediate control points of a segment, specified directly.
data ControlJoin = CJ { _c1 :: P2, _c2 :: P2 }
                 deriving Show

makeLenses ''TensionJoin
makeLenses ''ControlJoin

data P
data J

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

-- | @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 = MFS { _x1 :: P2, _pj :: (PathJoin d j), _x2 :: P2 }
                         deriving (Functor, 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 = MFP { _loop :: Bool, _segs :: [MetafontSegment d j] }
                deriving 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 = MFPath (Maybe PathDir) BasicJoin

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

makeLenses ''MetafontSegment
makeLenses ''MFPath

instance Monoid (PathJoin (Maybe PathDir) (Maybe BasicJoin)) where
    -- | The default join, with no directions specified, and both tensions 1.
    mempty = PJ Nothing Nothing Nothing
    l `mappend` r = PJ (c (l^.d1) (r^.d1)) (c (l^.j) (r^.j)) (c (l^.d2) (r^.d2))
      where
        c a b = case b of
            Nothing -> a
            Just _  -> b

instance Semigroup (PathJoin (Maybe PathDir) (Maybe BasicJoin)) where
    (<>) = mappend