{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}
module Graphics.UI.FLTK.Theme.Light.Dial
(
dialNew,
fillDialNew,
lineDialNew,
drawDial
)
where
import Control.Exception
import Control.Monad
import Data.List
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.Theme.Light.Common
import Text.Printf
import qualified Data.ByteString.Char8 as BC
import qualified Data.Text as T
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel
import Graphics.UI.FLTK.Theme.Light.Assets
dialOutline w h rW rH a1X a1Y rWWithStroke rHWithStroke bigCircle a2X a2Y sw colorString =
"<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\" >"
++ "<path "
++ "d=\"M" ++ (show a1X) ++ " " ++ (show a1Y) ++ ""
++ "A " ++ (show rWWithStroke) ++ " " ++ (show rHWithStroke) ++ " 0 1 " ++ (show bigCircle) ++ " " ++ (show a2X) ++ " " ++ (show a2Y) ++ ""
++ "\""
++ "stroke-width=\"" ++ (show sw) ++ "\""
++ "stroke=\"" ++ colorString ++ "\""
++ "fill=\"none\""
++ "stroke-linecap=\"round\""
++ "/>"
++ "</svg>"
meter w h rW rH meterCenter meterX meterY mw =
"<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\">"
++ "<circle cx=\"0.0\" cy=\"0.0\" r=\"" ++ (show meterCenter) ++ "\" />"
++ "<path "
++ "d=\"M0.0 0.0"
++ "l" ++ (show meterX) ++ " " ++ (show meterY) ++ ""
++ "\""
++ "stroke=\"black\""
++ "stroke-width=\"" ++ (show mw) ++ "\""
++ "stroke-linecap=\"round\""
++ "/>"
++ "</svg>"
fillEllipse w h rW rH startX startY rWWithStroke rHWithStroke bigCircle endX endY colorString =
"<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\" >"
++ "<path "
++ "d=\"M" ++ (show startX) ++ " " ++ (show startY) ++ ""
++ "A " ++ (show rWWithStroke) ++ " " ++ (show rHWithStroke) ++ " 0 " ++ (show bigCircle) ++ " 1 " ++ (show endX) ++ " " ++ (show endY) ++ ""
++ "L 0.0 0.0 Z"
++ "\""
++ "fill=\"" ++ colorString ++ "\""
++ "/>"
++ "</svg>"
arrow =
[
"<svg width=\"%d\" height=\"%d\" viewBox=\"%f %f %d %d\" transform=\"rotate(%f)\">"
, "<circle cx=\"%f\" cy=\"%f\" r=\"%f\" fill=\"none\" stroke=\"black\" stroke-width=\"%f\"/>"
, "<path "
, "d=\"M%f %f"
, "L%f %f"
, "L%f %f"
, "Z"
, "\""
, "fill=\"black\""
, "/>"
, "</svg>"
]
makeDialOutline :: Size -> PreciseAngle -> PreciseAngle -> String -> String
makeDialOutline (Size (Width w) (Height h)) a1 a2 colorString =
let ((rW,rH) :: (Double,Double)) = center w h
PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1)
PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2)
sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
in
dialOutline w h rW rH (a1X * (rW-(sw/2))) ((-a1Y) * (rH-(sw/2))) (rW-(sw/2)) (rH-(sw/2)) (if (a1 < a2) then (1 :: Int) else (0 :: Int)) (a2X * (rW-(sw/2))) ((-a2Y) * (rH-(sw/2))) sw colorString
center :: Int -> Int -> (Double,Double)
center w h = (fromIntegral w / 2, fromIntegral h / 2)
strokeWidth = percentOfSmallerEllipseRadius 10
meterCenterRadius = percentOfSmallerEllipseRadius 8
meterWidth = percentOfSmallerEllipseRadius 5
knobPadding = percentOfSmallerEllipseRadius 3
arrowBase = percentOfSmallerEllipseRadius 25
arrowHeight = percentOfSmallerEllipseRadius 20
arrowPadding = percentOfSmallerEllipseRadius 15
makeMeter :: PreciseAngle -> Size -> String
makeMeter angle (Size (Width w) (Height h)) =
let (rW,rH) = center w h
meterLength = if (rW < rH) then rW else rH
PrecisePosition (PreciseX x) (PreciseY y) = angleToCoordinate (fromFltkAngle angle)
sw :: Double
sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
meterCenter = meterCenterRadius (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
mw = meterWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
in
meter w h rW rH meterCenter (x * (meterLength - sw - (mw / 2))) ((-y) * (meterLength - sw - (mw / 2))) mw
makeFill :: Size -> PreciseAngle -> PreciseAngle -> String -> String
makeFill (Size (Width w) (Height h)) a1@(PreciseAngle a1') a2@(PreciseAngle a2') colorString =
let ((rW,rH) :: (Double,Double)) = center w h
PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1)
PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2)
sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
in
fillEllipse w h rW rH (a1X * (rW-sw)) ((-a1Y) * (rH-sw)) (rW-sw) (rH-sw) (if (abs (a2'-a1') < 180) then (0 :: Int) else (1 :: Int)) (a2X * (rW-sw)) ((-a2Y) * (rH-sw)) colorString
makeArrow :: Size -> PreciseAngle -> String
makeArrow (Size (Width w) (Height h)) a =
let ((rW,rH) :: (Double,Double)) = center w h
sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
circleR = if (rW<rH) then rW else rH
PreciseAngle a' = fromFltkAngle a
arrH = arrowHeight (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
arrB = arrowBase (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
arrP = arrowPadding (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
knobP = knobPadding (PreciseSize (PreciseWidth rW) (PreciseHeight rH))
in
printf (intercalate "\n" arrow)
w h (-rW) (-rH) w h (-a')
(0.0 :: Double) (0.0 :: Double) (circleR-sw-knobP) (1.0 :: Double)
(rW-sw-knobP-arrP) (0.0 :: Double)
(circleR-sw-arrH-knobP-arrP) (arrH/2)
(circleR-sw-arrH-knobP-arrP) (-(arrB/2))
wrapSvgs svgs =
concat (intersperse "\n" (["<svg>"] ++ svgs ++ ["</svg>"]))
drawDial :: Ref LowLevel.Dial -> IO ()
drawDial d = do
bounds@(Rectangle dialPos@(Position (X dialX) (Y dialY)) dialSize@(Size (Width dialW) (Height dialH))) <- LowLevel.getRectangle d
p <- LowLevel.getParent d
color <- maybe (return lightBackground) LowLevel.getColor p
drawBorderBox d
(BorderBoxSpec
{
borderBoxBounds = bounds
, borderBoxFocusedColor = color
, borderBoxHoveringColor = color
, borderBoxColor = color
, borderBoxFillColor = color
})
True
color <- fmap (\c -> colorAverage c blackColor 0.80) (LowLevel.getColor d)
(colorR,colorG,colorB) <- FL.getColorRgb color
(Angle a1) <- LowLevel.getAngle1 d
(Angle a2) <- LowLevel.getAngle2 d
let dialOutlineSvg = makeDialOutline dialSize (PreciseAngle (fromIntegral a1)) (PreciseAngle (fromIntegral a2)) ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")")
dialMin <- LowLevel.getMinimum d
dialMax <- LowLevel.getMaximum d
when (dialMin>dialMax) (throwIO (userError ("Dial minimum cannot be less than maximum:(" ++ (show dialMin) ++ "," ++ (show dialMax) ++ ")")))
dialV <- LowLevel.getValue d >>= LowLevel.clamp d
dialType <- LowLevel.getType_ d
let dialLocation = (dialV-dialMin) / (dialMax-dialMin)
let meterAngle = PreciseAngle (((fromIntegral (a2-a1)) * dialLocation) + (fromIntegral a1))
(selectionColorR, selectionColorG, selectionColorB) <- LowLevel.getSelectionColor d >>= FL.getColorRgb
let svg =
case dialType of
LowLevel.FillDialType ->
wrapSvgs
[
dialOutlineSvg
, if (a1<a2)
then makeFill dialSize
(PreciseAngle (fromIntegral a1))
meterAngle
("rgb(" ++ show selectionColorR ++ "," ++ show selectionColorG ++ "," ++ show selectionColorB ++ ")")
else makeFill dialSize
meterAngle
(PreciseAngle (fromIntegral a1))
("rgb(" ++ show selectionColorR ++ "," ++ show selectionColorG ++ "," ++ show selectionColorB ++ ")")
, makeMeter meterAngle dialSize
]
LowLevel.LineDialType ->
wrapSvgs
[
dialOutlineSvg
, makeMeter meterAngle dialSize
]
LowLevel.NormalDialType ->
wrapSvgs
[
dialOutlineSvg
, makeArrow dialSize meterAngle
]
iE <- LowLevel.svgImageNew (BC.pack svg)
case iE of
Left _ -> throwIO (userError ("drawDial: the generated SVG is invalid: \n" ++ svg))
Right i -> do
LowLevel.draw i dialPos
LowLevel.destroy i
LowLevel.drawLabel d Nothing
dialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Dial)
dialNew rectangle label = do
d <- LowLevel.dialCustom
rectangle
label
(Just drawDial)
Nothing
color <- commonColor
LowLevel.setColor d color
color <- commonFillColor
LowLevel.setSelectionColor d color
LowLevel.setLabelfont d commonFont
LowLevel.setLabelsize d commonFontSize
return d
fillDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillDial)
fillDialNew rect l = do
d <- dialNew rect l
LowLevel.setType d LowLevel.FillDialType
return (castTo d)
lineDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LineDial)
lineDialNew rect l = do
d <- dialNew rect l
LowLevel.setType d LowLevel.LineDialType
return (castTo d)