{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Diagrams.TwoD.Model
(
showOrigin
, showOrigin'
, OriginOpts(..), oColor, oScale, oMinSize
, showEnvelope
, showEnvelope'
, EnvelopeOpts(..), eColor, eLineWidth, ePoints
, showTrace
, showTrace'
, TraceOpts(..), tColor, tScale, tMinSize, tPoints
, showLabels
) where
import Control.Arrow (second)
import Control.Lens (makeLenses, (^.))
import Data.Colour (Colour)
import Data.Colour.Names
import Data.Default.Class
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.Semigroup
import Diagrams.Attributes
import Diagrams.Combinators (atPoints)
import Diagrams.Core
import Diagrams.Core.Names
import Diagrams.CubicSpline
import Diagrams.Path
import Diagrams.TwoD.Attributes
import Diagrams.TwoD.Ellipse
import Diagrams.TwoD.Path
import Diagrams.TwoD.Text
import Diagrams.TwoD.Transform (rotateBy)
import Diagrams.TwoD.Types
import Diagrams.TwoD.Vector (unitX)
import Diagrams.Util
import Linear.Affine
import Linear.Vector
data OriginOpts n = OriginOpts
{ OriginOpts n -> Colour Double
_oColor :: Colour Double
, OriginOpts n -> n
_oScale :: n
, OriginOpts n -> n
_oMinSize :: n
}
makeLenses ''OriginOpts
instance Fractional n => Default (OriginOpts n) where
def :: OriginOpts n
def = Colour Double -> n -> n -> OriginOpts n
forall n. Colour Double -> n -> n -> OriginOpts n
OriginOpts Colour Double
forall a. (Ord a, Floating a) => Colour a
red (n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/n
50) n
0.001
data EnvelopeOpts n = EnvelopeOpts
{ EnvelopeOpts n -> Colour Double
_eColor :: Colour Double
, EnvelopeOpts n -> Measure n
_eLineWidth :: Measure n
, EnvelopeOpts n -> Int
_ePoints :: Int
}
makeLenses ''EnvelopeOpts
instance OrderedField n => Default (EnvelopeOpts n) where
def :: EnvelopeOpts n
def = Colour Double -> Measure n -> Int -> EnvelopeOpts n
forall n. Colour Double -> Measure n -> Int -> EnvelopeOpts n
EnvelopeOpts Colour Double
forall a. (Ord a, Floating a) => Colour a
red Measure n
forall n. OrderedField n => Measure n
medium Int
32
data TraceOpts n = TraceOpts
{ TraceOpts n -> Colour Double
_tColor :: Colour Double
, TraceOpts n -> n
_tScale :: n
, TraceOpts n -> n
_tMinSize :: n
, TraceOpts n -> Int
_tPoints :: Int
}
makeLenses ''TraceOpts
instance Floating n => Default (TraceOpts n) where
def :: TraceOpts n
def = Colour Double -> n -> n -> Int -> TraceOpts n
forall n. Colour Double -> n -> n -> Int -> TraceOpts n
TraceOpts Colour Double
forall a. (Ord a, Floating a) => Colour a
red (n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/n
100) n
0.001 Int
64
showOrigin :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m)
=> QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin :: QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin = OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m
forall n b m.
(TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) =>
OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin' OriginOpts n
forall a. Default a => a
def
showOrigin' :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m)
=> OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin' :: OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin' OriginOpts n
oo QDiagram b V2 n m
d = QDiagram b V2 n m
o QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
forall a. Semigroup a => a -> a -> a
<> QDiagram b V2 n m
d
where o :: QDiagram b V2 n m
o = Path V2 n -> QDiagram b V2 n Any
forall n b.
(TypeableFloat n, Renderable (Path V2 n) b) =>
Path V2 n -> QDiagram b V2 n Any
strokeP (n -> Path V2 n
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle n
sz)
# fc (oo^.oColor)
# lw none
# fmap (const mempty)
V2 n
w n
h = OriginOpts n
ooOriginOpts n -> Getting n (OriginOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (OriginOpts n) n
forall n. Lens' (OriginOpts n) n
oScale n -> V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ QDiagram b V2 n m -> V2 n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a, HasBasis v) =>
a -> v n
size QDiagram b V2 n m
d
sz :: n
sz = [n] -> n
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [n
w, n
h, OriginOpts n
ooOriginOpts n -> Getting n (OriginOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (OriginOpts n) n
forall n. Lens' (OriginOpts n) n
oMinSize]
showEnvelope' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b)
=> EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showEnvelope' :: EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showEnvelope' EnvelopeOpts n
opts QDiagram b V2 n Any
d = Bool -> [Point V2 n] -> QDiagram b V2 n Any
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) =>
Bool -> [Point v n] -> t
cubicSpline Bool
True [Point V2 n]
pts QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc (EnvelopeOpts n
optsEnvelopeOpts n
-> Getting (Colour Double) (EnvelopeOpts n) (Colour Double)
-> Colour Double
forall s a. s -> Getting a s a -> a
^.Getting (Colour Double) (EnvelopeOpts n) (Colour Double)
forall n. Lens' (EnvelopeOpts n) (Colour Double)
eColor)
# lw w <> d
where
pts :: [Point V2 n]
pts = [Maybe (Point V2 n)] -> [Point V2 n]
forall a. [Maybe a] -> [a]
catMaybes [V2 n -> QDiagram b V2 n Any -> Maybe (Point V2 n)
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Maybe (Point v n)
envelopePMay V2 n
v QDiagram b V2 n Any
d | V2 n
v <- (n -> V2 n) -> [n] -> [V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (n -> V2 n -> V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
n -> t -> t
`rotateBy` V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX) [n
0,n
inc..n
top]]
w :: Measure n
w = EnvelopeOpts n
opts EnvelopeOpts n
-> Getting (Measure n) (EnvelopeOpts n) (Measure n) -> Measure n
forall s a. s -> Getting a s a -> a
^. Getting (Measure n) (EnvelopeOpts n) (Measure n)
forall n n.
Lens (EnvelopeOpts n) (EnvelopeOpts n) (Measure n) (Measure n)
eLineWidth
inc :: n
inc = n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EnvelopeOpts n
optsEnvelopeOpts n -> Getting Int (EnvelopeOpts n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (EnvelopeOpts n) Int
forall n. Lens' (EnvelopeOpts n) Int
ePoints)
top :: n
top = n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
inc
showEnvelope :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b)
=> QDiagram b V2 n Any -> QDiagram b V2 n Any
showEnvelope :: QDiagram b V2 n Any -> QDiagram b V2 n Any
showEnvelope = EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n b.
(Enum n, TypeableFloat n, Renderable (Path V2 n) b) =>
EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showEnvelope' EnvelopeOpts n
forall a. Default a => a
def
showTrace' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b)
=> TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showTrace' :: TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showTrace' TraceOpts n
opts QDiagram b V2 n Any
d = [Point V2 n] -> [QDiagram b V2 n Any] -> QDiagram b V2 n Any
forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[Point v n] -> [a] -> a
atPoints [Point V2 n]
ps (QDiagram b V2 n Any -> [QDiagram b V2 n Any]
forall a. a -> [a]
repeat QDiagram b V2 n Any
pt) QDiagram b V2 n Any -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. Semigroup a => a -> a -> a
<> QDiagram b V2 n Any
d
where
ps :: [Point V2 n]
ps = (([n], V2 n) -> [Point V2 n]) -> [([n], V2 n)] -> [Point V2 n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([n], V2 n) -> [Point V2 n]
forall (f :: * -> *) a.
(Additive f, Num a) =>
([a], f a) -> [Point f a]
p [([n], V2 n)]
ts
ts :: [([n], V2 n)]
ts = [[n]] -> [V2 n] -> [([n], V2 n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[n]]
rs [V2 n]
vs
p :: ([a], f a) -> [Point f a]
p ([a]
r, f a
v) = [Point f a
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Point f a -> Diff (Point f) a -> Point f a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (a
s a -> f a -> f a
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ f a
v) | a
s <- [a]
r]
vs :: [V2 n]
vs = (n -> V2 n) -> [n] -> [V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (n -> V2 n -> V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
n -> t -> t
`rotateBy` V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX) [n
0, n
inc..n
top]
rs :: [[n]]
rs = [SortedList n -> [n]
forall a. SortedList a -> [a]
getSortedList (SortedList n -> [n]) -> SortedList n -> [n]
forall a b. (a -> b) -> a -> b
$ (Trace V2 n -> Point V2 n -> V2 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (Trace V2 n -> Point V2 n -> V2 n -> SortedList n)
-> (QDiagram b V2 n Any -> Trace V2 n)
-> QDiagram b V2 n Any
-> Point V2 n
-> V2 n
-> SortedList n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QDiagram b V2 n Any -> Trace V2 n
forall a. Traced a => a -> Trace (V a) (N a)
getTrace) QDiagram b V2 n Any
d Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin V2 n
v | V2 n
v <- [V2 n]
vs]
pt :: QDiagram b V2 n Any
pt = n -> QDiagram b V2 n Any
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle n
sz QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc (TraceOpts n
optsTraceOpts n
-> Getting (Colour Double) (TraceOpts n) (Colour Double)
-> Colour Double
forall s a. s -> Getting a s a -> a
^.Getting (Colour Double) (TraceOpts n) (Colour Double)
forall n. Lens' (TraceOpts n) (Colour Double)
tColor) QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Measure n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw Measure n
forall n. OrderedField n => Measure n
none
V2 n
w n
h = TraceOpts n
optsTraceOpts n -> Getting n (TraceOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (TraceOpts n) n
forall n. Lens' (TraceOpts n) n
tScale n -> V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ QDiagram b V2 n Any -> V2 n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a, HasBasis v) =>
a -> v n
size QDiagram b V2 n Any
d
sz :: n
sz = [n] -> n
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [n
w, n
h, TraceOpts n
optsTraceOpts n -> Getting n (TraceOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (TraceOpts n) n
forall n. Lens' (TraceOpts n) n
tMinSize]
inc :: n
inc = n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TraceOpts n
optsTraceOpts n -> Getting Int (TraceOpts n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (TraceOpts n) Int
forall n. Lens' (TraceOpts n) Int
tPoints)
top :: n
top = n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
inc
showTrace :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b)
=> QDiagram b V2 n Any -> QDiagram b V2 n Any
showTrace :: QDiagram b V2 n Any -> QDiagram b V2 n Any
showTrace = TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n b.
(Enum n, TypeableFloat n, Renderable (Path V2 n) b) =>
TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
showTrace' TraceOpts n
forall a. Default a => a
def
showLabels :: (TypeableFloat n, Renderable (Text n) b, Semigroup m)
=> QDiagram b V2 n m -> QDiagram b V2 n Any
showLabels :: QDiagram b V2 n m -> QDiagram b V2 n Any
showLabels QDiagram b V2 n m
d =
( [QDiagram b V2 n Any] -> QDiagram b V2 n Any
forall a. Monoid a => [a] -> a
mconcat
([QDiagram b V2 n Any] -> QDiagram b V2 n Any)
-> (Map Name [Subdiagram b V2 n m] -> [QDiagram b V2 n Any])
-> Map Name [Subdiagram b V2 n m]
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Point V2 n) -> QDiagram b V2 n Any)
-> [(Name, Point V2 n)] -> [QDiagram b V2 n Any]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n,Point V2 n
p) -> String -> QDiagram b V2 n Any
forall n b.
(TypeableFloat n, Renderable (Text n) b) =>
String -> QDiagram b V2 n Any
text (Name -> String
simpleName Name
n) QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Vn (QDiagram b V2 n Any)
-> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall t. Transformable t => Vn t -> t -> t
translate (Point V2 n
p Point V2 n -> Point V2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin))
([(Name, Point V2 n)] -> [QDiagram b V2 n Any])
-> (Map Name [Subdiagram b V2 n m] -> [(Name, Point V2 n)])
-> Map Name [Subdiagram b V2 n m]
-> [QDiagram b V2 n Any]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [Point V2 n]) -> [(Name, Point V2 n)])
-> [(Name, [Point V2 n])] -> [(Name, Point V2 n)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Name
n,[Point V2 n]
ps) -> [Name] -> [Point V2 n] -> [(Name, Point V2 n)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Name -> [Name]
forall a. a -> [a]
repeat Name
n) [Point V2 n]
ps)
([(Name, [Point V2 n])] -> [(Name, Point V2 n)])
-> (Map Name [Subdiagram b V2 n m] -> [(Name, [Point V2 n])])
-> Map Name [Subdiagram b V2 n m]
-> [(Name, Point V2 n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Name, [Subdiagram b V2 n m]) -> (Name, [Point V2 n]))
-> [(Name, [Subdiagram b V2 n m])] -> [(Name, [Point V2 n])]
forall a b. (a -> b) -> [a] -> [b]
map (((Name, [Subdiagram b V2 n m]) -> (Name, [Point V2 n]))
-> [(Name, [Subdiagram b V2 n m])] -> [(Name, [Point V2 n])])
-> ((Subdiagram b V2 n m -> Point V2 n)
-> (Name, [Subdiagram b V2 n m]) -> (Name, [Point V2 n]))
-> (Subdiagram b V2 n m -> Point V2 n)
-> [(Name, [Subdiagram b V2 n m])]
-> [(Name, [Point V2 n])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Subdiagram b V2 n m] -> [Point V2 n])
-> (Name, [Subdiagram b V2 n m]) -> (Name, [Point V2 n])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([Subdiagram b V2 n m] -> [Point V2 n])
-> (Name, [Subdiagram b V2 n m]) -> (Name, [Point V2 n]))
-> ((Subdiagram b V2 n m -> Point V2 n)
-> [Subdiagram b V2 n m] -> [Point V2 n])
-> (Subdiagram b V2 n m -> Point V2 n)
-> (Name, [Subdiagram b V2 n m])
-> (Name, [Point V2 n])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Subdiagram b V2 n m -> Point V2 n)
-> [Subdiagram b V2 n m] -> [Point V2 n]
forall a b. (a -> b) -> [a] -> [b]
map) Subdiagram b V2 n m -> Point V2 n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location
([(Name, [Subdiagram b V2 n m])] -> [(Name, [Point V2 n])])
-> (Map Name [Subdiagram b V2 n m]
-> [(Name, [Subdiagram b V2 n m])])
-> Map Name [Subdiagram b V2 n m]
-> [(Name, [Point V2 n])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name [Subdiagram b V2 n m] -> [(Name, [Subdiagram b V2 n m])]
forall k a. Map k a -> [(k, a)]
M.assocs
(Map Name [Subdiagram b V2 n m] -> QDiagram b V2 n Any)
-> Map Name [Subdiagram b V2 n m] -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ Map Name [Subdiagram b V2 n m]
m
) QDiagram b V2 n Any -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. Semigroup a => a -> a -> a
<>
(m -> Any) -> QDiagram b V2 n m -> QDiagram b V2 n Any
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Any -> m -> Any
forall a b. a -> b -> a
const (Bool -> Any
Any Bool
False)) QDiagram b V2 n m
d
where
SubMap Map Name [Subdiagram b V2 n m]
m = QDiagram b V2 n m
dQDiagram b V2 n m
-> Getting (SubMap b V2 n m) (QDiagram b V2 n m) (SubMap b V2 n m)
-> SubMap b V2 n m
forall s a. s -> Getting a s a -> a
^.Getting (SubMap b V2 n m) (QDiagram b V2 n m) (SubMap b V2 n m)
forall (v :: * -> *) m n b.
(Metric v, Semigroup m, OrderedField n) =>
Lens' (QDiagram b v n m) (SubMap b v n m)
subMap
simpleName :: Name -> String
simpleName (Name [AName]
ns) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" .> " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (AName -> String) -> [AName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AName -> String
simpleAName [AName]
ns
simpleAName :: AName -> String
simpleAName (AName a
n) = a -> String
forall a. Show a => a -> String
show a
n