aboutsummaryrefslogtreecommitdiff
path: root/src/client/Chart
diff options
context:
space:
mode:
Diffstat (limited to 'src/client/Chart')
-rw-r--r--src/client/Chart/Api.elm41
-rw-r--r--src/client/Chart/Model.elm73
-rw-r--r--src/client/Chart/View.elm182
3 files changed, 296 insertions, 0 deletions
diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm
new file mode 100644
index 0000000..693f362
--- /dev/null
+++ b/src/client/Chart/Api.elm
@@ -0,0 +1,41 @@
+module Chart.Api exposing
+ ( from
+ , withSize
+ , withTitle
+ , withOrdinate
+ , toHtml
+ )
+
+import Html exposing (Html)
+import Svg exposing (..)
+import Svg.Attributes exposing (..)
+
+import Chart.Model as Chart exposing (Chart, Serie, Vec2, View)
+import Chart.View as Chart
+
+from : List String -> List Serie -> Chart
+from keys series =
+ { keys = keys
+ , series = series
+ , size = { x = 600, y = 400 }
+ , title = ""
+ , scaleColor = "#DDDDDD"
+ , formatOrdinate = toString
+ , ordinateLines = 5
+ }
+
+withSize : Vec2 -> Chart -> Chart
+withSize size chart = { chart | size = size }
+
+withTitle : String -> Chart -> Chart
+withTitle title chart = { chart | title = title }
+
+withOrdinate : Int -> (Float -> String) -> Chart -> Chart
+withOrdinate lines format chart =
+ { chart
+ | formatOrdinate = format
+ , ordinateLines = lines
+ }
+
+toHtml : Chart -> Html msg
+toHtml chart = Chart.view chart
diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm
new file mode 100644
index 0000000..b5c176f
--- /dev/null
+++ b/src/client/Chart/Model.elm
@@ -0,0 +1,73 @@
+module Chart.Model exposing
+ ( Chart
+ , Serie
+ , maxScale
+ , Vec2
+ , View
+ , mkView
+ , bounds
+ )
+
+import List.Extra as List
+
+type alias Chart =
+ { keys : List String
+ , series : List Serie
+ , size : Vec2
+ , title : String
+ , scaleColor : String
+ , formatOrdinate : Float -> String
+ , ordinateLines : Int
+ }
+
+type alias Serie =
+ { values : List Float
+ , color : String
+ , label : String
+ }
+
+maxScale : Chart -> Float
+maxScale { keys, series } =
+ List.range 0 (List.length keys - 1)
+ |> List.map (\i ->
+ series
+ |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values)
+ |> List.maximum
+ |> Maybe.withDefault 0
+ )
+ |> List.maximum
+ |> Maybe.withDefault 0
+ |> upperBound
+
+upperBound : Int -> Float
+upperBound n = toFloat (upperBoundInt 0 n)
+
+upperBoundInt : Int -> Int -> Int
+upperBoundInt count n =
+ if n < 10
+ then
+ (n + 1) * (10 ^ count)
+ else
+ upperBoundInt (count + 1) (n // 10)
+
+type alias Vec2 =
+ { x : Float
+ , y : Float
+ }
+
+type alias View =
+ { fx : Float -> Float
+ , fy : Float -> Float
+ }
+
+mkView : Vec2 -> Vec2 -> View
+mkView p1 p2 =
+ { fx = \x -> p1.x + x * (p2.x - p1.x)
+ , fy = \y -> p1.y + y * (p2.y - p1.y)
+ }
+
+bounds : View -> (Vec2, Vec2)
+bounds { fx, fy } =
+ ( { x = fx 0, y = fy 0 }
+ , { x = fx 1, y = fy 1 }
+ )
diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm
new file mode 100644
index 0000000..af8b4b7
--- /dev/null
+++ b/src/client/Chart/View.elm
@@ -0,0 +1,182 @@
+module Chart.View exposing
+ ( view
+ )
+
+import Html exposing (Html)
+import List.Extra as List
+import Svg exposing (..)
+import Svg.Attributes exposing (..)
+
+import Chart.Model as Chart exposing (Chart, Serie, Vec2, View)
+import Utils.List as List
+
+view : Chart -> Html msg
+view chart =
+ let { size, title, series } = chart
+ titleHeight = 100
+ captionHeight = 50
+ in svg
+ [ width << toString <| size.x
+ , height << toString <| size.y
+ , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y))
+ ]
+ ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ]
+ ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart
+ ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series
+ )
+
+renderTitle : View -> String -> Svg msg
+renderTitle view title =
+ text_
+ [ x << toString <| view.fx 0.5
+ , y << toString <| view.fy 0.5
+ , textAnchor "middle"
+ , dominantBaseline "middle"
+ , fontSize "20"
+ ]
+ [ text title ]
+
+renderSeriesAndScales : View -> Chart -> List (Svg msg)
+renderSeriesAndScales view chart =
+ let { keys, series, scaleColor, formatOrdinate } = chart
+ (p1, p2) = Chart.bounds view
+ ordinateWidth = 100
+ abscissaHeight = 60
+ maxScale = Chart.maxScale chart
+ in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale
+ ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor
+ ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor
+ )
+
+renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg)
+renderOrdinates view formatOrdinate maxScale =
+ ordinates
+ |> List.map (\l ->
+ text_
+ [ x << toString <| view.fx 0.5
+ , y << toString <| view.fy l
+ , textAnchor "middle"
+ , dominantBaseline "middle"
+ ]
+ [ text << formatOrdinate <| (1 - l) * maxScale ]
+ )
+
+
+renderAbscissas : View -> List String -> String -> List (Svg msg)
+renderAbscissas view keys scaleColor =
+ let count = List.length keys
+ in ( abscissasXPositions keys
+ |> List.map (\(xPos, key) ->
+ [ text_
+ [ x << toString <| view.fx xPos
+ , y << toString <| view.fy 0.5
+ , textAnchor "middle"
+ , dominantBaseline "middle"
+ ]
+ [ text key ]
+ , line
+ [ x1 << toString <| view.fx xPos
+ , y1 << toString <| view.fy 0
+ , x2 << toString <| view.fx xPos
+ , y2 << toString <| view.fy 0.2
+ , stroke scaleColor
+ ]
+ []
+ ]
+ )
+ |> List.concat
+ )
+
+renderSeries : View -> List Serie -> Float -> String -> List (Svg msg)
+renderSeries view series maxScale scaleColor =
+ ( renderHorizontalLines view series scaleColor
+ ++ renderPoints view series maxScale
+ )
+
+renderHorizontalLines : View -> List Serie -> String -> List (Svg msg)
+renderHorizontalLines view series scaleColor =
+ ordinates
+ |> List.map (\l ->
+ line
+ [ x1 << toString <| view.fx 0
+ , y1 << toString <| view.fy l
+ , x2 << toString <| view.fx 1
+ , y2 << toString <| view.fy l
+ , stroke scaleColor
+ ]
+ []
+ )
+
+renderPoints : View -> List Serie -> Float -> List (Svg msg)
+renderPoints view series maxScale =
+ series
+ |> List.map (\serie ->
+ let points =
+ abscissasXPositions serie.values
+ |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale })
+ in [ renderLines view serie.color points
+ , List.map (renderPoint view serie.color) points
+ ]
+ |> List.concat
+ )
+ |> List.concat
+
+renderLines : View -> String -> List Vec2 -> List (Svg msg)
+renderLines view color points =
+ List.links points
+ |> List.map (\(p1, p2) ->
+ line
+ [ x1 << toString <| view.fx p1.x
+ , y1 << toString <| view.fy p1.y
+ , x2 << toString <| view.fx p2.x
+ , y2 << toString <| view.fy p2.y
+ , stroke color
+ ]
+ []
+ )
+
+renderPoint : View -> String -> Vec2 -> Svg msg
+renderPoint view color pos =
+ circle
+ [ cx << toString <| view.fx pos.x
+ , cy << toString <| view.fy pos.y
+ , r "4"
+ , fill color
+ ]
+ []
+
+abscissasXPositions : List a -> List (Float, a)
+abscissasXPositions xs =
+ let count = List.length xs
+ in xs
+ |> List.zip (List.range 1 (count + 1))
+ |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x))
+
+ordinates : List Float
+ordinates =
+ let count = 10
+ in List.range 0 (count - 1)
+ |> List.map (\l -> toFloat l / (toFloat count - 1))
+
+renderCaptions : View -> List Serie -> List (Svg msg)
+renderCaptions view series =
+ let count = List.length series
+ in series
+ |> List.zip (List.range 1 (List.length series))
+ |> List.map (\(i, serie) ->
+ renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie
+ )
+ |> List.concat
+
+renderCaption : Vec2 -> Serie -> List (Svg msg)
+renderCaption point { label, color } =
+ [ text_
+ [ x << toString <| point.x
+ , y << toString <| point.y
+ , textAnchor "middle"
+ , dominantBaseline "middle"
+ , fill color
+ , fontSize "18"
+ ]
+ [ text label ]
+ ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 01:54:52 +0000