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

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Path.Metafont.Internal
-- Copyright   :  (c) 2013 Daniel Bergey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  bergey@alum.mit.edu
--
-- Solve equations due to John Hobby, as implemented in Donald Knuth's
-- /Metafont/, to create (usually) smooth paths from specified points
-- and directions.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Path.Metafont.Internal
       (
           solve, computeControls, locatedTrail
           -- combinator style
           , mfPathToSegments
       )
    where

import           Control.Lens                      hiding (at, ( # ))
import           Data.Maybe

import           Diagrams.Prelude                  hiding (view)
import           Diagrams.Solve.Tridiagonal

import           Diagrams.TwoD.Path.Metafont.Types


-- | Reverse a MetaFont segment, including all directions & joins.
reverseSeg :: Num n => MFS n -> MFS n
reverseSeg :: forall n. Num n => MFS n -> MFS n
reverseSeg MFS n
s = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2) (forall d j. d -> j -> d -> PathJoin d j
PJ (forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
rDir forall a b. (a -> b) -> a -> b
$ MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2) (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
jforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall {n} {n}.
Either (TensionJoin n) (ControlJoin n)
-> Either (TensionJoin n) (ControlJoin n)
rj) (forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
rDir forall a b. (a -> b) -> a -> b
$ MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1)) (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1) where
  rj :: Either (TensionJoin n) (ControlJoin n)
-> Either (TensionJoin n) (ControlJoin n)
rj (Left TensionJoin n
t) = (forall a b. a -> Either a b
Left (forall n. Tension n -> Tension n -> TensionJoin n
TJ (TensionJoin n
tforall s a. s -> Getting a s a -> a
^.forall n. Lens' (TensionJoin n) (Tension n)
t2) (TensionJoin n
tforall s a. s -> Getting a s a -> a
^.forall n. Lens' (TensionJoin n) (Tension n)
t1)))
  rj (Right ControlJoin n
c) = (forall a b. b -> Either a b
Right (forall n. P2 n -> P2 n -> ControlJoin n
CJ (ControlJoin n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (ControlJoin n) (P2 n)
c2) (ControlJoin n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (ControlJoin n) (P2 n)
c1)))
  rDir :: Maybe (PathDir n) -> Maybe (PathDir n)
rDir (Just (PathDirDir Dir n
d)) = (forall a. a -> Maybe a
Just (forall n. Dir n -> PathDir n
PathDirDir (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Dir n
d)))
  rDir Maybe (PathDir n)
d = Maybe (PathDir n)
d

-- | Calculate the length of a MetaFont segment.
mfSegmentLength :: Floating n  => MetafontSegment p j n -> n
mfSegmentLength :: forall n p j. Floating n => MetafontSegment p j n -> n
mfSegmentLength = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n p j. Num n => MetafontSegment p j n -> V2 n
mfSegmentOffset

-- | Calculate the vector between endpoints of the given segment.
mfSegmentOffset :: Num n => MetafontSegment p j n -> V2 n
mfSegmentOffset :: forall n p j. Num n => MetafontSegment p j n -> V2 n
mfSegmentOffset MetafontSegment p j n
s = MetafontSegment p j n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. MetafontSegment p j n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1

-- | leftCurl s is True if the first direction of s is specified as a curl
leftCurl, rightCurl :: MFS n -> Bool
leftCurl :: forall n. MFS n -> Bool
leftCurl (MFS P2 n
_ (PJ (Just (PathDirCurl n
_)) BasicJoin n
_ Maybe (PathDir n)
_) P2 n
_) = Bool
True
leftCurl MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
_ = Bool
False

-- | rightCurl s is True if the second direction of s is specified as a curl
rightCurl :: forall n. MFS n -> Bool
rightCurl (MFS P2 n
_ (PJ Maybe (PathDir n)
_ BasicJoin n
_ (Just (PathDirCurl n
_))) P2 n
_) = Bool
True
rightCurl MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
_ = Bool
False

-- | Normalize a number representing number of turns to ±½
normalizeTurns :: RealFrac n => n -> n
normalizeTurns :: forall n. RealFrac n => n -> n
normalizeTurns n
t | n
t forall a. Ord a => a -> a -> Bool
>  n
1forall a. Fractional a => a -> a -> a
/n
2   = n
t forall a. Num a => a -> a -> a
- forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a b. (RealFrac a, Integral b) => a -> b
ceiling n
t :: Int)
normalizeTurns n
t | n
t forall a. Ord a => a -> a -> Bool
< -n
1forall a. Fractional a => a -> a -> a
/n
2   = n
t forall a. Num a => a -> a -> a
- forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a b. (RealFrac a, Integral b) => a -> b
floor n
t   :: Int)
normalizeTurns n
t = n
t

-- | By analogy with fromJust, fromLeft returns the Left value or errors
fromLeft :: Either a b -> a
fromLeft :: forall a b. Either a b -> a
fromLeft (Left a
l) = a
l
fromLeft (Right b
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"got Right in fromLeft"


-- | Fill in default values for as many blank directions as possible.
-- @fillDirs@ implements all of the following rules:
--
-- 1. Empty direction at beginning or end of path -> curl 1.
--    Note cyclic paths have no beginning/end; will use cyclic tridiagonal.
--
-- 2. Empty direction next to & -> curl 1.
--
-- 3. empty P nonempty -> replace empty with nonempty.
--
-- 4. nonempty P empty -> replace empty with nonempty.
--
-- 5.  .. z .. controls u and ...  -> {u - z} z ... controls if (u /=
--        z), or {curl 1} if u = z
--
--        Similarly  controls u and v ... z ... ->  z {z - v} (or curl 1)
fillDirs :: (Num n, Eq n) => MFP n -> MFP n
fillDirs :: forall n. (Num n, Eq n) => MFP n -> MFP n
fillDirs MFP n
p  = (forall n. MFP n -> MFP n
copyDirsLoop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => MFP n -> MFP n
curlEnds) MFP n
p forall a b. a -> (a -> b) -> b
& forall d1 j1 n1 d2 j2 n2.
Lens
  (MFPath d1 j1 n1)
  (MFPath d2 j2 n2)
  [MetafontSegment d1 j1 n1]
  [MetafontSegment d2 j2 n2]
segs forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
              (forall n. [MFS n] -> [MFS n]
copyDirsR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. [MFS n] -> [MFS n]
copyDirsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n. (Num n, Eq n) => MFS n -> MFS n
controlPtDirs)

-- rules 1 & 2
curlEnds :: Num n => MFP n -> MFP n
curlEnds :: forall n. Num n => MFP n -> MFP n
curlEnds MFP n
p | (MFP n
pforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MFPath d j n) Bool
loop) = MFP n
p
curlEnds MFP n
p             = MFP n
p forall a b. a -> (a -> b) -> b
& forall d1 j1 n1 d2 j2 n2.
Lens
  (MFPath d1 j1 n1)
  (MFPath d2 j2 n2)
  [MetafontSegment d1 j1 n1]
  [MetafontSegment d2 j2 n2]
segs forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {n} {j2} {n}.
Num n =>
[MetafontSegment (Maybe (PathDir n)) j2 n]
-> [MetafontSegment (Maybe (PathDir n)) j2 n]
leftEnd where
  leftEnd :: [MetafontSegment (Maybe (PathDir n)) j2 n]
-> [MetafontSegment (Maybe (PathDir n)) j2 n]
leftEnd  [MetafontSegment (Maybe (PathDir n)) j2 n
s]         = [MetafontSegment (Maybe (PathDir n)) j2 n
s forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
curlIfEmpty forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
curlIfEmpty]
  leftEnd  (MetafontSegment (Maybe (PathDir n)) j2 n
s:[MetafontSegment (Maybe (PathDir n)) j2 n]
ss)      = (MetafontSegment (Maybe (PathDir n)) j2 n
s forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
curlIfEmpty) forall a. a -> [a] -> [a]
: forall {n} {j2} {n}.
Num n =>
[MetafontSegment (Maybe (PathDir n)) j2 n]
-> [MetafontSegment (Maybe (PathDir n)) j2 n]
rightEnd [MetafontSegment (Maybe (PathDir n)) j2 n]
ss
  leftEnd  []          = []
  rightEnd :: [MetafontSegment (Maybe (PathDir n)) j2 n]
-> [MetafontSegment (Maybe (PathDir n)) j2 n]
rightEnd []          = []
  rightEnd [MetafontSegment (Maybe (PathDir n)) j2 n
s]         = [MetafontSegment (Maybe (PathDir n)) j2 n
s forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {n}. Num n => Maybe (PathDir n) -> Maybe (PathDir n)
curlIfEmpty]
  rightEnd (MetafontSegment (Maybe (PathDir n)) j2 n
s:[MetafontSegment (Maybe (PathDir n)) j2 n]
ss)      = MetafontSegment (Maybe (PathDir n)) j2 n
sforall a. a -> [a] -> [a]
:[MetafontSegment (Maybe (PathDir n)) j2 n]
-> [MetafontSegment (Maybe (PathDir n)) j2 n]
rightEnd [MetafontSegment (Maybe (PathDir n)) j2 n]
ss
  curlIfEmpty :: Maybe (PathDir n) -> Maybe (PathDir n)
curlIfEmpty Maybe (PathDir n)
Nothing  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. n -> PathDir n
PathDirCurl n
1
  curlIfEmpty Maybe (PathDir n)
d        = Maybe (PathDir n)
d

-- rule 3
copyDirsL :: [MFS n] -> [MFS n]
copyDirsL :: forall n. [MFS n] -> [MFS n]
copyDirsL (s1 :: MFS n
s1@(MFS P2 n
_ (PJ Maybe (PathDir n)
_ BasicJoin n
_ Maybe (PathDir n)
Nothing) P2 n
_) : ss :: [MFS n]
ss@(MFS P2 n
_ (PJ (Just PathDir n
d) BasicJoin n
_ Maybe (PathDir n)
_) P2 n
_ : [MFS n]
_))
  = (MFS n
s1 forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2 forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just PathDir n
d) forall a. a -> [a] -> [a]
: forall n. [MFS n] -> [MFS n]
copyDirsL [MFS n]
ss
copyDirsL (MFS n
s1 : [MFS n]
ss') = MFS n
s1 forall a. a -> [a] -> [a]
: forall n. [MFS n] -> [MFS n]
copyDirsL [MFS n]
ss'
copyDirsL [] = []

-- rule 4
copyDirsR :: [MFS n] -> [MFS n]
copyDirsR :: forall n. [MFS n] -> [MFS n]
copyDirsR (s1 :: MFS n
s1@(MFS P2 n
_ (PJ Maybe (PathDir n)
_ BasicJoin n
_ (Just PathDir n
d)) P2 n
_) : s2 :: MFS n
s2@(MFS P2 n
_ (PJ Maybe (PathDir n)
Nothing BasicJoin n
_ Maybe (PathDir n)
_) P2 n
_) : [MFS n]
ss)
  = MFS n
s1 forall a. a -> [a] -> [a]
: forall n. [MFS n] -> [MFS n]
copyDirsR ((MFS n
s2 forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1 forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just PathDir n
d) forall a. a -> [a] -> [a]
: [MFS n]
ss)
copyDirsR (MFS n
s1 : [MFS n]
ss') = MFS n
s1 forall a. a -> [a] -> [a]
: forall n. [MFS n] -> [MFS n]
copyDirsR [MFS n]
ss'
copyDirsR [] = []

-- copy a direction from one end of a loop to the other
copyDirsLoop :: MFP n -> MFP n
copyDirsLoop :: forall n. MFP n -> MFP n
copyDirsLoop MFP n
p | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall d j n. MFPath d j n -> Bool
_loop MFP n
p = MFP n
p
copyDirsLoop p :: MFP n
p@(MFP Bool
_ []) = MFP n
p
copyDirsLoop MFP n
p | (MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isJust) Bool -> Bool -> Bool
&&
                 (MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Snoc s s a a => Traversal' s a
_lastforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isNothing) =
                   MFP n
p forall a b. a -> (a -> b) -> b
& 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 s a. Snoc s s a a => Traversal' s a
_lastforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1)
copyDirsLoop MFP n
p | MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isNothing Bool -> Bool -> Bool
&&
                 MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Snoc s s a a => Traversal' s a
_lastforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isJust =
                   MFP n
p forall a b. a -> (a -> b) -> b
& 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 s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MFP n
pforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!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 s a. Snoc s s a a => Traversal' s a
_lastforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2)
copyDirsLoop MFP n
p = MFP n
p

-- rule 5
-- apply rule 5 before rules 3 & 4, then depend on those rules to copy the directions
-- into adjacent segments
controlPtDirs :: forall n. (Num n, Eq n) => MFS n -> MFS n
controlPtDirs :: forall n. (Num n, Eq n) => MFS n -> MFS n
controlPtDirs s :: MFS n
s@(MFS P2 n
z0 (PJ Maybe (PathDir n)
_ jj :: BasicJoin n
jj@(Right (CJ P2 n
u P2 n
v)) Maybe (PathDir n)
_) P2 n
z1) = MFS n
s forall a b. a -> (a -> b) -> b
& forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pj forall s t a b. ASetter s t a b -> b -> s -> t
.~ PathJoin (Maybe (PathDir n)) (BasicJoin n)
dirs where
  dirs :: PathJoin (Maybe (PathDir n)) (BasicJoin n)
dirs = forall d j. d -> j -> d -> PathJoin d j
PJ (P2 n -> P2 n -> Maybe (PathDir n)
dir P2 n
z0 P2 n
u) BasicJoin n
jj (P2 n -> P2 n -> Maybe (PathDir n)
dir P2 n
v P2 n
z1)
  dir :: P2 n -> P2 n -> Maybe (PathDir n)
  dir :: P2 n -> P2 n -> Maybe (PathDir n)
dir P2 n
p0 P2 n
p1 | P2 n
p0 forall a. Eq a => a -> a -> Bool
== P2 n
p1 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. n -> PathDir n
PathDirCurl n
1
  dir P2 n
p0 P2 n
p1 | Bool
otherwise = 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
$ (P2 n
p1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
p0)
controlPtDirs MFS n
s = MFS n
s

-- | Run all the rules required to fully specify all segment directions,
-- but do not replace the Joins with ControlJoin.
solve :: RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solve :: forall n. RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solve = forall n. RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solvePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. (Num n, Eq n) => MFP n -> MFP n
fillDirs

-- | each sublist of groupSegments ss satisfies:
-- isJust . d1 . pj . head
-- isJust . d2 . pj . last
-- all (isNothing . d1 . pj) . init . tail
-- all (isNothing . d2 . pj) . init . tail
-- That is, each sublist can be handled as a line,
-- (except the first and last, if the initial MFP was a loop).
groupSegments :: [MFS n] -> [[MFS n]]
groupSegments :: forall n. [MFS n] -> [[MFS n]]
groupSegments [] = []
groupSegments (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
s:[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss) = (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n
sforall a. a -> [a] -> [a]
:[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
open)forall a. a -> [a] -> [a]
:forall n. [MFS n] -> [[MFS n]]
groupSegments [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest where
  ([MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
open,[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isNothing) [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss

-- | Calculate the tangent direction at all remaining points.
-- This function dispatches all of the hard work to other functions.
-- It distinguishes 3 cases:
-- * A loop with no internal directions given.
-- * A loop with one or more directions given.
--     Mathematically, this is handled like a line, but the Loopness is
--     preserved, so that the Diagrams Trail is a Loop.
-- * A line, consisting of one or more segments as described in groupSegments.
-- Note that the result type is different from the input, reflecting
-- fully specified directions.
solvePath :: RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solvePath :: forall n. RealFloat n => MFP n -> MFPath (Dir n) (BasicJoin n) n
solvePath (MFP Bool
False [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss) = forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
False (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n.
RealFloat n =>
[MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. [MFS n] -> [[MFS n]]
groupSegments forall a b. (a -> b) -> a -> b
$ [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss)
-- A simple loop.  All directions are unknown, curvature gives us enough equations.
solvePath (MFP Bool
True [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Maybe a -> Bool
isNothing) [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss = forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
True forall a b. (a -> b) -> a -> b
$ forall n.
RealFloat n =>
[MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLoop [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss
solvePath (MFP Bool
True [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss) = forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
True [MetafontSegment (Dir n) (BasicJoin n) n]
ss'' where
  ss' :: [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss' = forall n. [MFS n] -> [[MFS n]]
groupSegments [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss
  ss'' :: [MetafontSegment (Dir n) (BasicJoin n) n]
ss'' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n.
RealFloat n =>
[MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLine forall a b. (a -> b) -> a -> b
$ case [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss'forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!forall s a. Cons s s a a => Traversal' s a
_headforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!forall s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1 of
      (Just (PathDirDir Dir n
_)) -> [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss'
      Maybe (PathDir n)
_ -> (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss'forall s a. s -> Getting (First a) s a -> Maybe a
^?forall s a. Cons s s a a => Traversal' s s
_tailforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. Snoc s s a a => Traversal' s s
_init) forall a. [a] -> [a] -> [a]
++ [forall a. [a] -> a
last [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss' forall a. [a] -> [a] -> [a]
++ forall a. [a] -> a
head [[MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]]
ss']

-- | Calculate the tangent directions at all points.  The input list is assumed
-- to form a loop; this is not checked.
-- See 'setDirs' for an explanation of offset angles.
solveLoop :: forall n. (RealFloat n) => [MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLoop :: forall n.
RealFloat n =>
[MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLoop [MFS n]
ss = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall n.
Floating n =>
MFS n -> n -> n -> MetafontSegment (Dir n) (BasicJoin n) n
setDirs [MFS n]
ss [n]
thetas [n]
phis where
  segmentPairs :: [(MFS n, MFS n)]
segmentPairs = forall a b. [a] -> [b] -> [(a, b)]
zip [MFS n]
ss (forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
cycle forall a b. (a -> b) -> a -> b
$ [MFS n]
ss)
  thetas, phis :: [n]
  thetas :: [n]
thetas = forall n. RealFloat n => [MFS n] -> [n]
loopDirs [MFS n]
ss
  phis :: [n]
phis = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi [(MFS n, MFS n)]
segmentPairs) (forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
cycle forall a b. (a -> b) -> a -> b
$ [n]
thetas)

-- | Calculate the offset angles θ for the case of a loop.
--   This is a system of (length ss) equations.  The first element of
--   loopDirs ss is θ for the starting point of the first segment of ss.
loopDirs :: RealFloat n => [MFS n] -> [n]
loopDirs :: forall n. RealFloat n => [MFS n] -> [n]
loopDirs [MFS n]
ss = forall a. Fractional a => [a] -> [a] -> [a] -> [a] -> a -> a -> [a]
solveCyclicTriDiagonal [n]
lower [n]
diag [n]
upper [n]
products n
ll n
ur where
  ([n]
lower, [n]
diag, [n]
upper, [n]
products, n
ll, n
ur) = forall n. RealFloat n => [MFS n] -> ([n], [n], [n], [n], n, n)
loopEqs [MFS n]
ss

-- | Calculate the coefficients for the loop case, in the
-- format required by solveCyclicTriDiagonal.
-- See mf.web ¶ 273
loopEqs :: RealFloat n => [MFS n]
           -> ([n], [n], [n], [n], n, n)
loopEqs :: forall n. RealFloat n => [MFS n] -> ([n], [n], [n], [n], n, n)
loopEqs [MFS n]
ss = ([n]
lower, [n]
diag, [n]
upper, [n]
products, n
ll, n
ur) where
  lower :: [n]
lower = forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
aCo (forall a. [a] -> [a]
init [MFS n]
ss)
  sLast :: MFS n
sLast = forall a. [a] -> a
last [MFS n]
ss
  diag :: [n]
diag = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
bCo forall a b. (a -> b) -> a -> b
$ [MFS n
sLast] forall a. [a] -> [a] -> [a]
++ [MFS n]
ss) (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
cCo [MFS n]
ss)
  upper :: [n]
upper = forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
dCo (forall a. [a] -> [a]
init [MFS n]
ss)
  ur :: n
ur = forall n. Floating n => MFS n -> n
aCo MFS n
sLast
  ll :: n
ll = forall n. Floating n => MFS n -> n
dCo MFS n
sLast
  segmentPairs :: [(MFS n, MFS n)]
segmentPairs = forall a b. [a] -> [b] -> [(a, b)]
zip ([forall a. [a] -> a
last [MFS n]
ss] forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init [MFS n]
ss) [MFS n]
ss
  products :: [n]
products = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-)
               [-n
1 forall a. Num a => a -> a -> a
* forall n. Floating n => MFS n -> n
bCo MFS n
l forall a. Num a => a -> a -> a
* forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (MFS n, MFS n)
s | s :: (MFS n, MFS n)
s@(MFS n
l,MFS n
_) <- [(MFS n, MFS n)]
segmentPairs]
               (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(*)
                (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
dCo [MFS n]
ss)
                (forall a b. (a -> b) -> [a] -> [b]
map forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [(MFS n, MFS n)]
segmentPairs)
                forall a. [a] -> [a] -> [a]
++ [forall n. Floating n => MFS n -> n
dCo MFS n
sLast forall a. Num a => a -> a -> a
* forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (forall a. [a] -> a
head [(MFS n, MFS n)]
segmentPairs)])

-- | solveLine takes a list of segments where only the first and last points
-- have known directions.  The type signature matches that of solveLoop, and the
-- precondition is not checked.
-- The equivalent MetaFont code (in make_choices) is written in terms of points,
-- rather than segments.  See metafont code paragraphs 271--274.
solveLine :: forall n. RealFloat n => [MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLine :: forall n.
RealFloat n =>
[MFS n] -> [MetafontSegment (Dir n) (BasicJoin n) n]
solveLine [MFS P2 n
z1 (PJ (Just (PathDirDir Dir n
d1')) BasicJoin n
jj (Just (PathDirDir Dir n
d2'))) 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 Dir n
d1' BasicJoin n
jj Dir n
d2') P2 n
z2]
solveLine [MFS n]
ss = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall n.
Floating n =>
MFS n -> n -> n -> MetafontSegment (Dir n) (BasicJoin n) n
setDirs [MFS n]
ss (forall a. [a] -> [a]
init [n]
thetas) [n]
phis where
  segmentPairs :: [(MFS n, MFS n)]
segmentPairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
init [MFS n]
ss) (forall a. [a] -> [a]
tail [MFS n]
ss)
  thetas :: [n]
thetas = forall n. RealFloat n => [MFS n] -> [n]
lineDirs [MFS n]
ss
  phis :: [n]
  phis :: [n]
phis = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi [(MFS n, MFS n)]
segmentPairs forall a. [a] -> [a] -> [a]
++ [n
0]) (forall a. [a] -> [a]
tail [n]
thetas)

-- | setDirs takes a segment with underspecified directions, and two offset
-- angles, and sets the directions at both ends of the segment.
-- The offset angle is measured between the direction vector at either end and
-- the vector difference of the segment endpoints.
setDirs :: Floating n => MFS n -- ^ The segment to be modified
        -> n -- ^ theta, the offset angle at the starting point
        -> n -- ^ phi, the ofset angle at the endpoint
        -> MetafontSegment (Dir n) (BasicJoin n) n
setDirs :: forall n.
Floating n =>
MFS n -> n -> n -> MetafontSegment (Dir n) (BasicJoin n) n
setDirs (MFS P2 n
z0 (PJ Maybe (PathDir n)
w0' BasicJoin n
jj Maybe (PathDir n)
w1') P2 n
z1) n
t n
p = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
z0 (forall d j. d -> j -> d -> PathJoin d j
PJ Direction V2 n
w0 BasicJoin n
jj Direction V2 n
w1) P2 n
z1 where
    offs :: Direction V2 n
offs  = forall (v :: * -> *) n. v n -> Direction v n
direction forall a b. (a -> b) -> a -> b
$ P2 n
z1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0
    w0 :: Direction V2 n
w0 = case Maybe (PathDir n)
w0' of
      (Just (PathDirDir Direction V2 n
d)) -> Direction V2 n
d
      Maybe (PathDir n)
_ -> Direction V2 n
offs forall a b. a -> (a -> b) -> b
# forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (n
t forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)
    w1 :: Direction V2 n
w1 = case Maybe (PathDir n)
w1' of
      (Just (PathDirDir Direction V2 n
d)) -> Direction V2 n
d
      Maybe (PathDir n)
_ -> Direction V2 n
offs forall a b. a -> (a -> b) -> b
# forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (forall a. Num a => a -> a
negate n
p forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | psi (l,r) calculates the turning angle between segments l and r, if
-- each segment were a straight line connecting its endpoints.  The endpoint of l
-- is assumed to be the starting point of r; this is not checked.
psi :: RealFloat n => (MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi :: forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (MetafontSegment p j1 n
l,MetafontSegment p j1 n
r) = forall n. RealFrac n => n -> n
normalizeTurns n
t where
  t :: n
t = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Floating n => Iso' (Angle n) n
turn forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween (forall n p j. Num n => MetafontSegment p j n -> V2 n
mfSegmentOffset MetafontSegment p j1 n
r) (forall n p j. Num n => MetafontSegment p j n -> V2 n
mfSegmentOffset MetafontSegment p j1 n
l)

-- | lineDirs calculates the offset angles θ for a Line.  Most of the work
-- done by lineEqs and solveTriDiagonal, but lineDirs handles the separate cases
-- of an empty list, and lists of length one.  See mf.web ¶ 280.
lineDirs :: RealFloat n => [MFS n] -> [n]
lineDirs :: forall n. RealFloat n => [MFS n] -> [n]
lineDirs [MFS n]
ss | forall (t :: * -> *) a. Foldable t => t a -> Int
length [MFS n]
ss forall a. Ord a => a -> a -> Bool
> Int
1 = forall a. Fractional a => [a] -> [a] -> [a] -> [a] -> [a]
solveTriDiagonal [n]
lower [n]
diag [n]
upper [n]
products where
  ([n]
lower, [n]
diag, [n]
upper, [n]
products) = forall n. RealFloat n => [MFS n] -> ([n], [n], [n], [n])
lineEqs [MFS n]
ss
lineDirs [] = []
lineDirs [MFS n
s] | forall n. MFS n -> Bool
leftCurl MFS n
s Bool -> Bool -> Bool
&& forall n. MFS n -> Bool
rightCurl MFS n
s = [n
0, n
0] where
lineDirs [MFS n
s] | forall n. MFS n -> Bool
rightCurl MFS n
s = forall a. Fractional a => [a] -> [a] -> [a] -> [a] -> [a]
solveTriDiagonal [n
a] [n
1,n
c] [n
0] [forall n. RealFrac n => n -> n
normalizeTurns n
t, n
r] where
  (n
a,n
c,n
r) = forall n. RealFloat n => MFS n -> (n, n, n)
solveOneSeg MFS n
s
  (PathDirDir Dir n
d) = MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. HasCallStack => Maybe a -> a
fromJust
  t :: n
t = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Floating n => Iso' (Angle n) n
turn forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n.
(Metric v, Floating n, Ord n) =>
Direction v n -> Direction v n -> Angle n
angleBetweenDirs Dir n
d (forall (v :: * -> *) n. v n -> Direction v n
direction forall a b. (a -> b) -> a -> b
$ MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)
lineDirs [MFS n
s] | forall n. MFS n -> Bool
leftCurl MFS n
s = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => [MFS n] -> [n]
lineDirs [forall n. Num n => MFS n -> MFS n
reverseSeg MFS n
s]
lineDirs [MFS n]
_ = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"lineDirs was called on something inappropriate.  \
\It should be called on a list of segments with directions specified at both ends.\
\It should only be called through solveLine."

-- | Each intermediate point produces one curvature equation, as in loopEqs.
-- The endpoint equations are the same as those for the single-segment line in
-- lineDirs.
-- lineEqs only works when segs has length > 1; this precondition is not checked.
lineEqs :: RealFloat n => [MFS n] -> ([n], [n], [n], [n])
lineEqs :: forall n. RealFloat n => [MFS n] -> ([n], [n], [n], [n])
lineEqs [MFS n]
ss = ([n]
lower, [n]
diag, [n]
upper, [n]
products) where
  segmentPairs :: [(MFS n, MFS n)]
segmentPairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
init [MFS n]
ss) (forall a. [a] -> [a]
tail [MFS n]
ss)
  lower :: [n]
lower = forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
aCo (forall a. [a] -> [a]
init [MFS n]
ss) forall a. [a] -> [a] -> [a]
++ [n
an]
  diag :: [n]
diag  = n
c0 forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
bCo (forall a. [a] -> [a]
init [MFS n]
ss)) (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
cCo (forall a. [a] -> [a]
tail [MFS n]
ss)) forall a. [a] -> [a] -> [a]
++ [n
cn]
  upper :: [n]
upper = (n
d0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
dCo (forall a. [a] -> [a]
tail [MFS n]
ss))
  products :: [n]
products = n
r0 forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-)
               [-n
1 forall a. Num a => a -> a -> a
* forall n. Floating n => MFS n -> n
bCo MFS n
l forall a. Num a => a -> a -> a
* forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (MFS n, MFS n)
s | s :: (MFS n, MFS n)
s@(MFS n
l,MFS n
_) <- [(MFS n, MFS n)]
segmentPairs]
               (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(*)
                 (forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => MFS n -> n
dCo (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ [MFS n]
ss))
                 (forall a b. (a -> b) -> [a] -> [b]
map forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (forall a. [a] -> [a]
tail [(MFS n, MFS n)]
segmentPairs)
                forall a. [a] -> [a] -> [a]
++ [n
0])) forall a. [a] -> [a] -> [a]
++ [n
rn]
  (n
d0,n
c0,n
_) = forall n. RealFloat n => MFS n -> (n, n, n)
solveOneSeg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => MFS n -> MFS n
reverseSeg forall a b. (a -> b) -> a -> b
$ MFS n
s0
  r0 :: n
r0 = PathDir n -> n
r0' (MFS n
s0forall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. HasCallStack => Maybe a -> a
fromJust) where
    r0' :: PathDir n -> n
r0' (PathDirDir Dir n
d) = forall n. RealFrac n => n -> n
normalizeTurns n
t where
      t :: n
t = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Floating n => Iso' (Angle n) n
turn forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n.
(Metric v, Floating n, Ord n) =>
Direction v n -> Direction v n -> Angle n
angleBetweenDirs Dir n
d  (forall (v :: * -> *) n. v n -> Direction v n
direction forall a b. (a -> b) -> a -> b
$ MFS n
s0forall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. MFS n
s0forall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)
    r0' (PathDirCurl n
_) = forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ n
d0 forall a. Num a => a -> a -> a
* forall n p j1.
RealFloat n =>
(MetafontSegment p j1 n, MetafontSegment p j1 n) -> n
psi (MFS n
s0, [MFS n]
ssforall a. [a] -> Int -> a
!!Int
1)
  s0 :: MFS n
s0 = forall a. [a] -> a
head [MFS n]
ss
  (n
an, n
cn, n
rn) = forall n. RealFloat n => MFS n -> (n, n, n)
solveOneSeg (forall a. [a] -> a
last [MFS n]
ss)

-- These functions calculate the coefficients in lineEqs, loopEqs
-- They are derived in mf.web ¶ 272-273
alpha, beta, aCo, bCo, cCo, dCo :: Floating n => MFS n -> n
alpha :: forall n. Floating n => MFS n -> n
alpha MFS n
s = n
1 forall a. Fractional a => a -> a -> a
/ MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
jforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. Either a b -> a
fromLeftforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (TensionJoin n) (Tension n)
t1forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall n. Tension n -> n
getTension
beta :: forall n. Floating n => MFS n -> n
beta  MFS n
s = n
1 forall a. Fractional a => a -> a -> a
/ MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
jforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. Either a b -> a
fromLeftforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (TensionJoin n) (Tension n)
t2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall n. Tension n -> n
getTension
aCo :: forall n. Floating n => MFS n -> n
aCo MFS n
s = (forall n. Floating n => MFS n -> n
alpha MFS n
s) forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
beta MFS n
s forall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* forall n p j. Floating n => MetafontSegment p j n -> n
mfSegmentLength MFS n
s)
bCo :: forall n. Floating n => MFS n -> n
bCo MFS n
s = (n
3 forall a. Num a => a -> a -> a
- forall n. Floating n => MFS n -> n
alpha MFS n
s) forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
beta MFS n
s forall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* forall n p j. Floating n => MetafontSegment p j n -> n
mfSegmentLength MFS n
s)
cCo :: forall n. Floating n => MFS n -> n
cCo MFS n
s = (n
3 forall a. Num a => a -> a -> a
- forall n. Floating n => MFS n -> n
beta MFS n
s) forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
alpha MFS n
s forall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* forall n p j. Floating n => MetafontSegment p j n -> n
mfSegmentLength MFS n
s)
dCo :: forall n. Floating n => MFS n -> n
dCo MFS n
s = (forall n. Floating n => MFS n -> n
beta MFS n
s) forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
alpha MFS n
s forall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* forall n p j. Floating n => MetafontSegment p j n -> n
mfSegmentLength MFS n
s)

-- | solveOneSeg calculates the coefficients of the angle equation for
-- the final segment of a line, which may incidentally be the only
-- segment.
solveOneSeg :: RealFloat n => MFS n -> (n, n, n)
solveOneSeg :: forall n. RealFloat n => MFS n -> (n, n, n)
solveOneSeg MFS n
s = (n
a, n
c, n
r) where
  a :: n
a = PathDir n -> n
a' (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. HasCallStack => Maybe a -> a
fromJust) where
    a' :: PathDir n -> n
a' (PathDirDir Dir n
_) = n
0
    a' (PathDirCurl n
g) = (n
3 forall a. Num a => a -> a -> a
- forall n. Floating n => MFS n -> n
beta MFS n
s) forall a. Num a => a -> a -> a
* (forall n. Floating n => MFS n -> n
beta MFS n
s) forall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* n
g forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
alpha MFS n
s forall a. Floating a => a -> a -> a
**n
2) forall a. Num a => a -> a -> a
+ forall n. Floating n => MFS n -> n
alpha MFS n
s
  c :: n
c = PathDir n -> n
c' (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. HasCallStack => Maybe a -> a
fromJust) where
       c' :: PathDir n -> n
c' (PathDirDir Dir n
_) = n
1
       c' (PathDirCurl n
g) = forall n. Floating n => MFS n -> n
beta MFS n
s forall a. Floating a => a -> a -> a
**n
3 forall a. Num a => a -> a -> a
* n
g forall a. Fractional a => a -> a -> a
/ (forall n. Floating n => MFS n -> n
alpha MFS n
s forall a. Floating a => a -> a -> a
**n
2) forall a. Num a => a -> a -> a
+ n
3 forall a. Num a => a -> a -> a
- forall n. Floating n => MFS n -> n
alpha MFS n
s
  r :: n
r = PathDir n -> n
r' (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d1 j1 n d2 j2.
Lens
  (MetafontSegment d1 j1 n)
  (MetafontSegment d2 j2 n)
  (PathJoin d1 j1)
  (PathJoin d2 j2)
pjforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j. Lens' (PathJoin d j) d
d2forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. HasCallStack => Maybe a -> a
fromJust) where
    r' :: PathDir n -> n
r' (PathDirDir Dir n
d) = forall n. RealFrac n => n -> n
normalizeTurns n
t where
      t :: n
t = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Floating n => Iso' (Angle n) n
turn forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n.
(Metric v, Floating n, Ord n) =>
v n -> v n -> Angle n
angleBetween (forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Dir n
d)  (MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. MFS n
sforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)
    r' (PathDirCurl n
_) = n
0

-- | Take a segment whose endpoint directions have been fully
--   determined, and compute the control points to realize it as a
--   cubic Bézier segment.  If the segment already has control points
--   specified, the directions are ignored (they are assumed to
--   match).  If the segment tensions are specified as TensionAtLeast,
--   check whether the minimum tension will lead to an inflection
--   point.  If so, pick the maximum velocity (equivalent to minimum
--   tension) that avoids the inflection point.  Otherwise, calculate
--   the velocity from the tension using 'hobbyF'.  Then calculate the
--   control point positions from the direction and the velocity.
--   Afterwards we can forget the direction information (since the
--   control points are what we really want, and the directions can be
--   recovered by subtracting the control points from the endpoints
--   anyway).
computeControls
  :: RealFloat n => MetafontSegment (Dir n) (BasicJoin n) n
  -> MetafontSegment () (ControlJoin n) n
computeControls :: forall n.
RealFloat n =>
MetafontSegment (Dir n) (BasicJoin n) n
-> MetafontSegment () (ControlJoin n) n
computeControls (MFS P2 n
z0 (PJ Dir n
_ (Right ControlJoin n
cj) Dir n
_) P2 n
z1)
  = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
z0 (forall d j. d -> j -> d -> PathJoin d j
PJ () ControlJoin n
cj ()) P2 n
z1
computeControls (MFS P2 n
z0 (PJ Dir n
w0 (Left (TJ Tension n
a Tension n
b)) Dir n
w1) P2 n
z1)
  = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
z0 (forall d j. d -> j -> d -> PathJoin d j
PJ () (forall n. P2 n -> P2 n -> ControlJoin n
CJ P2 n
u P2 n
v) ()) P2 n
z1
  where
    w0' :: V2 n
w0' = forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Dir n
w0
    w1' :: V2 n
w1' = forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Dir n
w1
    (P2 n
u,P2 n
v) = forall n.
RealFloat n =>
P2 n -> V2 n -> n -> n -> V2 n -> P2 n -> (P2 n, P2 n)
ctrlPts P2 n
z0 V2 n
w0' n
va n
vb V2 n
w1' P2 n
z1
    offs :: Diff (Point V2) n
offs  = P2 n
z1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0
    theta :: Angle n
theta = forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween V2 n
w0' Diff (Point V2) n
offs
    phi :: Angle n
phi   = forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween Diff (Point V2) n
offs V2 n
w1'
    sinR :: Angle n -> n
sinR  = forall a. Floating a => a -> a
sin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Iso' (Angle n) n
rad
    boundingTriangleExists :: Bool
boundingTriangleExists = forall a. Num a => a -> a
signum (Angle n -> n
sinR Angle n
theta) forall a. Eq a => a -> a -> Bool
== forall a. Num a => a -> a
signum (Angle n -> n
sinR Angle n
phi)
                             Bool -> Bool -> Bool
&& forall a. Num a => a -> a
signum (Angle n -> n
sinR Angle n
theta) forall a. Eq a => a -> a -> Bool
== forall a. Num a => a -> a
signum (Angle n -> n
sinR (Angle n
thetaforall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^Angle n
phi))
    va :: n
va = case Tension n
a of
              (TensionAmt n
ta) -> forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
theta Angle n
phi forall a. Fractional a => a -> a -> a
/ n
ta
              (TensionAtLeast n
ta) -> case Bool
boundingTriangleExists of
                  Bool
True -> forall a. Ord a => a -> a -> a
min (Angle n -> n
sinR Angle n
phi forall a. Fractional a => a -> a -> a
/ Angle n -> n
sinR (Angle n
theta forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
phi))
                              (forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
theta Angle n
phi forall a. Fractional a => a -> a -> a
/ n
ta)
                  Bool
False -> forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
theta Angle n
phi forall a. Fractional a => a -> a -> a
/ n
ta
    vb :: n
vb = case Tension n
b of
              (TensionAmt n
tb) -> forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
phi Angle n
theta forall a. Fractional a => a -> a -> a
/ n
tb
              (TensionAtLeast n
tb) -> case Bool
boundingTriangleExists of
                  Bool
True -> forall a. Ord a => a -> a -> a
min (Angle n -> n
sinR Angle n
theta forall a. Fractional a => a -> a -> a
/ Angle n -> n
sinR (Angle n
theta forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
phi))
                              (forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
phi Angle n
theta forall a. Fractional a => a -> a -> a
/ n
tb)
                  Bool
False -> forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
phi Angle n
theta forall a. Fractional a => a -> a -> a
/ n
tb

-- | Compute the control points for a cubic bezier, given a segment
--   where we know the directions and tensions at both endpoints,
--   i.e. go from
--
--   @z0{w0} .. tension a and b .. {w1}z1@
--
--   to
--
--   @z0 .. controls u and v .. z1@.
--
--   This uses a mysterious, magical formula due to John Hobby.
ctrlPts :: RealFloat n => P2 n -> V2 n -> n -> n -> V2 n -> P2 n -> (P2 n, P2 n)
ctrlPts :: forall n.
RealFloat n =>
P2 n -> V2 n -> n -> n -> V2 n -> P2 n -> (P2 n, P2 n)
ctrlPts P2 n
z0 V2 n
w0 n
va n
vb V2 n
w1 P2 n
z1 = (P2 n
u,P2 n
v)
  where
    offs :: Diff (Point V2) n
offs  = P2 n
z1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0
    theta :: Angle n
theta = forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween V2 n
w0 Diff (Point V2) n
offs
    phi :: Angle n
phi   = forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween Diff (Point V2) n
offs V2 n
w1
    u :: P2 n
u     = P2 n
z0 forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (Diff (Point V2) n
offs forall a b. a -> (a -> b) -> b
# forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta  forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
va)
    v :: P2 n
v     = P2 n
z1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ (Diff (Point V2) n
offs forall a b. a -> (a -> b) -> b
# forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
phi) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
vb)

-- | Some weird function that computes some sort of scaling factor
--   based on the turning angles between endpoints and direction
--   vectors (again due to Hobby).
hobbyF :: Floating n => Angle n -> Angle n -> n
hobbyF :: forall n. Floating n => Angle n -> Angle n -> n
hobbyF Angle n
theta' Angle n
phi' = let
    theta :: n
theta = Angle n
theta' forall s a. s -> Getting a s a -> a
^. forall n. Iso' (Angle n) n
rad
    phi :: n
phi = Angle n
phi' forall s a. s -> Getting a s a -> a
^. forall n. Iso' (Angle n) n
rad
    in
     (n
2 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt n
2 forall a. Num a => a -> a -> a
* (forall a. Floating a => a -> a
sin n
theta forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
sin n
phi forall a. Fractional a => a -> a -> a
/ n
16)forall a. Num a => a -> a -> a
*(forall a. Floating a => a -> a
sin n
phi forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
sin n
theta forall a. Fractional a => a -> a -> a
/ n
16)forall a. Num a => a -> a -> a
*(forall a. Floating a => a -> a
cos n
theta forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
cos n
phi))
     forall a. Fractional a => a -> a -> a
/
     (n
3 forall a. Num a => a -> a -> a
* (n
1 forall a. Num a => a -> a -> a
+ (forall a. Floating a => a -> a
sqrt n
5 forall a. Num a => a -> a -> a
- n
1)forall a. Fractional a => a -> a -> a
/n
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos n
theta forall a. Num a => a -> a -> a
+ (n
3 forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
sqrt n
5)forall a. Fractional a => a -> a -> a
/n
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos n
phi))

-- | Convert a fully specified MetafontSegment to a Diagrams Segment
importSegment :: Num n => MetafontSegment () (ControlJoin n) n -> Segment Closed V2 n
importSegment :: forall n.
Num n =>
MetafontSegment () (ControlJoin n) n -> Segment Closed V2 n
importSegment (MFS P2 n
z0 (PJ () (CJ P2 n
u P2 n
v) ()) P2 n
z1) = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (P2 n
u forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0) (P2 n
v forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0) (P2 n
z1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
z0)

-- | Convert a MetaFont path to a Diagrams Trail, using a Loop or Line as needed
locatedTrail :: (Floating n, Ord n) => MFPath () (ControlJoin n) n -> Located (Trail V2 n)
locatedTrail :: forall n.
(Floating n, Ord n) =>
MFPath () (ControlJoin n) n -> Located (Trail V2 n)
locatedTrail (MFP Bool
False [MetafontSegment () (ControlJoin n) n]
ss)  = (forall (v :: * -> *) n. Trail' Line v n -> Trail v n
wrapLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n.
Num n =>
MetafontSegment () (ControlJoin n) n -> Segment Closed V2 n
importSegment forall a b. (a -> b) -> a -> b
$ [MetafontSegment () (ControlJoin n) n]
ss)
                                forall a. a -> Point (V a) (N a) -> Located a
`at` (forall a. [a] -> a
head [MetafontSegment () (ControlJoin n) n]
ss forall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)
locatedTrail (MFP Bool
True [MetafontSegment () (ControlJoin n) n]
ss)   = (forall (v :: * -> *) n. Trail' Loop v n -> Trail v n
wrapLoop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n.
Num n =>
MetafontSegment () (ControlJoin n) n -> Segment Closed V2 n
importSegment forall a b. (a -> b) -> a -> b
$ [MetafontSegment () (ControlJoin n) n]
ss)
                                forall a. a -> Point (V a) (N a) -> Located a
`at` (forall a. [a] -> a
head [MetafontSegment () (ControlJoin n) n]
ss forall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)

-- | Convert a path in combinator syntax to the internal
-- representation used for solving.
mfPathToSegments :: forall n. Num n => MFPathData P n -> MFP n
mfPathToSegments :: forall n. Num n => MFPathData P n -> MFP n
mfPathToSegments = forall {d} {j} {n}. MFPath d j n -> MFPath d j n
fixCycleSegment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFPathData P n -> (P2 n, MFP n)
mfPathToSegments'
  where
    mfPathToSegments' :: MFPathData P n -> (P2 n, MFP n)
    mfPathToSegments' :: MFPathData P n -> (P2 n, MFP n)
mfPathToSegments' (MFPathEnd P2 n
p0) = (P2 n
p0, forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
False [])
    mfPathToSegments' MFPathData P n
MFPathCycle    = (forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin, forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
True [])
    mfPathToSegments' (MFPathPt P2 n
p0 (MFPathJoin PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
jj MFPathData P n
path)) = (P2 n
p0, forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
c (forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
p0 PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj' P2 n
p1 forall a. a -> [a] -> [a]
: [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss))
      where
        (P2 n
p1, MFP Bool
c [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss) = MFPathData P n -> (P2 n, MFP n)
mfPathToSegments' MFPathData P n
path
        jj' :: PathJoin (Maybe (PathDir n)) (BasicJoin n)
jj' = case PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
jjforall s a. s -> Getting a s a -> a
^.forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
j of
            Maybe (BasicJoin n)
Nothing -> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
jj forall a b. a -> (a -> b) -> b
& forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
j forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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))
            Just BasicJoin n
bj -> PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))
jj forall a b. a -> (a -> b) -> b
& forall d j1 j2. Lens (PathJoin d j1) (PathJoin d j2) j1 j2
j forall s t a b. ASetter s t a b -> b -> s -> t
.~ BasicJoin n
bj
    fixCycleSegment :: MFPath d j n -> MFPath d j n
fixCycleSegment (MFP Bool
True [MetafontSegment d j n]
ss) = forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
True ([MetafontSegment d j n]
ss forall a b. a -> (a -> b) -> b
& forall s a. Snoc s s a a => Traversal' s a
_lastforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x2 forall s t a b. ASetter s t a b -> b -> s -> t
.~ [MetafontSegment d j n]
ssforall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!forall s a. Cons s s a a => Traversal' s a
_headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)
    fixCycleSegment MFPath d j n
p = MFPath d j n
p