{-# 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
data PathJoin d j = PJ { _d1 :: d, _j :: j, _d2 :: d }
deriving (Functor, Show)
makeLenses ''PathJoin
data PathDir n
= PathDirCurl n
| PathDirDir (Dir n)
deriving Show
isCurl :: PathDir n -> Bool
isCurl (PathDirDir _) = False
isCurl (PathDirCurl _) = True
type Curl n = n
type Dir n = Direction V2 n
type BasicJoin n = Either (TensionJoin n) (ControlJoin n)
data Tension n
= TensionAmt n
| TensionAtLeast n
deriving Show
getTension :: Tension n -> n
getTension (TensionAmt t) = t
getTension (TensionAtLeast t) = t
data TensionJoin n = TJ { _t1 :: Tension n, _t2 :: Tension n }
deriving Show
data ControlJoin n = CJ { _c1 :: P2 n, _c2 :: P2 n}
deriving Show
makeLenses ''TensionJoin
makeLenses ''ControlJoin
data P
data J
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
data MetafontSegment d j n = MFS { _x1 :: P2 n, _pj :: (PathJoin d j ), _x2 :: P2 n }
deriving (Functor, Show)
data MFPath d j n = MFP { _loop :: Bool, _segs :: [MetafontSegment d j n] }
deriving Show
type MFP n = MFPath (Maybe (PathDir n)) (BasicJoin n) n
type MFS n = MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
makeLenses ''MetafontSegment
makeLenses ''MFPath
instance Monoid (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where
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 n)) (Maybe (BasicJoin n))) where
(<>) = mappend