{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
module Diagrams.TwoD.Grid (
gridWithHalves
, gridWithHalves'
, annotate
, gridLine
, gridLine'
, gridLines
, placeDiagramOnGrid
, GridOpts(..)
, gridLineWidth, gridYColour, gridXColour, gridLL, gridLR, gridUL
, HighlightLineOpts(..)
, highLightLineColour, highLightLineWidth
, highLightLineDashingOnOff, highLightLineDashingOffset
) where
import Diagrams.Prelude
import Data.List
import Data.List.Split
import Data.Typeable
data GridOpts n
= GridOpts
{ forall n. GridOpts n -> Measure n
_gridLineWidth :: Measure n
, forall n. GridOpts n -> Colour Double
_gridYColour :: Colour Double
, forall n. GridOpts n -> Colour Double
_gridXColour :: Colour Double
, forall n. GridOpts n -> V2 n
_gridLL :: V2 n
, forall n. GridOpts n -> V2 n
_gridLR :: V2 n
, forall n. GridOpts n -> V2 n
_gridUL :: V2 n
}
instance (Floating n, Ord n) => Default (GridOpts n) where
def :: GridOpts n
def = GridOpts
{ _gridLineWidth :: Measure n
_gridLineWidth = forall n. OrderedField n => Measure n
thin
, _gridXColour :: Colour Double
_gridXColour = forall a. (Ord a, Floating a) => Colour a
red
, _gridYColour :: Colour Double
_gridYColour = forall a. (Ord a, Floating a) => Colour a
blue
, _gridLL :: V2 n
_gridLL = forall n. (n, n) -> V2 n
r2 (n
1.0, n
1.0)
, _gridLR :: V2 n
_gridLR = forall n. (n, n) -> V2 n
r2 (n
2.0, n
1.0)
, _gridUL :: V2 n
_gridUL = forall n. (n, n) -> V2 n
r2 (n
1.0, n
2.0)
}
data HighlightLineOpts n
= HighlightLineOpts
{ forall n. HighlightLineOpts n -> Colour Double
_highLightLineColour :: Colour Double
, forall n. HighlightLineOpts n -> Measure n
_highLightLineWidth :: Measure n
, forall n. HighlightLineOpts n -> [Measure n]
_highLightLineDashingOnOff :: [Measure n]
, forall n. HighlightLineOpts n -> Measure n
_highLightLineDashingOffset :: Measure n
}
instance (Floating n, Ord n) => Default (HighlightLineOpts n) where
def :: HighlightLineOpts n
def = HighlightLineOpts
{ _highLightLineColour :: Colour Double
_highLightLineColour = forall a. Num a => Colour a
black
, _highLightLineWidth :: Measure n
_highLightLineWidth = forall n. OrderedField n => Measure n
medium
, _highLightLineDashingOnOff :: [Measure n]
_highLightLineDashingOnOff = [forall n. Num n => n -> Measure n
normalized n
0.03, forall n. Num n => n -> Measure n
normalized n
0.03]
, _highLightLineDashingOffset :: Measure n
_highLightLineDashingOffset = forall n. n -> Measure n
output n
0
}
makeLenses ''GridOpts
makeLenses ''HighlightLineOpts
tick :: (Floating n, Ord n)
=> (Int, Int) -> QDiagram b V2 n Any
tick :: forall n b.
(Floating n, Ord n) =>
(Int, Int) -> QDiagram b V2 n Any
tick (Int
n, Int
m) = forall (v :: * -> *) n b m.
(Metric v, Fractional n) =>
Point v n -> QDiagram b v n m
pointDiagram forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin forall a b. a -> (a -> b) -> b
# forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named (Int
n, Int
m)
gridWithHalves :: (Renderable (Path V2 n) b, TypeableFloat n)
=> Int -> Int -> QDiagram b V2 n Any
gridWithHalves :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Int -> Int -> QDiagram b V2 n Any
gridWithHalves = forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
GridOpts n -> Int -> Int -> QDiagram b V2 n Any
gridWithHalves' forall a. Default a => a
def
gridWithHalves' :: (Renderable (Path V2 n) b, TypeableFloat n)
=> GridOpts n -> Int -> Int -> QDiagram b V2 n Any
gridWithHalves' :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
GridOpts n -> Int -> Int -> QDiagram b V2 n Any
gridWithHalves' GridOpts n
opts Int
n Int
m =
(forall a. Monoid a => [a] -> a
mconcat [QDiagram b V2 n Any]
lineXs forall a b. a -> (a -> b) -> b
# forall t. Transformable t => Vn t -> t -> t
translate (forall n. (n, n) -> V2 n
r2 (n
llx, n
lly))) forall a. Semigroup a => a -> a -> a
<>
(forall a. Monoid a => [a] -> a
mconcat [QDiagram b V2 n Any]
lineYs forall a b. a -> (a -> b) -> b
# forall t. Transformable t => Vn t -> t -> t
translate (forall n. (n, n) -> V2 n
r2 (n
llx, n
lly))) forall a. Semigroup a => a -> a -> a
<>
(forall {b}. QDiagram b V2 n Any
intersections forall a b. a -> (a -> b) -> b
# forall t. Transformable t => Vn t -> t -> t
translate (forall n. (n, n) -> V2 n
r2 (n
llx forall a. Num a => a -> a -> a
- n
delta2X, n
luy forall a. Num a => a -> a -> a
+ n
delta2Y)))
where
n
llx :& n
lly = forall c. Coordinates c => c -> Decomposition c
coords (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridLL)
n
lrx :& n
_ = forall c. Coordinates c => c -> Decomposition c
coords (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridLR)
n
_ :& n
luy = forall c. Coordinates c => c -> Decomposition c
coords (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridUL)
deltaX :: n
deltaX = (n
lrx forall a. Num a => a -> a -> a
- n
llx) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
deltaY :: n
deltaY = (n
luy forall a. Num a => a -> a -> a
- n
lly) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m
delta2X :: n
delta2X = (n
lrx forall a. Num a => a -> a -> a
- n
llx) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
2 forall a. Num a => a -> a -> a
* Int
n)
delta2Y :: n
delta2Y = (n
luy forall a. Num a => a -> a -> a
- n
lly) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
2 forall a. Num a => a -> a -> a
* Int
m)
ns :: [Int]
ns = [Int
0..Int
n]
ms :: [Int]
ms = [Int
0..Int
m]
n2s :: [Int]
n2s = [Int
0..Int
2 forall a. Num a => a -> a -> a
* Int
n forall a. Num a => a -> a -> a
+ Int
2]
m2s :: [Int]
m2s = [Int
0..Int
2 forall a. Num a => a -> a -> a
* Int
m forall a. Num a => a -> a -> a
+ Int
2]
xs :: [n]
xs = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
* n
deltaX) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int]
ns
ys :: [n]
ys = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
* n
deltaY) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int]
ms
lineXs :: [QDiagram b V2 n Any]
lineXs = forall a b. (a -> b) -> [a] -> [b]
Prelude.map N (QDiagram b V2 n Any) -> QDiagram b V2 n Any
lineX [n]
ys
lineYs :: [QDiagram b V2 n Any]
lineYs = forall a b. (a -> b) -> [a] -> [b]
Prelude.map N (QDiagram b V2 n Any) -> QDiagram b V2 n Any
lineY [n]
xs
lineX :: N (QDiagram b V2 n Any) -> QDiagram b V2 n Any
lineX N (QDiagram b V2 n Any)
y = forall t. TrailLike t => [Vn t] -> t
fromOffsets [(GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridLR) forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridLL)] forall a b. a -> (a -> b) -> b
#
forall t. Transformable t => Vn t -> t -> t
translate (forall n. (n, n) -> V2 n
r2 (N (QDiagram b V2 n Any)
0.0, N (QDiagram b V2 n Any)
y)) forall a b. a -> (a -> b) -> b
#
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (Colour Double)
gridXColour) forall a b. a -> (a -> b) -> b
#
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (Measure n)
gridLineWidth)
lineY :: N (QDiagram b V2 n Any) -> QDiagram b V2 n Any
lineY N (QDiagram b V2 n Any)
x = forall t. TrailLike t => [Vn t] -> t
fromOffsets [(GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridUL) forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (V2 n)
gridLL)] forall a b. a -> (a -> b) -> b
#
forall t. Transformable t => Vn t -> t -> t
translate (forall n. (n, n) -> V2 n
r2 (N (QDiagram b V2 n Any)
x, N (QDiagram b V2 n Any)
0.0)) forall a b. a -> (a -> b) -> b
#
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (Colour Double)
gridYColour) forall a b. a -> (a -> b) -> b
#
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw (GridOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GridOpts n) (Measure n)
gridLineWidth)
intersections :: QDiagram b V2 n Any
intersections = forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
Monoid' a) =>
[a] -> a
hcat forall a b. (a -> b) -> a -> b
$
forall a. a -> [a] -> [a]
intersperse (forall (v :: * -> *) n b m.
(Metric v, R1 v, OrderedField n) =>
n -> QDiagram b v n m
strutX n
delta2X) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
Monoid' a) =>
[a] -> a
vcat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
intersperse (forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY n
delta2Y)) forall a b. (a -> b) -> a -> b
$
forall e. Int -> [e] -> [[e]]
chunksOf (Int
2 forall a. Num a => a -> a -> a
* Int
m forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
2) [ forall n b.
(Floating n, Ord n) =>
(Int, Int) -> QDiagram b V2 n Any
tick (Int
n, Int
m) | Int
n <- [Int]
n2s, Int
m <- [Int]
m2s ]
placeDiagramOnGrid :: (IsName nm, Floating n, Ord n) =>
QDiagram b V2 n Any -> [nm] -> QDiagram b V2 n Any -> QDiagram b V2 n Any
placeDiagramOnGrid :: forall nm n b.
(IsName nm, Floating n, Ord n) =>
QDiagram b V2 n Any
-> [nm] -> QDiagram b V2 n Any -> QDiagram b V2 n Any
placeDiagramOnGrid QDiagram b V2 n Any
d = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\nm
n -> forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm
-> (Subdiagram b v n m -> QDiagram b v n m -> QDiagram b v n m)
-> QDiagram b v n m
-> QDiagram b v n m
withName nm
n (forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place QDiagram b V2 n Any
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location))
annotate :: (Floating n, Ord n, Typeable n) =>
String ->
(String -> QDiagram b V2 n Any) ->
Colour Double ->
Int ->
Int ->
QDiagram b V2 n Any ->
QDiagram b V2 n Any
annotate :: forall n b.
(Floating n, Ord n, Typeable n) =>
String
-> (String -> QDiagram b V2 n Any)
-> Colour Double
-> Int
-> Int
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
annotate String
s String -> QDiagram b V2 n Any
txtPt Colour Double
h Int
n Int
m =
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm
-> (Subdiagram b v n m -> QDiagram b v n m -> QDiagram b v n m)
-> QDiagram b v n m
-> QDiagram b v n m
withName (Int
n, Int
m) (forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place (String -> Colour Double -> QDiagram b V2 n Any
addText String
s Colour Double
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location)
where
addText :: String -> Colour Double -> QDiagram b V2 n Any
addText String
s Colour Double
h = String -> QDiagram b V2 n Any
txtPt String
s forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
h
gridLine :: (IsName a, IsName b,
Renderable (Path V2 n) c, TypeableFloat n) =>
a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine :: forall a b n c.
(IsName a, IsName b, Renderable (Path V2 n) c, TypeableFloat n) =>
a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine = forall a b n c.
(IsName a, IsName b, Renderable (Path V2 n) c, TypeableFloat n) =>
HighlightLineOpts n
-> a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine' forall a. Default a => a
def
gridLine' :: (IsName a, IsName b,
Renderable (Path V2 n) c, TypeableFloat n) =>
HighlightLineOpts n -> a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine' :: forall a b n c.
(IsName a, IsName b, Renderable (Path V2 n) c, TypeableFloat n) =>
HighlightLineOpts n
-> a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine' HighlightLineOpts n
opts a
u b
v =
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm
-> (Subdiagram b v n m -> QDiagram b v n m -> QDiagram b v n m)
-> QDiagram b v n m
-> QDiagram b v n m
withName a
u forall a b. (a -> b) -> a -> b
$ \Subdiagram c V2 n Any
x ->
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm
-> (Subdiagram b v n m -> QDiagram b v n m -> QDiagram b v n m)
-> QDiagram b v n m
-> QDiagram b v n m
withName b
v forall a b. (a -> b) -> a -> b
$ \Subdiagram c V2 n Any
y ->
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop ((forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram c V2 n Any
x forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Point v n -> Point v n -> t
~~ forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram c V2 n Any
y) forall a b. a -> (a -> b) -> b
#
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc (HighlightLineOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (HighlightLineOpts n) (Colour Double)
highLightLineColour) forall a b. a -> (a -> b) -> b
#
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw (HighlightLineOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (HighlightLineOpts n) (Measure n)
highLightLineWidth) forall a b. a -> (a -> b) -> b
#
forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
[Measure n] -> Measure n -> a -> a
dashing (HighlightLineOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (HighlightLineOpts n) [Measure n]
highLightLineDashingOnOff) (HighlightLineOpts n
optsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (HighlightLineOpts n) (Measure n)
highLightLineDashingOffset))
gridLines :: (Renderable (Path V2 n) c, TypeableFloat n,
IsName a, IsName b) =>
[(a, b)] -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLines :: forall n c a b.
(Renderable (Path V2 n) c, TypeableFloat n, IsName a, IsName b) =>
[(a, b)] -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLines [(a, b)]
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [ forall a b n c.
(IsName a, IsName b, Renderable (Path V2 n) c, TypeableFloat n) =>
a -> b -> QDiagram c V2 n Any -> QDiagram c V2 n Any
gridLine a
x b
y | (a
x, b
y) <- [(a, b)]
xs ]