{-# LANGUAGE GADTs           #-}
{-# LANGUAGE TypeFamilies    #-}
{-# LANGUAGE TypeOperators   #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Path.Metafont
-- Copyright   :  (c) 2013 Daniel Bergey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  bergey@alum.mit.edu
--
-- Define Diagrams Paths by specifying points and
-- optionally directions and tension.  Calculate control points to
-- maintain smooth curvature at each point, following rules
-- implemented in Donald Knuth's /Metafont/.
--
--  This module is intended to be imported qualified.
-----------------------------------------------------------------------------
module Diagrams.TwoD.Path.Metafont
       (
             module  Diagrams.TwoD.Path.Metafont.Combinators
           , module  Diagrams.TwoD.Path.Metafont
           , metafontParser
       )
       where

import           Control.Lens                            hiding (at, ( # ))
import           Data.Either
import           Data.Text                               (Text)
import           Text.Parsec                             (ParseError, parse)

import           Diagrams.Prelude                        hiding (view)

import           Diagrams.TwoD.Path.Metafont.Combinators
import           Diagrams.TwoD.Path.Metafont.Internal
import           Diagrams.TwoD.Path.Metafont.Parser
import           Diagrams.TwoD.Path.Metafont.Types

-- | MF.fromString parses a Text value in MetaFont syntax, and
-- attempts to return a TrailLike.  Only a subset of Metafont is
-- supported; see the tutorial for details.
fromString :: (TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) => Text -> Either ParseError t
fromString :: forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) =>
Text -> Either ParseError t
fromString Text
s = case Parsec Text () (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
-> SourceName
-> Text
-> Either ParseError (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
forall n.
(Num n, Read n) =>
Parser (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
metafontParser SourceName
"" Text
s of
  (Left ParseError
err) -> ParseError -> Either ParseError t
forall a b. a -> Either a b
Left ParseError
err -- with different type
  (Right MFPath (Maybe (PathDir n)) (BasicJoin n) n
p)  -> t -> Either ParseError t
forall a b. b -> Either a b
Right (t -> Either ParseError t)
-> (MFPath (Maybe (PathDir n)) (BasicJoin n) n -> t)
-> MFPath (Maybe (PathDir n)) (BasicJoin n) n
-> Either ParseError t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFPath (Maybe (PathDir n)) (BasicJoin n) n -> t
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath  (MFPath (Maybe (PathDir n)) (BasicJoin n) n -> Either ParseError t)
-> MFPath (Maybe (PathDir n)) (BasicJoin n) n
-> Either ParseError t
forall a b. (a -> b) -> a -> b
$ MFPath (Maybe (PathDir n)) (BasicJoin n) n
p

-- | fromStrings takes a list of MetaFont strings, and returns either
--  all errors, or, if there are no parsing errors, a TrailLike for
--  each string.  fromStrings is provided as a convenience because the
--  MetaFont &-join is not supported.  'mconcat' ('<>') on the TrailLike is
--  equivalent, with clearer semantics.
fromStrings :: (TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) => [Text] -> Either [ParseError] [t]
fromStrings :: forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) =>
[Text] -> Either [ParseError] [t]
fromStrings [Text]
ss = case [Either ParseError t] -> ([ParseError], [t])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ParseError t] -> ([ParseError], [t]))
-> ([Text] -> [Either ParseError t])
-> [Text]
-> ([ParseError], [t])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either ParseError t) -> [Text] -> [Either ParseError t]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Either ParseError t
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) =>
Text -> Either ParseError t
fromString ([Text] -> ([ParseError], [t])) -> [Text] -> ([ParseError], [t])
forall a b. (a -> b) -> a -> b
$ [Text]
ss of
  ([],[t]
ts) -> [t] -> Either [ParseError] [t]
forall a b. b -> Either a b
Right [t]
ts
  ([ParseError]
es,[t]
_)  -> [ParseError] -> Either [ParseError] [t]
forall a b. a -> Either a b
Left [ParseError]
es

-- | Should you wish to construct the MFPath in some other fashion,
--   fromPath makes a TrailLike directly from the MFPath
fromPath :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => MFP n -> t
fromPath :: forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath = Located (Trail (V t) (N t)) -> t
Located (Trail V2 n) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail V2 n) -> t)
-> (MFP n -> Located (Trail V2 n)) -> MFP n -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFPath () (ControlJoin n) n -> Located (Trail V2 n)
forall n.
(Floating n, Ord n) =>
MFPath () (ControlJoin n) n -> Located (Trail V2 n)
locatedTrail (MFPath () (ControlJoin n) n -> Located (Trail V2 n))
-> (MFP n -> MFPath () (ControlJoin n) n)
-> MFP n
-> Located (Trail V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  (MFPath (Dir n) (BasicJoin n) n)
  (MFPath () (ControlJoin n) n)
  (MetafontSegment (Dir n) (BasicJoin n) n)
  (MetafontSegment () (ControlJoin n) n)
-> (MetafontSegment (Dir n) (BasicJoin n) n
    -> MetafontSegment () (ControlJoin n) n)
-> MFPath (Dir n) (BasicJoin n) n
-> MFPath () (ControlJoin n) n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([MetafontSegment (Dir n) (BasicJoin n) n]
 -> Identity [MetafontSegment () (ControlJoin n) n])
-> MFPath (Dir n) (BasicJoin n) n
-> Identity (MFPath () (ControlJoin n) n)
forall d1 j1 n1 d2 j2 n2 (f :: * -> *).
Functor f =>
([MetafontSegment d1 j1 n1] -> f [MetafontSegment d2 j2 n2])
-> MFPath d1 j1 n1 -> f (MFPath d2 j2 n2)
segs(([MetafontSegment (Dir n) (BasicJoin n) n]
  -> Identity [MetafontSegment () (ControlJoin n) n])
 -> MFPath (Dir n) (BasicJoin n) n
 -> Identity (MFPath () (ControlJoin n) n))
-> ((MetafontSegment (Dir n) (BasicJoin n) n
     -> Identity (MetafontSegment () (ControlJoin n) n))
    -> [MetafontSegment (Dir n) (BasicJoin n) n]
    -> Identity [MetafontSegment () (ControlJoin n) n])
-> ASetter
     (MFPath (Dir n) (BasicJoin n) n)
     (MFPath () (ControlJoin n) n)
     (MetafontSegment (Dir n) (BasicJoin n) n)
     (MetafontSegment () (ControlJoin n) n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MetafontSegment (Dir n) (BasicJoin n) n
 -> Identity (MetafontSegment () (ControlJoin n) n))
-> [MetafontSegment (Dir n) (BasicJoin n) n]
-> Identity [MetafontSegment () (ControlJoin n) n]
Setter
  [MetafontSegment (Dir n) (BasicJoin n) n]
  [MetafontSegment () (ControlJoin n) n]
  (MetafontSegment (Dir n) (BasicJoin n) n)
  (MetafontSegment () (ControlJoin n) n)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) MetafontSegment (Dir n) (BasicJoin n) n
-> MetafontSegment () (ControlJoin n) n
forall n.
RealFloat n =>
MetafontSegment (Dir n) (BasicJoin n) n
-> MetafontSegment () (ControlJoin n) n
computeControls (MFPath (Dir n) (BasicJoin n) n -> MFPath () (ControlJoin n) n)
-> (MFP n -> MFPath (Dir n) (BasicJoin n) n)
-> MFP n
-> MFPath () (ControlJoin n) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFP n -> MFPath (Dir n) (BasicJoin n) n
forall n. RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solve

-- | flex ps draws a Trail through the points ps, such that at every
-- point p ∊ ps except the endpoints, the Trail is parallel to the
-- line from the first to the last point.  This is the same as the
-- flex command defined in plain MetaFont.
flex :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => [P2 n] -> t
flex :: forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
[P2 n] -> t
flex [P2 n]
ps = MFP n -> t
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath (MFP n -> t)
-> ([MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n] -> MFP n)
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n] -> MFP n
forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
False ([MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n] -> t)
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n] -> t
forall a b. (a -> b) -> a -> b
$ (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
s0MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
forall a. a -> [a] -> [a]
:[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest) where
  tj :: Either (TensionJoin n) b
tj = TensionJoin n -> Either (TensionJoin n) b
forall a b. a -> Either a b
Left (Tension n -> Tension n -> TensionJoin n
forall n. Tension n -> Tension n -> TensionJoin n
TJ (n -> Tension n
forall n. n -> Tension n
TensionAmt n
1) (n -> Tension n
forall n. n -> Tension n
TensionAmt n
1))
  jj :: PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj = Maybe (PathDir n)
-> BasicJoin n
-> Maybe (PathDir n)
-> PathJoin (Maybe (PathDir n)) (BasicJoin n)
forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
forall a. Maybe a
Nothing BasicJoin n
forall {b}. Either (TensionJoin n) b
tj Maybe (PathDir n)
forall a. Maybe a
Nothing
  s0 :: MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
s0 = P2 n
-> PathJoin (Maybe (PathDir n)) (BasicJoin n)
-> P2 n
-> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS ([P2 n] -> P2 n
forall a. HasCallStack => [a] -> a
head [P2 n]
ps) PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj ([P2 n] -> P2 n
forall a. HasCallStack => [a] -> a
head([P2 n] -> P2 n) -> ([P2 n] -> [P2 n]) -> [P2 n] -> P2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[P2 n] -> [P2 n]
forall a. HasCallStack => [a] -> [a]
tail ([P2 n] -> P2 n) -> [P2 n] -> P2 n
forall a b. (a -> b) -> a -> b
$ [P2 n]
ps)
  d :: Maybe (PathDir n)
d = PathDir n -> Maybe (PathDir n)
forall a. a -> Maybe a
Just (PathDir n -> Maybe (PathDir n))
-> (V2 n -> PathDir n) -> V2 n -> Maybe (PathDir n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dir n -> PathDir n
forall n. Dir n -> PathDir n
PathDirDir (Dir n -> PathDir n) -> (V2 n -> Dir n) -> V2 n -> PathDir n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 n -> Dir n
forall (v :: * -> *) n. v n -> Direction v n
direction (V2 n -> Maybe (PathDir n)) -> V2 n -> Maybe (PathDir n)
forall a b. (a -> b) -> a -> b
$ [P2 n] -> P2 n
forall a. HasCallStack => [a] -> a
last [P2 n]
ps P2 n -> P2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. [P2 n] -> P2 n
forall a. HasCallStack => [a] -> a
head [P2 n]
ps
  seg :: P2 n -> P2 n -> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
seg P2 n
z1 P2 n
z2 = P2 n
-> PathJoin (Maybe (PathDir n)) (BasicJoin n)
-> P2 n
-> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
z1 (Maybe (PathDir n)
-> BasicJoin n
-> Maybe (PathDir n)
-> PathJoin (Maybe (PathDir n)) (BasicJoin n)
forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
d BasicJoin n
forall {b}. Either (TensionJoin n) b
tj Maybe (PathDir n)
forall a. Maybe a
Nothing) P2 n
z2
  rest :: [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest = (P2 n
 -> P2 n -> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n)
-> [P2 n]
-> [P2 n]
-> [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith P2 n -> P2 n -> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
seg ([P2 n] -> [P2 n]
forall a. HasCallStack => [a] -> [a]
init ([P2 n] -> [P2 n]) -> ([P2 n] -> [P2 n]) -> [P2 n] -> [P2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [P2 n] -> [P2 n]
forall a. HasCallStack => [a] -> [a]
tail ([P2 n] -> [P2 n]) -> [P2 n] -> [P2 n]
forall a b. (a -> b) -> a -> b
$ [P2 n]
ps) ([P2 n] -> [P2 n]
forall a. HasCallStack => [a] -> [a]
tail ([P2 n] -> [P2 n]) -> ([P2 n] -> [P2 n]) -> [P2 n] -> [P2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [P2 n] -> [P2 n]
forall a. HasCallStack => [a] -> [a]
tail ([P2 n] -> [P2 n]) -> [P2 n] -> [P2 n]
forall a b. (a -> b) -> a -> b
$ [P2 n]
ps)

-- | metafont converts a path defined in the Metafont combinator synax into a
-- native Diagrams TrailLike.
metafont :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => MFPathData P n -> t
metafont :: forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFPathData P n -> t
metafont = MFP n -> t
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath (MFP n -> t) -> (MFPathData P n -> MFP n) -> MFPathData P n -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFPathData P n -> MFP n
forall n. Num n => MFPathData P n -> MFP n
mfPathToSegments