module Graphics.Rendering.Chart.Axis.Types(
AxisData(..),
AxisT(..),
AxisStyle(..),
PlotValue(..),
AxisFn,
defaultAxisLineStyle,
defaultAxisStyle,
defaultGridLineStyle,
makeAxis,
makeAxis',
axisToRenderable,
renderAxisGrid,
axisOverhang,
vmap,
invmap,
linMap,
invLinMap,
axisGridAtTicks,
axisGridAtBigTicks,
axisGridAtLabels,
axisGridHide,
axisTicksHide,
axisLabelsHide,
axisLabelsOverride,
axis_viewport,
axis_tropweiv,
axis_ticks,
axis_labels,
axis_grid,
axis_line_style,
axis_label_style,
axis_grid_style,
axis_label_gap,
) where
import qualified Graphics.Rendering.Cairo as C
import Data.Time
import Data.Fixed
import Data.Maybe
import System.Locale (defaultTimeLocale)
import Control.Monad
import Data.List(sort,intersperse)
import Data.Accessor.Template
import Data.Colour (opaque)
import Data.Colour.Names (black, lightgrey)
import Graphics.Rendering.Chart.Types
import Graphics.Rendering.Chart.Renderable
class Ord a => PlotValue a where
toValue :: a -> Double
fromValue:: Double -> a
autoAxis :: AxisFn a
data AxisData x = AxisData {
axis_viewport_ :: Range -> x -> Double,
axis_tropweiv_ :: Range -> Double -> x,
axis_ticks_ :: [(x,Double)],
axis_labels_ :: [[(x, String)]],
axis_grid_ :: [ x ]
}
data AxisStyle = AxisStyle {
axis_line_style_ :: CairoLineStyle,
axis_label_style_ :: CairoFontStyle,
axis_grid_style_ :: CairoLineStyle,
axis_label_gap_ :: Double
}
type AxisFn x = [x] -> AxisData x
data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x)
axisToRenderable :: AxisT x -> Renderable x
axisToRenderable at = Renderable {
minsize = minsizeAxis at,
render = renderAxis at
}
axisGridHide :: AxisData x -> AxisData x
axisGridHide ad = ad{ axis_grid_ = [] }
axisGridAtTicks :: AxisData x -> AxisData x
axisGridAtTicks ad = ad{ axis_grid_ = map fst (axis_ticks_ ad) }
axisGridAtBigTicks :: AxisData x -> AxisData x
axisGridAtBigTicks ad = ad{ axis_grid_ =
map fst $
filter ((> minimum (map (abs.snd) (axis_ticks_ ad))).snd) $
axis_ticks_ ad }
axisGridAtLabels :: AxisData x -> AxisData x
axisGridAtLabels ad = ad{ axis_grid_ = map fst vs }
where
vs = case axis_labels_ ad of
[] -> []
ls -> head ls
axisTicksHide :: AxisData x -> AxisData x
axisTicksHide ad = ad{ axis_ticks_ = [] }
axisLabelsHide :: AxisData x -> AxisData x
axisLabelsHide ad = ad{ axis_labels_ = []}
axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x
axisLabelsOverride o ad = ad{ axis_labels_ = [o] }
minsizeAxis :: AxisT x -> CRender RectSize
minsizeAxis (AxisT at as rev ad) = do
labelSizes <- preserveCState $ do
setFontStyle (axis_label_style_ as)
mapM (mapM textSize) (labelTexts ad)
let ag = axis_label_gap_ as
let tsize = maximum ([0] ++ [ max 0 (l) | (v,l) <- axis_ticks_ ad ])
let hw = maximum0 (map (maximum0.map fst) labelSizes)
let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes)
let vw = ag + tsize + (sum . intersperse ag . map (maximum0.map fst) $ labelSizes)
let vh = maximum0 (map (maximum0.map snd) labelSizes)
let sz = case at of
E_Top -> (hw,hh)
E_Bottom -> (hw,hh)
E_Left -> (vw,vh)
E_Right -> (vw,vh)
return sz
labelTexts :: AxisData a -> [[String]]
labelTexts ad = map (map snd) (axis_labels_ ad)
maximum0 [] = 0
maximum0 vs = maximum vs
axisOverhang :: Ord x => AxisT x -> CRender (Double,Double)
axisOverhang (AxisT at as rev ad) = do
let labels = map snd . sort . concat . axis_labels_ $ ad
labelSizes <- preserveCState $ do
setFontStyle (axis_label_style_ as)
mapM textSize labels
case labelSizes of
[] -> return (0,0)
ls -> let l1 = head ls
l2 = last ls
ohangv = return (snd l1 / 2, snd l2 / 2)
ohangh = return (fst l1 / 2, fst l2 / 2)
in
case at of
E_Top -> ohangh
E_Bottom -> ohangh
E_Left -> ohangv
E_Right -> ohangh
renderAxis :: AxisT x -> RectSize -> CRender (PickFn x)
renderAxis at@(AxisT et as rev ad) sz = do
let ls = axis_line_style_ as
preserveCState $ do
setLineStyle ls{line_cap_=C.LineCapSquare}
strokePath [Point sx sy,Point ex ey]
preserveCState $ do
setLineStyle ls{line_cap_=C.LineCapButt}
mapM_ drawTick (axis_ticks_ ad)
preserveCState $ do
setFontStyle (axis_label_style_ as)
labelSizes <- mapM (mapM textSize) (labelTexts ad)
let sizes = map ((+ag).maximum0.map coord) labelSizes
let offsets = scanl (+) ag sizes
mapM_ drawLabels (zip offsets (axis_labels_ ad))
return pickfn
where
(sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz
drawTick (value,length) =
let t1 = axisPoint value
t2 = t1 `pvadd` (vscale length tp)
in strokePath [t1,t2]
(hta,vta,coord,awayFromAxis) = case et of
E_Top -> (HTA_Centre, VTA_Bottom, snd, \v -> (Vector 0 (v)))
E_Bottom -> (HTA_Centre, VTA_Top, snd, \v -> (Vector 0 v))
E_Left -> (HTA_Right, VTA_Centre, fst, \v -> (Vector (v) 0))
E_Right -> (HTA_Left, VTA_Centre, fst, \v -> (Vector v 0))
avoidOverlaps labels = do
rects <- mapM labelDrawRect labels
return $ map snd . head . filter (noOverlaps . map fst)
$ map (\n -> eachNth n rects) [0 .. length rects]
labelDrawRect (value,s) = do
let pt = axisPoint value `pvadd` (awayFromAxis ag)
r <- textDrawRect hta vta pt s
return (hBufferRect r,(value,s))
drawLabels (offset,labels) = do
labels' <- avoidOverlaps labels
mapM_ drawLabel labels'
where
drawLabel (value,s) = do
drawText hta vta (axisPoint value `pvadd` (awayFromAxis offset)) s
textSize s
ag = axis_label_gap_ as
pickfn = Just . invAxisPoint
hBufferRect :: Rect -> Rect
hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y
where x' = x + w/2
w = x (p_x p)
noOverlaps :: [Rect] -> Bool
noOverlaps [] = True
noOverlaps [_] = True
noOverlaps (x:y:l) | rectsOverlap x y = False
| otherwise = noOverlaps (y:l)
rectsOverlap :: Rect -> Rect -> Bool
rectsOverlap (Rect p1 p2) r = any (withinRect r) ps
where (Point x1 y1) = p1
(Point x2 y2) = p2
p3 = Point x1 y2
p4 = Point x2 y1
ps = [p1,p2,p3,p4]
eachNth n = skipN
where
n' = n 1
skipN [] = []
skipN (x:xs) = x : skipN (drop n' xs)
withinRect :: Rect -> Point -> Bool
withinRect (Rect (Point x1 y1) (Point x2 y2)) (Point x y)
= and [x >= x1 && x <= x2,
y >= y1 && y <= y2]
axisMapping :: AxisT z -> RectSize
-> (Double,Double,Double,Double,Vector,z->Point,Point->z)
axisMapping (AxisT et as rev ad) (x2,y2) = case et of
E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx y2, imapx)
E_Bottom -> (x1,y1,x2,y1, (Vector 0 (1)), mapx y1, imapx)
E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy x2, imapy)
E_Right -> (x1,y2,x1,y1, (Vector (1) 0), mapy x1, imapy)
where
(x1,y1) = (0,0)
xr = reverse (x1,x2)
yr = reverse (y2,y1)
mapx y x = Point (axis_viewport_ ad xr x) y
mapy x y = Point x (axis_viewport_ ad yr y)
imapx (Point x _) = axis_tropweiv_ ad xr x
imapy (Point _ y) = axis_tropweiv_ ad yr y
reverse r@(r0,r1) = if rev then (r1,r0) else r
renderAxisGrid :: RectSize -> AxisT z -> CRender ()
renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do
preserveCState $ do
setLineStyle (axis_grid_style_ as)
mapM_ (drawGridLine re) (axis_grid_ ad)
where
(sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz
drawGridLine E_Top = vline
drawGridLine E_Bottom = vline
drawGridLine E_Left = hline
drawGridLine E_Right = hline
vline v = let v' = p_x (axisPoint v)
in strokePath [Point v' 0,Point v' h]
hline v = let v' = p_y (axisPoint v)
in strokePath [Point 0 v',Point w v']
makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x
makeAxis labelf (labelvs, tickvs, gridvs) = AxisData {
axis_viewport_ = newViewport,
axis_tropweiv_ = newTropweiv,
axis_ticks_ = newTicks,
axis_grid_ = gridvs,
axis_labels_ = [newLabels]
}
where
newViewport = vmap (min',max')
newTropweiv = invmap (min',max')
newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ]
newLabels = [ (v,labelf v) | v <- labelvs ]
min' = minimum labelvs
max' = maximum labelvs
makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> (x -> String)
-> ([x],[x],[x]) -> AxisData x
makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData {
axis_viewport_ = linMap t (minimum labelvs, maximum labelvs),
axis_tropweiv_ = invLinMap f t (minimum labelvs, maximum labelvs),
axis_ticks_ = zip tickvs (repeat 2) ++ zip labelvs (repeat 5),
axis_grid_ = gridvs,
axis_labels_ = [[ (v,labelf v) | v <- labelvs ]]
}
defaultAxisLineStyle :: CairoLineStyle
defaultAxisLineStyle = solidLine 1 $ opaque black
defaultGridLineStyle :: CairoLineStyle
defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey
defaultAxisStyle :: AxisStyle
defaultAxisStyle = AxisStyle {
axis_line_style_ = defaultAxisLineStyle,
axis_label_style_ = defaultFontStyle,
axis_grid_style_ = defaultGridLineStyle,
axis_label_gap_ = 10
}
vmap :: PlotValue x => (x,x) -> Range -> x -> Double
vmap (v1,v2) (v3,v4) v = v3 + (toValue v toValue v1) * (v4v3)
/ (toValue v2 toValue v1)
invmap :: PlotValue x => (x,x) -> Range -> Double -> x
invmap (v3,v4) (d1,d2) d = fromValue (toValue v3 + ( (dd1) * doubleRange
/ (d2d1) ))
where doubleRange = toValue v4 toValue v3
linMap :: (a -> Double) -> (a,a) -> Range -> a -> Double
linMap f (x1,x2) (d1,d2) x =
d1 + (d2 d1) * (f x f x1) / (f x2 f x1)
invLinMap :: (Double -> a) -> (a -> Double) -> (a,a) -> Range -> Double -> a
invLinMap f t (v3,v4) (d1,d2) d =
f (t v3 + ( (dd1) * doubleRange / (d2d1) ))
where
doubleRange = t v4 t v3
$( deriveAccessors ''AxisData )
$( deriveAccessors ''AxisStyle )