diagrams-contrib 1.4.6 → 1.4.7
raw patch · 4 files changed
+341/−246 lines, 4 filesdep −HUnitdep −mtl-compatdep −semigroupsdep ~QuickCheckdep ~basedep ~containers
Dependencies removed: HUnit, mtl-compat, semigroups, test-framework-hunit
Dependency ranges changed: QuickCheck, base, containers, diagrams-lib, diagrams-solve
Files
- CHANGES.markdown +15/−0
- diagrams-contrib.cabal +10/−15
- src/Diagrams/TwoD/Path/Metafont/Internal.hs +288/−203
- src/Diagrams/TwoD/Path/Metafont/Types.hs +28/−28
CHANGES.markdown view
@@ -1,7 +1,22 @@+1.4.7 (24 Sep 2026)+-------------------++- Add support for GHC 9.14+- Drop support for GHC 8.4+- Remove unused dependencies+- Fix many (though not all (yet)) warnings+- Allow `containers-0.8`, `diagrams-lib-1.6`, `diagrams-solve-0.3`, `QuickCheck-2.18`+ 1.4.6 (29 Oct 2024) ------------------- - Upgrade to require `data-default-0.8` and drop dependency on `data-default-class`++- Hackage revisions+ - r1 (17 Feb 2025): allow `random-1.3`, `diagrams-1.5`, and test+ on GHC 9.12+ - r2 (2 Jun 2025): allow `monoid-extras-0.7`+ - r3 (19 June 2025): allow `QuickCheck-2.16` 1.4.5.1 (10 July 2023) ----------------------
diagrams-contrib.cabal view
@@ -1,5 +1,5 @@ name: diagrams-contrib-version: 1.4.6+version: 1.4.7 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation@@ -15,7 +15,7 @@ cabal-version: 1.18 extra-source-files: README.markdown, diagrams/*.svg, CONTRIBUTORS extra-doc-files: diagrams/*.svg, CHANGES.markdown-tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 || ==9.14.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-contrib.git@@ -51,27 +51,25 @@ Diagrams.TwoD.Path.Metafont.Internal Diagrams.TwoD.Path.Metafont.Combinators Diagrams.TwoD.Path.Metafont.Parser- build-depends: base >= 4.8 && < 4.21,+ build-depends: base >= 4.8 && < 4.23, mtl >= 2.0 && < 2.4,- mtl-compat >= 0.2.1 && < 0.3,- containers > 0.4 && < 0.8,+ containers > 0.4 && < 0.9, split >= 0.2.1 && < 0.3, colour >= 2.3.1 && < 2.4, split >= 0.2.1 && < 0.3,- monoid-extras >= 0.4.2 && < 0.7,+ monoid-extras >= 0.4.2 && < 0.8, diagrams-core >= 1.4 && < 1.6,- diagrams-lib >= 1.4 && < 1.5,- diagrams-solve >= 0.1 && < 0.2,+ diagrams-lib >= 1.4 && < 1.7,+ diagrams-solve >= 0.1 && < 0.4, lens >= 4.0 && < 5.4, linear >= 1.11.3 && < 1.24, force-layout >= 0.4 && < 0.5, data-default >= 0.8 && < 0.9, MonadRandom >= 0.1.8 && < 0.7,- random >= 1.0 && < 1.3,+ random >= 1.0 && < 1.4, circle-packing >= 0.1 && < 0.2, parsec >= 3.1 && < 3.2, text >= 0.11 && < 2.2,- semigroups >= 0.3.4 && < 0.21, cubicbezier >= 0.6 && < 0.7, hashable >= 0.1.2 && < 1.6, mfsolve >= 0.3 && < 0.4@@ -87,14 +85,11 @@ other-modules: Diagrams.TwoD.Path.Turtle.Tests Diagrams.TwoD.Path.Turtle.Internal - build-depends: HUnit >= 1.2 && < 1.7,- QuickCheck >= 2.4 && < 2.16,- containers >= 0.3 && < 0.8,+ build-depends: QuickCheck >= 2.4 && < 2.19, test-framework >= 0.4 && < 0.9,- test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, base >= 4.8 && < 5,- diagrams-lib >= 1.4 && < 1.5+ diagrams-lib >= 1.4 && < 1.7 default-language: Haskell2010
src/Diagrams/TwoD/Path/Metafont/Internal.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------+{- HLINT ignore "Redundant ^." -}+ -- | -- Module : Diagrams.TwoD.Path.Metafont.Internal -- Copyright : (c) 2013 Daniel Bergey@@ -13,41 +12,41 @@ -- 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+module Diagrams.TwoD.Path.Metafont.Internal (+ solve,+ computeControls,+ locatedTrail,+ -- combinator style+ mfPathToSegments,+)+where +import Control.Lens hiding (at, (#))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Diagrams.CubicSpline.NonSingleton (NonSingleton (..))+import qualified Diagrams.CubicSpline.NonSingleton as NS+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 s = MFS (s^.x2) (PJ (rDir $ s^.pj.d2) (s^.pj.j.to rj) (rDir $ s^.pj.d1)) (s^.x1) where- rj (Left t) = (Left (TJ (t^.t2) (t^.t1)))- rj (Right c) = (Right (CJ (c^.c2) (c^.c1)))- rDir (Just (PathDirDir d)) = (Just (PathDirDir (negated d)))+reverseSeg s = MFS (s ^. x2) (PJ (rDir $ s ^. pj . d2) (s ^. pj . j . to rj) (rDir $ s ^. pj . d1)) (s ^. x1)+ where+ rj (Left t) = Left (TJ (t ^. t2) (t ^. t1))+ rj (Right c) = Right (CJ (c ^. c2) (c ^. c1))+ rDir (Just (PathDirDir d)) = Just (PathDirDir (negated d)) rDir d = d -- | Calculate the length of a MetaFont segment.-mfSegmentLength :: Floating n => MetafontSegment p j n -> n+mfSegmentLength :: Floating n => MetafontSegment p j n -> n mfSegmentLength = norm . mfSegmentOffset -- | Calculate the vector between endpoints of the given segment. mfSegmentOffset :: Num n => MetafontSegment p j n -> V2 n-mfSegmentOffset s = s^.x2 .-. s^.x1+mfSegmentOffset s = (s ^. x2) .-. (s ^. x1) -- | leftCurl s is True if the first direction of s is specified as a curl leftCurl, rightCurl :: MFS n -> Bool@@ -60,8 +59,8 @@ -- | Normalize a number representing number of turns to ±½ normalizeTurns :: RealFrac n => n -> n-normalizeTurns t | t > 1/2 = t - realToFrac (ceiling t :: Int)-normalizeTurns t | t < -1/2 = t - realToFrac (floor t :: Int)+normalizeTurns t | t > 1 / 2 = t - realToFrac (ceiling t :: Int)+normalizeTurns t | t < -(1 / 2) = t - realToFrac (floor t :: Int) normalizeTurns t = t -- | By analogy with fromJust, fromLeft returns the Left value or errors@@ -69,7 +68,6 @@ fromLeft (Left l) = l fromLeft (Right _) = error "got Right in fromLeft" - -- | Fill in default values for as many blank directions as possible. -- @fillDirs@ implements all of the following rules: --@@ -87,33 +85,36 @@ -- -- Similarly controls u and v ... z ... -> z {z - v} (or curl 1) fillDirs :: (Num n, Eq n) => MFP n -> MFP n-fillDirs p = (copyDirsLoop . curlEnds) p & segs %~- (copyDirsR . copyDirsL . map controlPtDirs)+fillDirs p =+ (copyDirsLoop . curlEnds) p+ & segs+ %~ (copyDirsR . copyDirsL . map controlPtDirs) -- rules 1 & 2 curlEnds :: Num n => MFP n -> MFP n-curlEnds p | (p^.loop) = p-curlEnds p = p & segs %~ leftEnd where- leftEnd [s] = [s & pj.d1 %~ curlIfEmpty & pj.d2 %~ curlIfEmpty]- leftEnd (s:ss) = (s & pj.d1 %~ curlIfEmpty) : rightEnd ss- leftEnd [] = []- rightEnd [] = []- rightEnd [s] = [s & pj.d2 %~ curlIfEmpty]- rightEnd (s:ss) = s:rightEnd ss- curlIfEmpty Nothing = Just $ PathDirCurl 1- curlIfEmpty d = d+curlEnds p | p ^. loop = p+curlEnds p = p & segs %~ leftEnd+ where+ leftEnd [s] = [s & pj . d1 %~ curlIfEmpty & pj . d2 %~ curlIfEmpty]+ leftEnd (s : ss) = (s & pj . d1 %~ curlIfEmpty) : rightEnd ss+ leftEnd [] = []+ rightEnd [] = []+ rightEnd [s] = [s & pj . d2 %~ curlIfEmpty]+ rightEnd (s : ss) = s : rightEnd ss+ curlIfEmpty Nothing = Just $ PathDirCurl 1+ curlIfEmpty d = d -- rule 3 copyDirsL :: [MFS n] -> [MFS n]-copyDirsL (s1@(MFS _ (PJ _ _ Nothing) _) : ss@(MFS _ (PJ (Just d) _ _) _ : _))- = (s1 & pj.d2 .~ Just d) : copyDirsL ss+copyDirsL (s1@(MFS _ (PJ _ _ Nothing) _) : ss@(MFS _ (PJ (Just d) _ _) _ : _)) =+ (s1 & pj . d2 ?~ d) : copyDirsL ss copyDirsL (s1 : ss') = s1 : copyDirsL ss' copyDirsL [] = [] -- rule 4 copyDirsR :: [MFS n] -> [MFS n]-copyDirsR (s1@(MFS _ (PJ _ _ (Just d)) _) : s2@(MFS _ (PJ Nothing _ _) _) : ss)- = s1 : copyDirsR ((s2 & pj.d1 .~ Just d) : ss)+copyDirsR (s1@(MFS _ (PJ _ _ (Just d)) _) : s2@(MFS _ (PJ Nothing _ _) _) : ss) =+ s1 : copyDirsR ((s2 & pj . d1 ?~ d) : ss) copyDirsR (s1 : ss') = s1 : copyDirsR ss' copyDirsR [] = [] @@ -121,23 +122,27 @@ copyDirsLoop :: MFP n -> MFP n copyDirsLoop p | not $ _loop p = p copyDirsLoop p@(MFP _ []) = p-copyDirsLoop p | (p^?!segs._head.pj.d1.to isJust) &&- (p^?!segs._last.pj.d2.to isNothing) =- p & over (segs._last.pj.d2) (const $ p^?!segs._head.pj.d1)-copyDirsLoop p | p^?!segs._head.pj.d1.to isNothing &&- p^?!segs._last.pj.d2.to isJust =- p & over (segs._head.pj.d1) (const $ p^?!segs._last.pj.d2)+copyDirsLoop p+ | (p ^?! segs . _head . pj . d1 . to isJust)+ && (p ^?! segs . _last . pj . d2 . to isNothing) =+ p & over (segs . _last . pj . d2) (const $ p ^?! segs . _head . pj . d1)+copyDirsLoop p+ | p ^?! segs . _head . pj . d1 . to isNothing+ && p ^?! segs . _last . pj . d2 . to isJust =+ p & over (segs . _head . pj . d1) (const $ p ^?! segs . _last . pj . d2) copyDirsLoop p = 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 s@(MFS z0 (PJ _ jj@(Right (CJ u v)) _) z1) = s & pj .~ dirs where+controlPtDirs s@(MFS z0 (PJ _ jj@(Right (CJ u v)) _) z1) = s & pj .~ dirs+ where dirs = PJ (dir z0 u) jj (dir v z1) dir :: P2 n -> P2 n -> Maybe (PathDir n)- dir p0 p1 | p0 == p1 = Just $ PathDirCurl 1- dir p0 p1 | otherwise = Just . PathDirDir . direction $ (p1 .-. p0)+ dir p0 p1+ | p0 == p1 = Just $ PathDirCurl 1+ | otherwise = Just . PathDirDir . direction $ (p1 .-. p0) controlPtDirs s = s -- | Run all the rules required to fully specify all segment directions,@@ -154,8 +159,9 @@ -- (except the first and last, if the initial MFP was a loop). groupSegments :: [MFS n] -> [[MFS n]] groupSegments [] = []-groupSegments (s:ss) = (s:open):groupSegments rest where- (open,rest) = span (view $ pj.d1.to isNothing) ss+groupSegments (s : ss) = (s : open) : groupSegments rest+ where+ (open, rest) = span (view $ pj . d1 . to isNothing) ss -- | Calculate the tangent direction at all remaining points. -- This function dispatches all of the hard work to other functions.@@ -168,51 +174,66 @@ -- 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 (MFP False ss) = MFP False (concat . map solveLine . groupSegments $ ss)+solvePath (MFP False ss) = MFP False (concatMap solveLine . groupSegments $ ss) -- A simple loop. All directions are unknown, curvature gives us enough equations.-solvePath (MFP True ss) | all (view $ pj.d1.to isNothing) ss = MFP True $ solveLoop ss-solvePath (MFP True ss) = MFP True ss'' where+solvePath (MFP True ss@(s1 : s2 : s3)) | all (view $ pj . d1 . to isNothing) ss = MFP True . NE.toList . solveLoop $ s1 :|| s2 :| s3+solvePath (MFP True ss) = MFP True ss''+ where ss' = groupSegments ss- ss'' = concat . map solveLine $ case ss'^?!_head^?!_head.pj.d1 of- (Just (PathDirDir _)) -> ss'- _ -> (maybe [] id $ ss'^?_tail._init) ++ [last ss' ++ head ss']+ ss'' = concatMap solveLine $ case ss' ^?! _head ^?! _head . pj . d1 of+ (Just (PathDirDir _)) -> ss'+ _ -> fromMaybe [] (ss' ^? _tail . _init) ++ [last ss' ++ head 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 ss = zipWith3 setDirs ss thetas phis where- segmentPairs = zip ss (tail . cycle $ ss)- thetas, phis :: [n]+solveLoop :: forall n. RealFloat n => NonSingleton (MFS n) -> NonEmpty (MetafontSegment (Dir n) (BasicJoin n) n)+solveLoop ss = zipWith3NE setDirs (NS.toNonEmpty ss) thetas phis+ where+ segmentPairs = NS.zipWith (,) ss (rotateNS ss)+ thetas, phis :: NonEmpty n thetas = loopDirs ss- phis = map negate $ zipWith (+) (map psi segmentPairs) (tail . cycle $ thetas)+ phis = negate <$> NE.zipWith (+) (NS.toNonEmpty $ psi <$> segmentPairs) (rotateNE thetas) +zipWith3NE :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d+zipWith3NE f (a :| as) (b :| bs) (c :| cs) = f a b c :| zipWith3 f as bs cs+ -- | 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 ss = solveCyclicTriDiagonal lower diag upper products ll ur where+loopDirs :: RealFloat n => NonSingleton (MFS n) -> NonEmpty n+loopDirs ss = solveCyclicTriDiagonal lower diag upper products ll ur+ where (lower, diag, upper, products, ll, ur) = loopEqs 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 ss = (lower, diag, upper, products, ll, ur) where- lower = map aCo (init ss)- sLast = last ss- diag = zipWith (+) (map bCo $ [sLast] ++ ss) (map cCo ss)- upper = map dCo (init ss)+loopEqs ::+ RealFloat n =>+ NonSingleton (MFS n) ->+ (NonEmpty n, NonEmpty n, NonEmpty n, NonEmpty n, n, n)+loopEqs ss = (lower, NS.toNonEmpty diag, upper, NS.toNonEmpty products, ll, ur)+ where+ lower = fmap aCo (initNS ss)+ sLast = lastNS ss+ diag = NS.zipWith (+) (bCo <$> consNS sLast ss) (fmap cCo ss)+ upper = fmap dCo (initNS ss) ur = aCo sLast ll = dCo sLast- segmentPairs = zip ([last ss] ++ init ss) ss- products = zipWith (-)- [-1 * bCo l * psi s | s@(l,_) <- segmentPairs]- (zipWith (*)- (map dCo ss)- (map psi $ tail segmentPairs)- ++ [dCo sLast * psi (head segmentPairs)])+ segmentPairs = NS.zipWith (,) (lastNS ss :|| initNS ss) ss+ products =+ NS.zipWith+ (-)+ (fmap (\s@(l, _) -> (-1) * bCo l * psi s) segmentPairs)+ ( snocNS+ ( NE.zipWith+ (*)+ (dCo <$> NS.toNonEmpty ss)+ (psi <$> NS.tail segmentPairs)+ )+ (dCo sLast * psi (headNS 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@@ -220,9 +241,11 @@ -- 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]+-- NonEmpty -> NonEmpty ? solveLine [MFS z1 (PJ (Just (PathDirDir d1')) jj (Just (PathDirDir d2'))) z2] = [MFS z1 (PJ d1' jj d2') z2]-solveLine ss = zipWith3 setDirs ss (init thetas) phis where+solveLine ss = zipWith3 setDirs ss (init thetas) phis+ where segmentPairs = zip (init ss) (tail ss) thetas = lineDirs ss phis :: [n]@@ -232,91 +255,147 @@ -- 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 (MFS z0 (PJ w0' jj w1') z1) t p = MFS z0 (PJ w0 jj w1) z1 where- offs = direction $ z1 .-. z0- w0 = case w0' of- (Just (PathDirDir d)) -> d- _ -> offs # rotate (t @@ turn)- w1 = case w1' of- (Just (PathDirDir d)) -> d- _ -> offs # rotate (negate p @@ turn)+setDirs ::+ Floating n =>+ -- | The segment to be modified+ MFS n ->+ -- | theta, the offset angle at the starting point+ n ->+ -- | phi, the ofset angle at the endpoint+ n ->+ MetafontSegment (Dir n) (BasicJoin n) n+setDirs (MFS z0 (PJ w0' jj w1') z1) t p = MFS z0 (PJ w0 jj w1) z1+ where+ offs = direction $ z1 .-. z0+ w0 = case w0' of+ (Just (PathDirDir d)) -> d+ _ -> offs # rotate (t @@ turn)+ w1 = case w1' of+ (Just (PathDirDir d)) -> d+ _ -> offs # rotate (negate p @@ 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 (l,r) = normalizeTurns t where+psi (l, r) = normalizeTurns t+ where t = view turn $ signedAngleBetween (mfSegmentOffset r) (mfSegmentOffset 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 ss | length ss > 1 = solveTriDiagonal lower diag upper products where- (lower, diag, upper, products) = lineEqs ss+-- NonEmpty -> NonEmpty ?+lineDirs (s1 : s2 : ss) = NE.toList $ solveTriDiagonal (NS.toNonEmpty lower) (NS.toNonEmpty diag) (NS.toNonEmpty upper) (NS.toNonEmpty products)+ where+ (lower, diag, upper, products) = lineEqs (s1 :|| (s2 :| ss)) lineDirs [] = []-lineDirs [s] | leftCurl s && rightCurl s = [0, 0] where-lineDirs [s] | rightCurl s = solveTriDiagonal [a] [1,c] [0] [normalizeTurns t, r] where- (a,c,r) = solveOneSeg s- (PathDirDir d) = s^.pj.d1.to fromJust- t = view turn $ angleBetweenDirs d (direction $ s^.x2 .-. s^.x1)+lineDirs [s] | leftCurl s && rightCurl s = [0, 0]+lineDirs [s] | rightCurl s = NE.toList $ solveTriDiagonal (a :| []) (1 :| [c]) (0 :| []) (normalizeTurns t :| [r])+ where+ (a, c, r) = solveOneSeg s+ (PathDirDir d) = s ^. pj . d1 . to fromJust+ t = view turn $ angleBetweenDirs d (direction $ s ^. x2 .-. s ^. x1) lineDirs [s] | leftCurl s = reverse $ lineDirs [reverseSeg s]-lineDirs _ = error $ "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."+lineDirs _ =+ error+ "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." +consNS :: a -> NonSingleton a -> NonSingleton a+consNS x (y :|| ys) = x :|| NE.cons y ys++initNS :: NonSingleton a -> NonEmpty a+initNS (x :|| xs) = x :| NE.init xs++snocNE :: [a] -> a -> NonEmpty a+snocNE [] a = a :| []+snocNE (x : xs) a = x :| (xs ++ [a])++snocNS :: NonEmpty a -> a -> NonSingleton a+snocNS (x :| xs) y = x :|| snocNE xs y++headNS :: NonSingleton a -> a+headNS (a :|| _) = a++sndNS :: NonSingleton a -> a+sndNS (_ :|| (a :| _)) = a++lastNS :: NonSingleton a -> a+lastNS (_ :|| as) = NE.last as++rotateNS :: NonSingleton a -> NonSingleton a+rotateNS s = snocNS (NS.tail s) (headNS s)++rotateNE :: NonEmpty a -> NonEmpty a+rotateNE s = snocNE (NE.tail s) (NE.head s)+ -- | 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 ss = (lower, diag, upper, products) where- segmentPairs = zip (init ss) (tail ss)- lower = map aCo (init ss) ++ [an]- diag = c0 : zipWith (+) (map bCo (init ss)) (map cCo (tail ss)) ++ [cn]- upper = (d0 : map dCo (tail ss))- products = r0 : zipWith (-)- [-1 * bCo l * psi s | s@(l,_) <- segmentPairs]- (zipWith (*)- (map dCo (tail $ ss))- (map psi (tail segmentPairs)- ++ [0])) ++ [rn]- (d0,c0,_) = solveOneSeg . reverseSeg $ s0- r0 = r0' (s0^.pj.d1.to fromJust) where- r0' (PathDirDir d) = normalizeTurns t where- t = view turn $ angleBetweenDirs d (direction $ s0^.x2 .-. s0^.x1)- r0' (PathDirCurl _) = negate $ d0 * psi (s0, ss!!1)- s0 = head ss- (an, cn, rn) = solveOneSeg (last ss)+lineEqs :: RealFloat n => NonSingleton (MFS n) -> (NonSingleton n, NonSingleton n, NonSingleton n, NonSingleton n)+lineEqs ss = (lower, diag, upper, products)+ where+ segmentPairs = NE.zip (initNS ss) (NS.tail ss)+ lower = snocNS (fmap aCo (initNS ss)) an+ diag = c0 :|| snocNE (NE.toList $ NE.zipWith (+) (fmap bCo (initNS ss)) (fmap cCo (NS.tail ss))) cn+ upper = d0 :|| fmap dCo (NS.tail ss)+ products =+ r0+ :|| snocNE+ ( NE.toList+ ( NE.zipWith+ (-)+ (fmap (\s@(l, _) -> -(bCo l * psi s)) segmentPairs)+ ( NE.zipWith+ (*)+ (fmap dCo (NS.tail ss))+ (snocNE (fmap psi (NE.tail segmentPairs)) 0)+ )+ )+ )+ rn+ (d0, c0, _) = solveOneSeg . reverseSeg $ s0+ r0 = r0' (s0 ^. pj . d1 . to fromJust)+ where+ r0' (PathDirDir d) = normalizeTurns t+ where+ t = view turn $ angleBetweenDirs d (direction $ s0 ^. x2 .-. s0 ^. x1)+ r0' (PathDirCurl _) = negate $ d0 * psi (s0, sndNS ss)+ s0 = headNS ss+ (an, cn, rn) = solveOneSeg (lastNS 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 s = 1 / s^.pj.j.to fromLeft.t1.to getTension-beta s = 1 / s^.pj.j.to fromLeft.t2.to getTension-aCo s = (alpha s) / (beta s **2 * mfSegmentLength s)-bCo s = (3 - alpha s) / (beta s **2 * mfSegmentLength s)-cCo s = (3 - beta s) / (alpha s **2 * mfSegmentLength s)-dCo s = (beta s) / (alpha s **2 * mfSegmentLength s)+alpha s = 1 / s ^. pj . j . to fromLeft . t1 . to getTension+beta s = 1 / s ^. pj . j . to fromLeft . t2 . to getTension+aCo s = alpha s / (beta s ** 2 * mfSegmentLength s)+bCo s = (3 - alpha s) / (beta s ** 2 * mfSegmentLength s)+cCo s = (3 - beta s) / (alpha s ** 2 * mfSegmentLength s)+dCo s = (beta s) / (alpha s ** 2 * mfSegmentLength 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 s = (a, c, r) where- a = a' (s^.pj.d2.to fromJust) where+solveOneSeg s = (a, c, r)+ where+ a = a' (s ^. pj . d2 . to fromJust)+ where a' (PathDirDir _) = 0- a' (PathDirCurl g) = (3 - beta s) * (beta s) **2 * g / (alpha s **2) + alpha s- c = c' (s^.pj.d2.to fromJust) where- c' (PathDirDir _) = 1- c' (PathDirCurl g) = beta s **3 * g / (alpha s **2) + 3 - alpha s- r = r' (s^.pj.d2.to fromJust) where- r' (PathDirDir d) = normalizeTurns t where- t = view turn $ angleBetween (fromDirection d) (s^.x2 .-. s^.x1)+ a' (PathDirCurl g) = (3 - beta s) * (beta s) ** 2 * g / (alpha s ** 2) + alpha s+ c = c' (s ^. pj . d2 . to fromJust)+ where+ c' (PathDirDir _) = 1+ c' (PathDirCurl g) = beta s ** 3 * g / (alpha s ** 2) + 3 - alpha s+ r = r' (s ^. pj . d2 . to fromJust)+ where+ r' (PathDirDir d) = normalizeTurns t+ where+ t = view turn $ angleBetween (fromDirection d) (s ^. x2 .-. s ^. x1) r' (PathDirCurl _) = 0 -- | Take a segment whose endpoint directions have been fully@@ -333,35 +412,41 @@ -- 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 (MFS z0 (PJ _ (Right cj) _) z1)- = MFS z0 (PJ () cj ()) z1-computeControls (MFS z0 (PJ w0 (Left (TJ a b)) w1) z1)- = MFS z0 (PJ () (CJ u v) ()) z1- where- w0' = fromDirection w0- w1' = fromDirection w1- (u,v) = ctrlPts z0 w0' va vb w1' z1- offs = z1 .-. z0- theta = signedAngleBetween w0' offs- phi = signedAngleBetween offs w1'- sinR = sin . view rad- boundingTriangleExists = signum (sinR theta) == signum (sinR phi)- && signum (sinR theta) == signum (sinR (theta^+^phi))- va = case a of- (TensionAmt ta) -> hobbyF theta phi / ta- (TensionAtLeast ta) -> case boundingTriangleExists of- True -> min (sinR phi / sinR (theta ^+^ phi))- (hobbyF theta phi / ta)- False -> hobbyF theta phi / ta- vb = case b of- (TensionAmt tb) -> hobbyF phi theta / tb- (TensionAtLeast tb) -> case boundingTriangleExists of- True -> min (sinR theta / sinR (theta ^+^ phi))- (hobbyF phi theta / tb)- False -> hobbyF phi theta / tb+computeControls ::+ RealFloat n =>+ MetafontSegment (Dir n) (BasicJoin n) n ->+ MetafontSegment () (ControlJoin n) n+computeControls (MFS z0 (PJ _ (Right cj) _) z1) =+ MFS z0 (PJ () cj ()) z1+computeControls (MFS z0 (PJ w0 (Left (TJ a b)) w1) z1) =+ MFS z0 (PJ () (CJ u v) ()) z1+ where+ w0' = fromDirection w0+ w1' = fromDirection w1+ (u, v) = ctrlPts z0 w0' va vb w1' z1+ offs = z1 .-. z0+ theta = signedAngleBetween w0' offs+ phi = signedAngleBetween offs w1'+ sinR = sin . view rad+ boundingTriangleExists =+ signum (sinR theta) == signum (sinR phi)+ && signum (sinR theta) == signum (sinR (theta ^+^ phi))+ va = case a of+ (TensionAmt ta) -> hobbyF theta phi / ta+ (TensionAtLeast ta) -> case boundingTriangleExists of+ True ->+ min+ (sinR phi / sinR (theta ^+^ phi))+ (hobbyF theta phi / ta)+ False -> hobbyF theta phi / ta+ vb = case b of+ (TensionAmt tb) -> hobbyF phi theta / tb+ (TensionAtLeast tb) -> case boundingTriangleExists of+ True ->+ min+ (sinR theta / sinR (theta ^+^ phi))+ (hobbyF phi theta / tb)+ False -> hobbyF phi theta / tb -- | Compute the control points for a cubic bezier, given a segment -- where we know the directions and tensions at both endpoints,@@ -375,25 +460,23 @@ -- -- 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 z0 w0 va vb w1 z1 = (u,v)- where- offs = z1 .-. z0- theta = signedAngleBetween w0 offs- phi = signedAngleBetween offs w1- u = z0 .+^ (offs # rotate theta # scale va)- v = z1 .-^ (offs # rotate (negated phi) # scale vb)+ctrlPts z0 w0 va vb w1 z1 = (u, v)+ where+ offs = z1 .-. z0+ theta = signedAngleBetween w0 offs+ phi = signedAngleBetween offs w1+ u = z0 .+^ (offs # rotate theta # scale va)+ v = z1 .-^ (offs # rotate (negated phi) # scale 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 theta' phi' = let- theta = theta' ^. rad- phi = phi' ^. rad- in- (2 + sqrt 2 * (sin theta - sin phi / 16)*(sin phi - sin theta / 16)*(cos theta - cos phi))- /- (3 * (1 + (sqrt 5 - 1)/2 * cos theta + (3 - sqrt 5)/2 * cos phi))+hobbyF theta' phi' =+ let theta = theta' ^. rad+ phi = phi' ^. rad+ in (2 + sqrt 2 * (sin theta - sin phi / 16) * (sin phi - sin theta / 16) * (cos theta - cos phi))+ / (3 * (1 + (sqrt 5 - 1) / 2 * cos theta + (3 - sqrt 5) / 2 * cos phi)) -- | Convert a fully specified MetafontSegment to a Diagrams Segment importSegment :: Num n => MetafontSegment () (ControlJoin n) n -> Segment Closed V2 n@@ -401,24 +484,26 @@ -- | 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 (MFP False ss) = (wrapLine . fromSegments . map importSegment $ ss)- `at` (head ss ^.x1)-locatedTrail (MFP True ss) = (wrapLoop . fromSegments . map importSegment $ ss)- `at` (head ss ^.x1)+locatedTrail (MFP False ss) =+ (wrapLine . fromSegments . map importSegment $ ss)+ `at` (head ss ^. x1)+locatedTrail (MFP True ss) =+ (wrapLoop . fromSegments . map importSegment $ ss)+ `at` (head ss ^. 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 = fixCycleSegment . snd . mfPathToSegments'- where- mfPathToSegments' :: MFPathData P n -> (P2 n, MFP n)- mfPathToSegments' (MFPathEnd p0) = (p0, MFP False [])- mfPathToSegments' MFPathCycle = (origin, MFP True [])- mfPathToSegments' (MFPathPt p0 (MFPathJoin jj path)) = (p0, MFP c (MFS p0 jj' p1 : ss))- where- (p1, MFP c ss) = mfPathToSegments' path- jj' = case jj^.j of- Nothing -> jj & j .~ Left (TJ (TensionAmt 1) (TensionAmt 1))- Just bj -> jj & j .~ bj- fixCycleSegment (MFP True ss) = MFP True (ss & _last.x2 .~ ss^?!_head.x1)- fixCycleSegment p = p+ where+ mfPathToSegments' :: MFPathData P n -> (P2 n, MFP n)+ mfPathToSegments' (MFPathEnd p0) = (p0, MFP False [])+ mfPathToSegments' MFPathCycle = (origin, MFP True [])+ mfPathToSegments' (MFPathPt p0 (MFPathJoin jj path)) = (p0, MFP c (MFS p0 jj' p1 : ss))+ where+ (p1, MFP c ss) = mfPathToSegments' path+ jj' = case jj ^. j of+ Nothing -> jj & j .~ Left (TJ (TensionAmt 1) (TensionAmt 1))+ Just bj -> jj & j .~ bj+ fixCycleSegment (MFP True ss) = MFP True (ss & _last . x2 .~ ss ^?! _head . x1)+ fixCycleSegment p = p
src/Diagrams/TwoD/Path/Metafont/Types.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-} module Diagrams.TwoD.Path.Metafont.Types where -import Control.Lens hiding (( # ))+import Control.Lens hiding ((#)) import Diagrams.Direction import Diagrams.TwoD.Types -- | A @PathJoin@ specifies the directions at both ends of a segment, -- and a join which describes the control points explicitly or implicitly.-data PathJoin d j = PJ { _d1 :: d, _j :: j, _d2 :: d }+data PathJoin d j = PJ {_d1 :: d, _j :: j, _d2 :: d} deriving (Functor, Show) makeLenses ''PathJoin@@ -23,8 +23,8 @@ -- to curl 1 if not set. data PathDir n = PathDirCurl n- | PathDirDir (Dir n)- deriving Show+ | PathDirDir (Dir n)+ deriving (Show) -- | A predicate to determine the constructor used. isCurl :: PathDir n -> Bool@@ -44,20 +44,20 @@ data Tension n = TensionAmt n | TensionAtLeast n- deriving Show+ deriving (Show) getTension :: Tension n -> n-getTension (TensionAmt t) = t+getTension (TensionAmt t) = t getTension (TensionAtLeast t) = t -- | Two tensions and two directions completely determine the control -- points of a segment.-data TensionJoin n = TJ { _t1 :: Tension n, _t2 :: Tension n }- deriving Show+data TensionJoin n = TJ {_t1 :: Tension n, _t2 :: Tension n}+ deriving (Show) -- | The two intermediate control points of a segment, specified directly.-data ControlJoin n = CJ { _c1 :: P2 n, _c2 :: P2 n}- deriving Show+data ControlJoin n = CJ {_c1 :: P2 n, _c2 :: P2 n}+ deriving (Show) makeLenses ''TensionJoin makeLenses ''ControlJoin@@ -67,16 +67,16 @@ -- | @MFPathData@ is the type manipulated by the metafont combinators. data MFPathData a n where- MFPathCycle:: MFPathData P n- MFPathEnd :: P2 n -> MFPathData P n- MFPathPt :: P2 n -> MFPathData J n -> MFPathData P n+ MFPathCycle :: MFPathData P n+ MFPathEnd :: P2 n -> MFPathData P n+ MFPathPt :: P2 n -> MFPathData J n -> MFPathData P n MFPathJoin :: PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n)) -> MFPathData P n -> MFPathData J n -- | @MetafontSegment@ is used internally in solving the metafont -- equations. It represents a segment with two known endpoints, and a -- /join/, which may be specified in various ways.-data MetafontSegment d j n = MFS { _x1 :: P2 n, _pj :: (PathJoin d j ), _x2 :: P2 n }- deriving (Functor, Show)+data MetafontSegment d j n = MFS {_x1 :: P2 n, _pj :: PathJoin d j, _x2 :: P2 n}+ deriving (Functor, Show) -- | @MFPath@ is the type used internally in solving the metafont -- equations. The direction and join types are progressively refined@@ -85,8 +85,8 @@ -- If constructing an @MFPath@ in new code, the responsibility rests -- on the user to ensure that successive @MetafontSegment@s share an -- endpoint. If this is not true, the result is undefined.-data MFPath d j n = MFP { _loop :: Bool, _segs :: [MetafontSegment d j n] }- deriving Show+data MFPath d j n = MFP {_loop :: Bool, _segs :: [MetafontSegment d j n]} -- XXX NonSingleton (MetafontSegment d j n) ?+ deriving (Show) -- | MFP is a type synonym to clarify signatures in Metafont.Internal. -- Note that the type permits segments which are \"overspecified\",@@ -101,12 +101,12 @@ makeLenses ''MFPath instance Monoid (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where- -- | The default join, with no directions specified, and both tensions 1.- mempty = PJ Nothing Nothing Nothing+ -- \| The default join, with no directions specified, and both tensions 1.+ mempty = PJ Nothing Nothing Nothing instance Semigroup (PathJoin (Maybe (PathDir n)) (Maybe (BasicJoin n))) where- l <> r = PJ (c (l^.d1) (r^.d1)) (c (l^.j) (r^.j)) (c (l^.d2) (r^.d2))- where- c a b = case b of- Nothing -> a- Just _ -> b+ l <> r = PJ (c (l ^. d1) (r ^. d1)) (c (l ^. j) (r ^. j)) (c (l ^. d2) (r ^. d2))+ where+ c a b = case b of+ Nothing -> a+ Just _ -> b