module Diagrams.TwoD.Grid (
gridWithHalves
, gridWithHalves'
, annotate
, gridLine
, gridLines
, placeDiagramOnGrid
) where
import Diagrams.Prelude
import Diagrams.TwoD.Text
import Control.Lens (makeLenses, (^.))
import Data.Default.Class
import Data.List
import Data.List.Split
data GridOpts
= GridOpts
{ _gridLineWidth :: Measure R2
, _gridYColour :: Colour Double
, _gridXColour :: Colour Double
, _gridLL :: R2
, _gridLR :: R2
, _gridUL :: R2
}
instance Default GridOpts where
def = GridOpts
{ _gridLineWidth = thin
, _gridXColour = red
, _gridYColour = blue
, _gridLL = r2 (1.0, 1.0)
, _gridLR = r2 (2.0, 1.0)
, _gridUL = r2 (1.0, 2.0)
}
data HighlightLineOpts
= HighlightLineOpts
{ _highLightLineColour :: Colour Double
, _highLightLineWidth :: Measure R2
, _highLightLineDashingOnOff :: [Measure R2]
, _highLightLineDashingOffset :: Measure R2
}
instance Default HighlightLineOpts where
def = HighlightLineOpts
{ _highLightLineColour = black
, _highLightLineWidth = medium
, _highLightLineDashingOnOff = [Normalized 0.03, Normalized 0.03]
, _highLightLineDashingOffset = Output 0
}
makeLenses ''GridOpts
makeLenses ''HighlightLineOpts
tick :: (Renderable Text b, Renderable (Path R2) b) =>
(Int, Int) -> Diagram b R2
tick (n, m) = pointDiagram origin # named (n, m)
gridWithHalves :: (Renderable Text b, Renderable (Path R2) b, Backend b R2) =>
Int -> Int -> Diagram b R2
gridWithHalves = gridWithHalves' def
gridWithHalves' :: (Renderable Text b, Renderable (Path R2) b, Backend b R2) =>
GridOpts -> Int -> Int -> Diagram b R2
gridWithHalves' opts n m =
(mconcat lineXs # translate (r2 (llx, lly))) <>
(mconcat lineYs # translate (r2 (llx, lly))) <>
(intersections # translate (r2 (llx delta2X, luy + delta2Y)))
where
llx :& lly = coords (opts^.gridLL)
lrx :& _ = coords (opts^.gridLR)
_ :& luy = coords (opts^.gridUL)
deltaX = (lrx llx) / fromIntegral n
deltaY = (luy lly) / fromIntegral m
delta2X = (lrx llx) / fromIntegral (2 * n)
delta2Y = (luy lly) / fromIntegral (2 * m)
ns = [0..n]
ms = [0..m]
n2s = [0..2 * n + 2]
m2s = [0..2 * m + 2]
xs = map ((* deltaX) . fromIntegral) ns
ys = map ((* deltaY) . fromIntegral) ms
lineXs = Prelude.map lineX ys
lineYs = Prelude.map lineY xs
lineX y = fromOffsets [(opts^.gridLR) ^-^ (opts^.gridLL)] #
translate (r2 (0.0, y)) #
lc (opts^.gridXColour) #
lw (opts^.gridLineWidth)
lineY x = fromOffsets [(opts^.gridUL) ^-^ (opts^.gridLL)] #
translate (r2 (x, 0.0)) #
lc (opts^.gridYColour) #
lw (opts^.gridLineWidth)
intersections = hcat $
intersperse (strutX delta2X) $
map vcat $
map (intersperse (strutY delta2Y)) $
chunksOf (2 * m + 1 + 2) [ tick (n, m) | n <- n2s, m <- m2s ]
placeDiagramOnGrid :: (IsName n, Renderable Text b, Renderable (Path R2) b) =>
Diagram b R2 -> [n] -> Diagram b R2 -> Diagram b R2
placeDiagramOnGrid d = flip $ foldr (\n -> withName n (atop . place d . location))
annotate :: (Renderable Text b, Renderable (Path R2) b) =>
String ->
(String -> Diagram b R2) ->
Colour Double ->
Int ->
Int ->
Diagram b R2 ->
Diagram b R2
annotate s txtPt h n m =
withName (n, m) (atop . place (addText s h) . location)
where
addText s h = txtPt s # fc h
gridLine :: (IsName a, IsName b, Renderable Text c, Renderable (Path R2) c) =>
a -> b -> Diagram c R2 -> Diagram c R2
gridLine = gridLine' def
gridLine' :: (IsName a, IsName b, Renderable Text c, Renderable (Path R2) c) =>
HighlightLineOpts -> a -> b -> Diagram c R2 -> Diagram c R2
gridLine' opts u v =
withName u $ \x ->
withName v $ \y ->
atop ((location x ~~ location y) #
lc (opts^.highLightLineColour) #
lw (opts^.highLightLineWidth) #
dashing (opts^.highLightLineDashingOnOff) (opts^.highLightLineDashingOffset))
gridLines :: (Renderable Text c, Renderable (Path R2) c, IsName a, IsName b) =>
[(a, b)] -> Diagram c R2 -> Diagram c R2
gridLines xs = foldr (.) id [ gridLine x y | (x, y) <- xs ]