{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Diagrams.TwoD.Path.Metafont.Internal
(
solve, computeControls, locatedTrail
, 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
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
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
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, 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 :: 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
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
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"
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)
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
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 [] = []
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 [] = []
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
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
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
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
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)
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']
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)
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
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 :: 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 :: Floating n => MFS n
-> n
-> n
-> 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 :: 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 :: 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."
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)
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 :: 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
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
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)
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))
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)
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)
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