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

-----------------------------------------------------------------------------
-- |
-- 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 forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse forall n.
(Num n, Read n) =>
Parser (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
metafontParser SourceName
"" Text
s of
  (Left ParseError
err) -> forall a b. a -> Either a b
Left ParseError
err -- with different type
  (Right MFPath (Maybe (PathDir n)) (BasicJoin n) n
p)  -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath  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 forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Read n, RealFloat n) =>
Text -> Either ParseError t
fromString forall a b. (a -> b) -> a -> b
$ [Text]
ss of
  ([],[t]
ts) -> forall a b. b -> Either a b
Right [t]
ts
  ([ParseError]
es,[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 = forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
(Floating n, Ord n) =>
MFPath () (ControlJoin n) n -> Located (Trail V2 n)
locatedTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall d1 j1 n1 d2 j2 n2.
Lens
  (MFPath d1 j1 n1)
  (MFPath d2 j2 n2)
  [MetafontSegment d1 j1 n1]
  [MetafontSegment d2 j2 n2]
segsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) forall n.
RealFloat n =>
MetafontSegment (Dir n) (BasicJoin n) n
-> MetafontSegment () (ControlJoin n) n
computeControls forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
False forall a b. (a -> b) -> a -> b
$ (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
s0forall a. a -> [a] -> [a]
:[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest) where
  tj :: Either (TensionJoin n) b
tj = forall a b. a -> Either a b
Left (forall n. Tension n -> Tension n -> TensionJoin n
TJ (forall n. n -> Tension n
TensionAmt n
1) (forall n. n -> Tension n
TensionAmt n
1))
  jj :: PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj = forall d j. d -> j -> d -> PathJoin d j
PJ forall a. Maybe a
Nothing forall {b}. Either (TensionJoin n) b
tj forall a. Maybe a
Nothing
  s0 :: MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
s0 = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS (forall a. [a] -> a
head [P2 n]
ps) PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj (forall a. [a] -> a
headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ [P2 n]
ps)
  d :: Maybe (PathDir n)
d = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Dir n -> PathDir n
PathDirDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. v n -> Direction v n
direction forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [P2 n]
ps forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall a. [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 = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
z1 (forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
d forall {b}. Either (TensionJoin n) b
tj forall a. Maybe a
Nothing) P2 n
z2
  rest :: [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith P2 n -> P2 n -> MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
seg (forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ [P2 n]
ps) (forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail 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 = forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
MFP n -> t
fromPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => MFPathData P n -> MFP n
mfPathToSegments