module Goal.Core.Plot
(
module Graphics.Rendering.Chart
, module Data.Colour
, module Data.Colour.Names
, module Data.Colour.SRGB.Linear
, module Graphics.Rendering.Chart.Backend.Cairo
, module Graphics.Rendering.Chart.Grid
, module Graphics.Rendering.Chart.Gtk
, module Graphics.Rendering.Chart.State
, module Goal.Core.Plot.Contour
, pixMapPlot
, histogramPlot
, histogramPlot0
, logHistogramPlot
, logHistogramPlot0
, pixMapLayout
, histogramLayout
, logHistogramLayout
, histogramLayoutLR
, rgbaGradient
, renderableToAspectWindow
) where
import Data.List hiding (sum)
import Control.Monad
import Control.Lens.Getter
import Control.Lens.Setter hiding (Identity)
import Data.Default.Class
import Numeric
import Graphics.Rendering.Chart hiding (x0,y0,Point)
import Data.Colour
import Data.Colour.Names
import Data.Colour.SRGB.Linear
import Graphics.Rendering.Chart.Backend.Cairo
import Graphics.Rendering.Chart.State
import Graphics.Rendering.Chart.Grid
import Graphics.Rendering.Chart.Gtk
import Goal.Core.Plot.Contour
import qualified Graphics.UI.Gtk as G
import Graphics.Rendering.Cairo (liftIO)
rgbaGradient :: (Double, Double, Double, Double) -> (Double, Double, Double, Double) -> Int
-> [AlphaColour Double]
rgbaGradient (rmn,gmn,bmn,amn) (rmx,gmx,bmx,amx) n =
zipWith (flip withOpacity) [amn,amn + astp .. amx]
$ zipWith3 rgb [rmn,rmn + rstp .. rmx] [gmn,gmn + gstp .. gmx] [bmn,bmn + bstp .. bmx]
where rstp = (rmx rmn) / fromIntegral n
gstp = (gmx gmn) / fromIntegral n
bstp = (bmx bmn) / fromIntegral n
astp = (amx amn) / fromIntegral n
pixMapPlot :: (Double,Double) -> [[AlphaColour Double]] -> Plot Double Double
pixMapPlot (x0,y0) pss = foldr1 joinPlot
$ concat [ [ boxPlot r c . solidFillStyle $ p | (c,p) <- zip [x0..] ps ] | (r,ps) <- zip [y0..] pss ]
where boxPlot y x stl = toPlot
$ plot_fillbetween_style .~ stl
$ plot_fillbetween_values .~ [(x0.5,(y0.5,y+0.5)),(x+0.5,(y0.5,y+0.5))]
$ def
pixMapLayout :: Int -> Int -> Layout Double Double -> Layout Double Double
pixMapLayout rws0 cls0 lyt =
layout_top_axis_visibility .~ AxisVisibility True True False
$ layout_left_axis_visibility .~ AxisVisibility True True False
$ layout_right_axis_visibility .~ AxisVisibility True True False
$ layout_bottom_axis_visibility .~ AxisVisibility True True False
$ layout_y_axis . laxis_reverse .~ True
$ layout_y_axis . laxis_generate .~
const (makeAxis (const "") ([1.5,rws+0.5],[1.5,rws+0.5],[1.5,rws+0.5]))
$ layout_x_axis . laxis_generate .~
const (makeAxis (const "") ([1.5,cls+0.5],[1.5,cls+0.5],[1.5,cls+0.5]))
$ lyt
where cls = fromIntegral cls0
rws = fromIntegral rws0
histogramPlot0 :: (Num a,BarsPlotValue a) =>Int -> [[Double]] -> PlotBars Double a -> PlotBars Double a
histogramPlot0 n xss plt =
let mx = maximum $ maximum <$> xss
mn = minimum $ minimum <$> xss
in histogramPlot n mn mx xss plt
logHistogramPlot0 :: Int -> [[Double]] -> PlotBars Double Double -> PlotBars Double Double
logHistogramPlot0 n xss =
let mx = maximum $ maximum <$> xss
mn = minimum $ minimum <$> xss
in logHistogramPlot n mn mx xss
histogramPlot
:: (Num a,BarsPlotValue a)
=> Int
-> Double
-> Double
-> [[Double]]
-> PlotBars Double a
-> PlotBars Double a
histogramPlot n mn mx xss plt =
let bns = range mn mx (n+1)
vls = transpose $ toHistogram (tail $ take n bns) . sort <$> xss
stp = (head (tail bns) head bns) / 2
bns' = (+ stp) <$> take n bns
in plot_bars_alignment .~ BarsCentered $ plot_bars_values .~ zip bns' vls $ plt
where toHistogram _ [] = repeat 0
toHistogram [] xs = [genericLength xs]
toHistogram (bn:bns') xs =
let (hds,xs') = span (< bn) xs
in genericLength hds : toHistogram bns' xs'
range _ _ 0 = []
range mn mx 1 = [(mn + mx) / 2]
range mn mx n =
[ x * mx + (1 x) * mn | x <- (/ (fromIntegral n 1)) . fromIntegral <$> [0 .. n1] ]
logHistogramPlot
:: Int
-> Double
-> Double
-> [[Double]]
-> PlotBars Double Double
-> PlotBars Double Double
logHistogramPlot n mn mx xss plt =
let bplt = histogramPlot n mn mx xss plt
vls = modVals <$> bplt ^. plot_bars_values
in plot_bars_values .~ vls $ bplt
where lbs = 10
modVals (x,ys) = (x, logBase lbs . (+1) <$> ys)
histogramLayout :: BarsPlotValue a => PlotBars Double a -> Layout Double a -> Layout Double a
histogramLayout pbrs lyt =
let bns = fst <$> pbrs ^. plot_bars_values
stp = (head (tail bns) head bns) / 2
bns' = (head bns stp) : map (+stp) bns
rng = abs $ maximum bns'
labelFun x
| rng >= 1000 = showEFloat (Just 2) x ""
| rng <= 0.01 = showEFloat (Just 2) x ""
| otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""
in layout_x_axis . laxis_generate .~ const (makeAxis labelFun (bns',[],bns'))
$ layout_plots %~ (plotBars pbrs:)
$ lyt
logHistogramLayout :: PlotBars Double Double -> Layout Double Double -> Layout Double Double
logHistogramLayout pbrs lyt =
let vls = pbrs ^. plot_bars_values
bns = fst <$> vls
stp = (head (tail bns) head bns) / 2
bns' = (head bns stp) : map (+stp) bns
cl = fromIntegral . ceiling . maximum . concat $ snd <$> vls
rng = abs $ maximum bns'
xLabelFun x
| rng >= 1000 = showEFloat (Just 2) x ""
| rng <= 0.01 = showEFloat (Just 2) x ""
| otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""
in layout_plots %~ (plotBars pbrs:)
$ layout_y_axis . laxis_generate .~ const (makeAxis yLabelFun ([0..cl],[],[0..cl]))
$ layout_x_axis . laxis_generate .~ const (makeAxis xLabelFun (bns',[],bns'))
$ lyt
where lbs = 10
yLabelFun 0 = show 0
yLabelFun x = show (round lbs) ++ "e" ++ show (round x) ++ "-1"
histogramLayoutLR :: (BarsPlotValue a,PlotValue b) => PlotBars Double a -> LayoutLR Double a b -> LayoutLR Double a b
histogramLayoutLR pbrs lyt =
let bns = fst <$> pbrs ^. plot_bars_values
stp = (head (tail bns) head bns) / 2
bns' = (head bns stp) : map (+stp) bns
rng = abs $ maximum bns'
labelFun x
| rng >= 1000 = showEFloat (Just 2) x ""
| rng <= 0.01 = showEFloat (Just 2) x ""
| otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""
in layoutlr_x_axis . laxis_generate .~ const (makeAxis labelFun (bns',[],bns'))
$ layoutlr_plots %~ (Left (plotBars pbrs):)
$ lyt
renderableToAspectWindow
:: Bool
-> Int
-> Int
-> Renderable a
-> IO ()
renderableToAspectWindow fs wdth hght rnbl = do
G.initGUI
win <- G.windowNew
afrm <- G.aspectFrameNew 0.5 0.5 . Just $ realToFrac (fromIntegral wdth / fromIntegral hght)
da <- G.drawingAreaNew
G.set afrm [ G.containerChild G.:= da ]
G.set win [ G.containerChild G.:= afrm ]
when fs $ G.windowFullscreen win
G.onDestroy win G.mainQuit
(da `G.on` G.exposeEvent) . liftIO $ do
updateCanvas rnbl da
return True
G.widgetShowAll win
G.mainGUI