module Chart.Arrow (
Arrow(..)
, ArrowOptions(..)
, normArrows
, arrows
, arrowChart
, arrowChart_
) where
import Chart.Core
import NumHask.Prelude hiding (max,(&))
import NumHask.Space
import NumHask.Range
import NumHask.Rect
import NumHask.Pair
import Data.Ord (max)
import Diagrams.Prelude hiding (width, D, Color, project)
data ArrowOptions a = ArrowOptions
{ arrowMinLength :: a
, arrowMaxLength :: a
, arrowMinHeadLength :: a
, arrowMaxHeadLength :: a
, arrowMinStaffWidth :: a
, arrowMaxStaffWidth :: a
, arrowColor :: AlphaColour Double
, arrowHeadStyle :: ArrowHT a
}
instance Default (ArrowOptions Double) where
def = ArrowOptions 0.02 0.2 0.01 0.1 0.002 0.005 ublue dart
normArrows :: [Arrow] -> [Arrow]
normArrows xs =
zipWith Arrow ps as'
where
ps = arrowPos <$> xs
as = arrowDir <$> xs
as' = (\x ->
x *
width (space $ arrowPos <$> xs :: Rect Double) /
width (space $ arrowDir <$> xs :: Rect Double)) <$>
as
data Arrow = Arrow
{ arrowPos :: Pair Double
, arrowDir :: Pair Double
} deriving (Eq, Show)
arrows :: (Traversable f) => ArrowOptions Double -> f Arrow -> Chart b
arrows opts xs = c
where
c = fcA (arrowColor opts) $ position $ getZipList $
(\ps' as' hrel' wrel' srel' ->
(ps',
arrowAt' (arropts hrel' wrel') (p2 (0, 0))
((srel'/norm as') *^ as'))) <$> ZipList
(toList $ p_ <$> ps) <*> ZipList
(toList $ r_ <$> as) <*> ZipList
(toList hrel) <*> ZipList
(toList wrel) <*> ZipList
srel
ps = arrowPos <$> xs
as = arrowDir <$> xs
(Pair dx dy) = width (space ps :: Rect Double)
anorm = (\(Pair x y) -> sqrt((x/dx)**2+(y/dy)**2)) <$> as
(Range _ anormMax) = space anorm
arel = (\x -> max (anormMax * arrowMinLength opts)
(x / anormMax * arrowMaxLength opts)) <$> anorm
hrel = (\x -> max (arrowMinHeadLength opts) (arrowMaxHeadLength opts * x)) <$>
arel
wrel = (\x -> max (arrowMinStaffWidth opts) (arrowMaxStaffWidth opts * x)) <$>
arel
srel = zipWith (\la lh -> max 1e-12 (la lh)) (toList arel) (toList hrel)
arropts lh lw'' = with & arrowHead .~ arrowHeadStyle opts &
headLength .~ global lh &
shaftStyle %~ (lwG lw'' & lcA (arrowColor opts)) &
headStyle %~ (lcA (arrowColor opts) & fcA (arrowColor opts))
arrowChart ::
(Traversable f) =>
[ArrowOptions Double] ->
Aspect ->
Rect Double ->
[f Arrow] ->
Chart b
arrowChart optss (Aspect asp) r xss =
mconcat $ zipWith (\opts xs -> arrows opts $
(\(Arrow d arr) ->
Arrow (project r asp d) (project r asp arr)) <$> xs) optss xss
arrowChart_ ::
(Traversable f) =>
[ArrowOptions Double] ->
Aspect ->
[f Arrow] ->
Chart b
arrowChart_ optss asp xss =
arrowChart optss asp r xss
where
r = fold (space . map arrowPos <$> xss)