{-|
Module      : Graphics.Rendering.Chart.Backend.FLTKHS
Description : Provides a backend for the Chart library using a FLTKHS widget for rendering
Copyright   : (c) Michael Oswald, 2019
License     : BSD-3
Maintainer  : michael.oswald@onikudaki.net
Stability   : experimental
Portability : POSIX

To render a Chart to a widget, it is best to create a custom widget and override it's draw method.

An example:

@
widget' <- widgetCustom
    (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))
    Nothing
    drawChart
    defaultCustomWidgetFuncs
@

Here, 'drawChart' is the provided draw method for the widget. A possible implementation
could be this:

@
-- The char itself, to be used here with "Graphics.Rendering.Chart.Easy"
signal :: [Double] -> [(Double,Double)]
signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * sin (x*3.14159/5)) | x <- xs ]

-- the overloaded drawing function
drawChart :: Ref Widget -> IO ()
drawChart widget = do
    -- determine a clipping area for the whole widget first
    rectangle' <- getRectangle widget

    -- with this clipping area, we draw the graph. This graph is taken from Example 1 <https://github.com/timbod7/haskell-chart/wiki/example-1>
    -- from the Chart library
    withFlClip rectangle' $
        renderToWidgetEC widget $ do
            layout_title .= "Amplitude Modulation"
            setColors [opaque blue, opaque red]
            plot (line "am" [signal [0,(0.5)..400]])
            plot (points "am points" (signal [0,7..400]))
@


-}
{-# LANGUAGE OverloadedStrings
    , BangPatterns
    , BinaryLiterals
    , NumericUnderscores
    , FlexibleInstances
    , GADTs
    , ExistentialQuantification
#-}
module Graphics.Rendering.Chart.Backend.FLTKHS
  ( renderToWidget
  , renderToWidgetOffscreen
  , renderToWidgetEC
  , renderToWidgetOffscreenEC
  , runBackend
  , FLTKHSEnv
  , defaultEnv
  , withFlClip
  )
where

import           Control.Monad.Operational
import           Control.Monad                  ( void )
import           Control.Exception              ( bracket
                                                , bracket_
                                                )

import qualified Data.Text                     as T
import           Data.Char                      ( chr )
import           Data.Colour
import           Data.Colour.SRGB
import           Data.Bits
import           Data.Default.Class

import           Graphics.UI.FLTK.LowLevel.Fl_Types
import           Graphics.UI.FLTK.LowLevel.FLTKHS
                                               as FL
import           Graphics.UI.FLTK.LowLevel.Fl_Enumerations

import           Graphics.Rendering.Chart.Backend
                                               as G
import           Graphics.Rendering.Chart.Backend.Impl
import           Graphics.Rendering.Chart.Geometry
                                               as G
import           Graphics.Rendering.Chart.Renderable
import           Graphics.Rendering.Chart.Drawing
import           Graphics.Rendering.Chart.State ( EC
                                                , execEC
                                                )


-- | The environment internally used for drawing
data FLTKHSEnv = FLTKHSEnv {
    FLTKHSEnv -> AlignmentFns
flAlignmentFns :: AlignmentFns
    , FLTKHSEnv -> Color
flFontColor :: Color
    , FLTKHSEnv -> Color
flPathColor :: Color
    , FLTKHSEnv -> Color
flFillColor :: Color
    , FLTKHSEnv -> Matrix
flCurrentMatrix :: Matrix
    }

-- | Provide a default environment. The 'AlignmentFns' used should be 'bitmapAlignmentFns'
-- from the Chart library
defaultEnv :: AlignmentFns -> FLTKHSEnv
defaultEnv :: AlignmentFns -> FLTKHSEnv
defaultEnv alignFns :: AlignmentFns
alignFns = FLTKHSEnv :: AlignmentFns -> Color -> Color -> Color -> Matrix -> FLTKHSEnv
FLTKHSEnv
  { flAlignmentFns :: AlignmentFns
flAlignmentFns  = AlignmentFns
alignFns
  , flFontColor :: Color
flFontColor     = Color
blackColor
  , flPathColor :: Color
flPathColor     = Color
blackColor
  , flFillColor :: Color
flFillColor     = Color
whiteColor
  , flCurrentMatrix :: Matrix
flCurrentMatrix = Double -> Double -> Double -> Double -> Double -> Double -> Matrix
Matrix 1.0 0.0 0.0 1.0 0.0 0.0
  }


-- | Render a 'Renderable' to a widget. It renders to the full widget (it gets the rectangle
-- of the widgets area) and uses that as the sizes for rendering.
{-# INLINABLE renderToWidget #-}
renderToWidget :: Ref Widget -> Renderable a -> IO (PickFn a)
renderToWidget :: Ref Widget -> Renderable a -> IO (PickFn a)
renderToWidget widget :: Ref Widget
widget r :: Renderable a
r = do
  Rectangle
rectangle' <- Ref Widget -> IO Rectangle
forall r a impl.
(HasCallStack, Match r ~ FindOp a a (GetRectangle ()),
 Op (GetRectangle ()) r a impl) =>
Ref a -> impl
getRectangle Ref Widget
widget
  let (x :: Int
x, y :: Int
y, w' :: Int
w', h' :: Int
h') = Rectangle -> (Int, Int, Int, Int)
fromRectangle Rectangle
rectangle'
      cr :: BackendProgram (PickFn a)
cr             = Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w', Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h')
  FLTKHSEnv -> BackendProgram (PickFn a) -> IO (PickFn a)
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend (AlignmentFns -> FLTKHSEnv
defaultEnv AlignmentFns
bitmapAlignmentFns)
             (Point -> BackendProgram (PickFn a) -> BackendProgram (PickFn a)
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) BackendProgram (PickFn a)
cr)

-- | Render a 'Renderable' to a widget, using an 'FlOffscreen' buffer for double buffering. 
-- It renders to the full widget (it gets the rectangle
-- of the widgets area) and uses that as the sizes for rendering. The offscreen
-- buffer needs to be allocated beforehand and needs to have the necessary size
-- (see FLTKs documentation for using the offscreen rendering)
{-# INLINABLE renderToWidgetOffscreen #-}
renderToWidgetOffscreen :: Ref Widget -> FlOffscreen -> Renderable a -> IO (PickFn a)
renderToWidgetOffscreen :: Ref Widget -> FlOffscreen -> Renderable a -> IO (PickFn a)
renderToWidgetOffscreen widget :: Ref Widget
widget offscreen :: FlOffscreen
offscreen r :: Renderable a
r = do
  rectangle' :: Rectangle
rectangle'@(FL.Rectangle pos :: Position
pos size :: Size
size) <- Ref Widget -> IO Rectangle
forall r a impl.
(HasCallStack, Match r ~ FindOp a a (GetRectangle ()),
 Op (GetRectangle ()) r a impl) =>
Ref a -> impl
getRectangle Ref Widget
widget
  let (x :: Int
x, y :: Int
y, w' :: Int
w', h' :: Int
h') = Rectangle -> (Int, Int, Int, Int)
fromRectangle Rectangle
rectangle'
      cr :: BackendProgram (PickFn a)
cr             = Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w', Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h')
  FlOffscreen -> IO ()
flcBeginOffscreen FlOffscreen
offscreen 
  PickFn a
fun <- FLTKHSEnv -> BackendProgram (PickFn a) -> IO (PickFn a)
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend (AlignmentFns -> FLTKHSEnv
defaultEnv AlignmentFns
bitmapAlignmentFns)
             (Point -> BackendProgram (PickFn a) -> BackendProgram (PickFn a)
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) BackendProgram (PickFn a)
cr)
  IO ()
flcEndOffscreen
  Position -> Size -> FlOffscreen -> Position -> IO ()
flcCopyOffscreen Position
pos Size
size FlOffscreen
offscreen Position
pos 
  PickFn a -> IO (PickFn a)
forall (m :: * -> *) a. Monad m => a -> m a
return PickFn a
fun

-- | Render a Chart created with the statefull "Graphics.Rendering.Chart.Easy" API.
-- Calls 'renderToWidget' internally
{-# INLINABLE renderToWidgetEC #-}
renderToWidgetEC
  :: (Default r, ToRenderable r) => Ref Widget -> EC r () -> IO ()
renderToWidgetEC :: Ref Widget -> EC r () -> IO ()
renderToWidgetEC widget :: Ref Widget
widget ec :: EC r ()
ec =
  IO (PickFn ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (PickFn ()) -> IO ()) -> IO (PickFn ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ref Widget -> Renderable () -> IO (PickFn ())
forall a. Ref Widget -> Renderable a -> IO (PickFn a)
renderToWidget Ref Widget
widget (r -> Renderable ()
forall a. ToRenderable a => a -> Renderable ()
toRenderable (EC r () -> r
forall l a. Default l => EC l a -> l
execEC EC r ()
ec))

-- | Render a Chart created with the statefull "Graphics.Rendering.Chart.Easy" API.
-- Calls 'renderToWidgetOffscreen' internally, so it also needs a 'FlOffscreen'
-- buffer as argument
{-# INLINABLE renderToWidgetOffscreenEC #-}
renderToWidgetOffscreenEC
  :: (Default r, ToRenderable r) => Ref Widget -> FlOffscreen -> EC r () -> IO ()
renderToWidgetOffscreenEC :: Ref Widget -> FlOffscreen -> EC r () -> IO ()
renderToWidgetOffscreenEC widget :: Ref Widget
widget offscreen :: FlOffscreen
offscreen ec :: EC r ()
ec =
  IO (PickFn ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (PickFn ()) -> IO ()) -> IO (PickFn ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ref Widget -> FlOffscreen -> Renderable () -> IO (PickFn ())
forall a.
Ref Widget -> FlOffscreen -> Renderable a -> IO (PickFn a)
renderToWidgetOffscreen Ref Widget
widget FlOffscreen
offscreen (r -> Renderable ()
forall a. ToRenderable a => a -> Renderable ()
toRenderable (EC r () -> r
forall l a. Default l => EC l a -> l
execEC EC r ()
ec))



-- | Run this backends renderer
{-# INLINABLE runBackend #-}
runBackend :: FLTKHSEnv -> BackendProgram a -> IO a
runBackend :: FLTKHSEnv -> BackendProgram a -> IO a
runBackend env' :: FLTKHSEnv
env' m' :: BackendProgram a
m' = FLTKHSEnv -> ProgramView ChartBackendInstr a -> IO a
forall a. FLTKHSEnv -> ProgramView ChartBackendInstr a -> IO a
eval FLTKHSEnv
env' (BackendProgram a -> ProgramView ChartBackendInstr a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view BackendProgram a
m')
 where
  eval :: FLTKHSEnv -> ProgramView ChartBackendInstr a -> IO a
  eval :: FLTKHSEnv -> ProgramView ChartBackendInstr a -> IO a
eval _   (Return v :: a
v                ) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
  eval env :: FLTKHSEnv
env (StrokePath  p :: Path
p     :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = FLTKHSEnv -> Path -> IO ()
flStrokePath FLTKHSEnv
env Path
p IO () -> (() -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (FillPath    p :: Path
p     :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = FLTKHSEnv -> Path -> IO ()
flFillPath FLTKHSEnv
env Path
p IO () -> (() -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (GetTextSize s :: String
s     :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = String -> IO TextSize
flTextSize String
s IO TextSize -> (TextSize -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (DrawText p :: Point
p s :: String
s      :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = FLTKHSEnv -> Point -> String -> IO ()
flDrawText FLTKHSEnv
env Point
p String
s IO () -> (() -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (GetAlignments     :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f (FLTKHSEnv -> AlignmentFns
flAlignmentFns FLTKHSEnv
env)
  eval env :: FLTKHSEnv
env (WithTransform m :: Matrix
m p :: Program ChartBackendInstr b
p :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) = FLTKHSEnv -> Matrix -> Program ChartBackendInstr b -> IO b
forall a. FLTKHSEnv -> Matrix -> BackendProgram a -> IO a
flWithTransform FLTKHSEnv
env Matrix
m Program ChartBackendInstr b
p IO b -> (b -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (WithFontStyle font :: FontStyle
font p :: Program ChartBackendInstr b
p :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) =
    FLTKHSEnv -> FontStyle -> Program ChartBackendInstr b -> IO b
forall a. FLTKHSEnv -> FontStyle -> BackendProgram a -> IO a
flWithFontStyle FLTKHSEnv
env FontStyle
font Program ChartBackendInstr b
p IO b -> (b -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (WithFillStyle fs :: FillStyle
fs p :: Program ChartBackendInstr b
p :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) =
    FLTKHSEnv -> FillStyle -> Program ChartBackendInstr b -> IO b
forall a. FLTKHSEnv -> FillStyle -> BackendProgram a -> IO a
flWithFillStyle FLTKHSEnv
env FillStyle
fs Program ChartBackendInstr b
p IO b -> (b -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (WithLineStyle ls :: LineStyle
ls p :: Program ChartBackendInstr b
p :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) =
    FLTKHSEnv -> LineStyle -> Program ChartBackendInstr b -> IO b
forall a. FLTKHSEnv -> LineStyle -> BackendProgram a -> IO a
flWithLineStyle FLTKHSEnv
env LineStyle
ls Program ChartBackendInstr b
p IO b -> (b -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f
  eval env :: FLTKHSEnv
env (WithClipRegion r :: Rect
r p :: Program ChartBackendInstr b
p :>>= f :: b -> ProgramT ChartBackendInstr Identity a
f) =
    FLTKHSEnv -> Rect -> Program ChartBackendInstr b -> IO b
forall a. FLTKHSEnv -> Rect -> BackendProgram a -> IO a
flWithClipRegion FLTKHSEnv
env Rect
r Program ChartBackendInstr b
p IO b -> (b -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FLTKHSEnv
-> (b -> ProgramT ChartBackendInstr Identity a) -> b -> IO a
forall v a. FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step FLTKHSEnv
env b -> ProgramT ChartBackendInstr Identity a
f

  step :: FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
  step :: FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a
step env :: FLTKHSEnv
env f :: v -> BackendProgram a
f v :: v
v = FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env (v -> BackendProgram a
f v
v)



{-# INLINABLE withColor #-}
withColor :: IO a -> IO a
withColor :: IO a -> IO a
withColor action :: IO a
action = IO Color -> (Color -> IO ()) -> (Color -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Color
flcColor Color -> IO ()
flcSetColor (IO a -> Color -> IO a
forall a b. a -> b -> a
const IO a
action)



{-# INLINABLE isClosed #-}
isClosed :: Path -> Bool
isClosed :: Path -> Bool
isClosed G.Close            = Bool
True
isClosed End                = Bool
False
isClosed (MoveTo _ p :: Path
p      ) = Path -> Bool
isClosed Path
p
isClosed (LineTo _ p :: Path
p      ) = Path -> Bool
isClosed Path
p
isClosed (Arc    _ _ _ _ p :: Path
p) = Path -> Bool
isClosed Path
p
isClosed (ArcNeg _ _ _ _ p :: Path
p) = Path -> Bool
isClosed Path
p


{-# INLINABLE radToDegree #-}
radToDegree :: Double -> Double
radToDegree :: Double -> Double
radToDegree !Double
theta = Double
theta Double -> Double -> Double
forall a. Num a => a -> a -> a
* 180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi

{-# INLINABLE pointToPrecisePosition #-}
pointToPrecisePosition :: Point -> PrecisePosition
pointToPrecisePosition :: Point -> PrecisePosition
pointToPrecisePosition p :: Point
p =
  PreciseX -> PreciseY -> PrecisePosition
PrecisePosition (Double -> PreciseX
PreciseX (Point -> Double
p_x Point
p)) (Double -> PreciseY
PreciseY (Point -> Double
p_y Point
p))

{-# INLINABLE pointToPosition #-}
pointToPosition :: Point -> Position
pointToPosition :: Point -> Position
pointToPosition p :: Point
p = X -> Y -> Position
Position (Int -> X
X Int
x) (Int -> Y
Y Int
y)
 where
  x :: Int
x = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round (Point -> Double
p_x Point
p)
  y :: Int
y = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round (Point -> Double
p_y Point
p)


-- instance Show Path where
--     show (MoveTo p path) = "MoveTo " <> show p <> " " <> show path
--     show (LineTo p path) = "LineTo " <> show p <> " " <> show path
--     show (Arc p rad a1 a2 path) = "Arc " <> show p <> " " <> show rad <> " " <> show a1 <> " " <> show a2 <> " " <> show path
--     show (ArcNeg p rad a1 a2 path) = "ArcNeg " <> show p <> " " <> show rad <> " " <> show a1 <> " " <> show a2 <> " " <> show path
--     show End = "End"
--     show G.Close = "Close"


{-# INLINABLE checkDouble #-}
checkDouble :: Double -> Double
checkDouble :: Double -> Double
checkDouble d :: Double
d = if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d then 0 else Double
d


flStrokePath :: FLTKHSEnv -> Path -> IO ()
flStrokePath :: FLTKHSEnv -> Path -> IO ()
flStrokePath env :: FLTKHSEnv
env p' :: Path
p' = IO () -> IO ()
forall a. IO a -> IO a
withColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Color -> IO ()
flcSetColor (FLTKHSEnv -> Color
flPathColor FLTKHSEnv
env)
  let closed :: Bool
closed = Path -> Bool
isClosed Path
p'
  if Bool
closed then IO ()
flcBeginLoop else IO ()
flcBeginLine
  Path -> Bool -> IO ()
go Path
p' Bool
closed
 where
  go :: Path -> Bool -> IO ()
go (MoveTo p :: Point
p path :: Path
path) closed :: Bool
closed = do
    if Bool
closed
      then do
        IO ()
flcEndLoop
        IO ()
flcBeginLoop
      else do
        IO ()
flcEndLine
        IO ()
flcBeginLine
    PrecisePosition -> IO ()
flcVertex (PreciseX -> PreciseY -> PrecisePosition
PrecisePosition (Double -> PreciseX
PreciseX (Point -> Double
p_x Point
p)) (Double -> PreciseY
PreciseY (Point -> Double
p_y Point
p)))
    Path -> Bool -> IO ()
go Path
path Bool
closed
  go (LineTo p :: Point
p path :: Path
path) closed :: Bool
closed = do
    PrecisePosition -> IO ()
flcVertex (PreciseX -> PreciseY -> PrecisePosition
PrecisePosition (Double -> PreciseX
PreciseX (Point -> Double
p_x Point
p)) (Double -> PreciseY
PreciseY (Point -> Double
p_y Point
p)))
    Path -> Bool -> IO ()
go Path
path Bool
closed
  go (Arc p :: Point
p r :: Double
r a1 :: Double
a1 a2 :: Double
a2 path :: Path
path) closed :: Bool
closed = do
    PrecisePosition -> Double -> PreciseAngle -> PreciseAngle -> IO ()
flcArcByRadius PrecisePosition
pt (Double -> Double
checkDouble Double
r) PreciseAngle
a1t PreciseAngle
a2t
    Path -> Bool -> IO ()
go Path
path Bool
closed
   where
    pt :: PrecisePosition
pt   = Point -> PrecisePosition
pointToPrecisePosition Point
p
    !a1t :: PreciseAngle
a1t = Double -> PreciseAngle
PreciseAngle (360 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
radToDegree Double
a1)
    !a2t :: PreciseAngle
a2t = Double -> PreciseAngle
PreciseAngle (360 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
radToDegree Double
a2)
  go (ArcNeg p :: Point
p r :: Double
r a1 :: Double
a1 a2 :: Double
a2 path :: Path
path) closed :: Bool
closed = do
    PrecisePosition -> Double -> PreciseAngle -> PreciseAngle -> IO ()
flcArcByRadius PrecisePosition
pt (Double -> Double
checkDouble Double
r) PreciseAngle
a1t PreciseAngle
a2t
    Path -> Bool -> IO ()
go Path
path Bool
closed
   where
    pt :: PrecisePosition
pt   = Point -> PrecisePosition
pointToPrecisePosition Point
p
    !a1t :: PreciseAngle
a1t = Double -> PreciseAngle
PreciseAngle (Double -> Double
radToDegree Double
a1)
    !a2t :: PreciseAngle
a2t = Double -> PreciseAngle
PreciseAngle (Double -> Double
radToDegree Double
a2)
  go End     closed :: Bool
closed = if Bool
closed then IO ()
flcEndLoop else IO ()
flcEndLine
  go G.Close closed :: Bool
closed = if Bool
closed then IO ()
flcEndLoop else IO ()
flcEndLine



flFillPath :: FLTKHSEnv -> Path -> IO ()
flFillPath :: FLTKHSEnv -> Path -> IO ()
flFillPath env :: FLTKHSEnv
env p' :: Path
p' = IO () -> IO ()
forall a. IO a -> IO a
withColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Color -> IO ()
flcSetColor (FLTKHSEnv -> Color
flFillColor FLTKHSEnv
env)
  IO ()
flcBeginComplexPolygon
  Path -> IO ()
go Path
p'
 where
  go :: Path -> IO ()
go (MoveTo p :: Point
p path :: Path
path) = do
    IO ()
flcGap
    PrecisePosition -> IO ()
flcVertex (PreciseX -> PreciseY -> PrecisePosition
PrecisePosition (Double -> PreciseX
PreciseX (Point -> Double
p_x Point
p)) (Double -> PreciseY
PreciseY (Point -> Double
p_y Point
p)))
    Path -> IO ()
go Path
path
  go (LineTo p :: Point
p path :: Path
path) = do
    PrecisePosition -> IO ()
flcVertex (PreciseX -> PreciseY -> PrecisePosition
PrecisePosition (Double -> PreciseX
PreciseX (Point -> Double
p_x Point
p)) (Double -> PreciseY
PreciseY (Point -> Double
p_y Point
p)))
    Path -> IO ()
go Path
path
  go (Arc p :: Point
p r :: Double
r a1 :: Double
a1 a2 :: Double
a2 path :: Path
path) = do
    PrecisePosition -> Double -> PreciseAngle -> PreciseAngle -> IO ()
flcArcByRadius PrecisePosition
pt (Double -> Double
checkDouble Double
r) PreciseAngle
a1t PreciseAngle
a2t
    Path -> IO ()
go Path
path
   where
    pt :: PrecisePosition
pt   = Point -> PrecisePosition
pointToPrecisePosition Point
p
    !a1t :: PreciseAngle
a1t = Double -> PreciseAngle
PreciseAngle (360 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
radToDegree Double
a1)
    !a2t :: PreciseAngle
a2t = Double -> PreciseAngle
PreciseAngle (360 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
radToDegree Double
a2)
  go (ArcNeg p :: Point
p r :: Double
r a1 :: Double
a1 a2 :: Double
a2 path :: Path
path) = do
    PrecisePosition -> Double -> PreciseAngle -> PreciseAngle -> IO ()
flcArcByRadius PrecisePosition
pt (Double -> Double
checkDouble Double
r) PreciseAngle
a1t PreciseAngle
a2t
    Path -> IO ()
go Path
path
   where
    pt :: PrecisePosition
pt   = Point -> PrecisePosition
pointToPrecisePosition Point
p
    !a1t :: PreciseAngle
a1t = Double -> PreciseAngle
PreciseAngle (Double -> Double
radToDegree Double
a1)
    !a2t :: PreciseAngle
a2t = Double -> PreciseAngle
PreciseAngle (Double -> Double
radToDegree Double
a2)
  go End     = IO ()
flcEndComplexPolygon
  go G.Close = IO ()
flcEndComplexPolygon


flTextSize :: String -> IO TextSize
flTextSize :: String -> IO TextSize
flTextSize text :: String
text = do
  FL.Rectangle (Position _ _) (Size (Width w :: Int
w) (Height h :: Int
h)) <- Text -> IO Rectangle
flcTextExtents
    (String -> Text
T.pack String
text)
  Int
descent <- IO Int
flcDescent
  let res :: TextSize
res = TextSize :: Double -> Double -> Double -> Double -> Double -> TextSize
TextSize { textSizeWidth :: Double
textSizeWidth    = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
                     , textSizeHeight :: Double
textSizeHeight   = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
                     , textSizeDescent :: Double
textSizeDescent  = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
descent
                     , textSizeAscent :: Double
textSizeAscent   = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
descent)
                     , textSizeYBearing :: Double
textSizeYBearing = 0
                     }
  TextSize -> IO TextSize
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextSize
res

{-# INLINABLE apply #-}
apply :: Matrix -> Point -> Point
apply :: Matrix -> Point -> Point
apply (Matrix a1 :: Double
a1 a2 :: Double
a2 b1 :: Double
b1 b2 :: Double
b2 c1 :: Double
c1 c2 :: Double
c2) (Point x :: Double
x y :: Double
y) =
  let new_x :: Double
new_x = Double
a1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c1
      new_y :: Double
new_y = Double
a2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c2
  in  Double -> Double -> Point
Point Double
new_x Double
new_y


{-# INLINABLE flDrawText #-}
flDrawText :: FLTKHSEnv -> Point -> String -> IO ()
flDrawText :: FLTKHSEnv -> Point -> String -> IO ()
flDrawText env :: FLTKHSEnv
env p :: Point
p text :: String
text = IO () -> IO ()
forall a. IO a -> IO a
withColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Color -> IO ()
flcSetColor (FLTKHSEnv -> Color
flFontColor FLTKHSEnv
env)
  Text -> Position -> IO ()
flcDraw (String -> Text
T.pack String
text) (Point -> Position
pointToPosition (Matrix -> Point -> Point
apply (FLTKHSEnv -> Matrix
flCurrentMatrix FLTKHSEnv
env) Point
p))




withSavedLineStyle :: IO a -> IO a
withSavedLineStyle :: IO a -> IO a
withSavedLineStyle action :: IO a
action = IO Color -> (Color -> IO ()) -> (Color -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Color
flcColor Color -> IO ()
reset (IO a -> Color -> IO a
forall a b. a -> b -> a
const IO a
action)
 where
  reset :: Color -> IO ()
reset col :: Color
col = do
    LineDrawStyle -> Maybe Width -> Maybe Text -> IO ()
flcLineStyle (Maybe LineStyle
-> Maybe CapStyle -> Maybe JoinStyle -> LineDrawStyle
LineDrawStyle Maybe LineStyle
forall a. Maybe a
Nothing Maybe CapStyle
forall a. Maybe a
Nothing Maybe JoinStyle
forall a. Maybe a
Nothing) Maybe Width
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
    Color -> IO ()
flcSetColor Color
col


{-# INLINABLE clampI #-}
clampI :: Int -> Int
clampI :: Int -> Int
clampI x :: Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0     = 0
         | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 255   = 255
         | Bool
otherwise = Int
x

flWithLineStyle :: FLTKHSEnv -> G.LineStyle -> BackendProgram a -> IO a
flWithLineStyle :: FLTKHSEnv -> LineStyle -> BackendProgram a -> IO a
flWithLineStyle env :: FLTKHSEnv
env ls :: LineStyle
ls p :: BackendProgram a
p = IO a -> IO a
forall a. IO a -> IO a
withSavedLineStyle (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  let width :: Int
width     = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round (LineStyle -> Double
_line_width LineStyle
ls)
      capStyle :: CapStyle
capStyle  = LineCap -> CapStyle
convCapStyle (LineStyle -> LineCap
_line_cap LineStyle
ls)
      joinStyle :: JoinStyle
joinStyle = LineJoin -> JoinStyle
convJoinStyle (LineStyle -> LineJoin
_line_join LineStyle
ls)
      style :: LineDrawStyle
style     = Maybe LineStyle
-> Maybe CapStyle -> Maybe JoinStyle -> LineDrawStyle
LineDrawStyle Maybe LineStyle
forall a. Maybe a
Nothing (CapStyle -> Maybe CapStyle
forall a. a -> Maybe a
Just CapStyle
capStyle) (JoinStyle -> Maybe JoinStyle
forall a. a -> Maybe a
Just JoinStyle
joinStyle)

      dashes :: Text
dashes    = String -> Text
T.pack (String -> Text) -> ([Double] -> String) -> [Double] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Char) -> [Double] -> String
forall a b. (a -> b) -> [a] -> [b]
map Double -> Char
conv ([Double] -> Text) -> [Double] -> Text
forall a b. (a -> b) -> a -> b
$ LineStyle -> [Double]
_line_dashes LineStyle
ls

      conv :: Double -> Char
      conv :: Double -> Char
conv = Int -> Char
chr (Int -> Char) -> (Double -> Int) -> Double -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
clampI (Int -> Int) -> (Double -> Int) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round

      col :: Color
col  = AlphaColour Double -> Color
convColor (LineStyle -> AlphaColour Double
_line_color LineStyle
ls)

  LineDrawStyle -> Maybe Width -> Maybe Text -> IO ()
flcLineStyle LineDrawStyle
style (Width -> Maybe Width
forall a. a -> Maybe a
Just (Int -> Width
Width Int
width)) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
dashes)
  FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env { flPathColor :: Color
flPathColor = Color
col } BackendProgram a
p

flWithFillStyle :: FLTKHSEnv -> FillStyle -> BackendProgram a -> IO a
flWithFillStyle :: FLTKHSEnv -> FillStyle -> BackendProgram a -> IO a
flWithFillStyle env :: FLTKHSEnv
env fs :: FillStyle
fs =
  FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env { flFillColor :: Color
flFillColor = AlphaColour Double -> Color
convColor (FillStyle -> AlphaColour Double
_fill_color FillStyle
fs) }

-- | Performs a drawing action in a widget within a defined clipping rectangle. This
-- is a convenience function, as FLTKHS is quite statefull and a 'flcPushClip' must
-- be closed by a 'flcPopClip'. So this function exactly provides this, while
-- executing the given drawing action in between push and pop
{-# INLINABLE withFlClip #-}
withFlClip :: FL.Rectangle -> IO a -> IO a
withFlClip :: Rectangle -> IO a -> IO a
withFlClip rect :: Rectangle
rect = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Rectangle -> IO ()
flcPushClip Rectangle
rect) IO ()
flcPopClip

{-# INLINABLE flWithClipRegion #-}
flWithClipRegion :: FLTKHSEnv -> Rect -> BackendProgram a -> IO a
flWithClipRegion :: FLTKHSEnv -> Rect -> BackendProgram a -> IO a
flWithClipRegion env :: FLTKHSEnv
env (Rect p1 :: Point
p1@(Point _ _) p2 :: Point
p2@(Point _ _)) p :: BackendProgram a
p = do
  let mat :: Matrix
mat         = FLTKHSEnv -> Matrix
flCurrentMatrix FLTKHSEnv
env
      Point x1 :: Double
x1 y1 :: Double
y1 = Matrix -> Point -> Point
apply Matrix
mat Point
p1
      Point x2 :: Double
x2 y2 :: Double
y2 = Matrix -> Point -> Point
apply Matrix
mat Point
p2

      !rect :: Rectangle
rect       = Position -> Size -> Rectangle
FL.Rectangle
        (X -> Y -> Position
Position (Int -> X
X (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round Double
minx)) (Int -> Y
Y (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round Double
miny)))
        (Width -> Height -> Size
Size (Int -> Width
Width (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round Double
w)) (Int -> Height
Height (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round Double
h)))
      !minx :: Double
minx = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
x1 Double
x2
      !miny :: Double
miny = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
y1 Double
y2
      !maxx :: Double
maxx = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
x1 Double
x2
      !maxy :: Double
maxy = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
y1 Double
y2
      !w :: Double
w    = Double
maxx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
minx
      !h :: Double
h    = Double
maxy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
miny
  Rectangle -> IO a -> IO a
forall a. Rectangle -> IO a -> IO a
withFlClip Rectangle
rect (FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env BackendProgram a
p)


{-# INLINABLE withMatrix #-}
withMatrix :: IO a -> IO a
withMatrix :: IO a -> IO a
withMatrix = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
flcPushMatrix IO ()
flcPopMatrix


flWithTransform :: FLTKHSEnv -> Matrix -> BackendProgram a -> IO a
flWithTransform :: FLTKHSEnv -> Matrix -> BackendProgram a -> IO a
flWithTransform env :: FLTKHSEnv
env mat :: Matrix
mat@(Matrix xx' :: Double
xx' yx' :: Double
yx' xy' :: Double
xy' yy' :: Double
yy' x0' :: Double
x0' y0' :: Double
y0') p :: BackendProgram a
p = IO a -> IO a
forall a. IO a -> IO a
withMatrix (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  Double -> Double -> Double -> Double -> ByXY -> IO ()
flcMultMatrix Double
xx' Double
yx' Double
xy' Double
yy' (ByX -> ByY -> ByXY
ByXY (Double -> ByX
ByX Double
x0') (Double -> ByY
ByY Double
y0'))
  FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env { flCurrentMatrix :: Matrix
flCurrentMatrix = FLTKHSEnv -> Matrix
flCurrentMatrix FLTKHSEnv
env Matrix -> Matrix -> Matrix
forall a. Num a => a -> a -> a
* Matrix
mat } BackendProgram a
p


{-# INLINABLE withFlFont #-}
withFlFont :: IO a -> IO a
withFlFont :: IO a -> IO a
withFlFont action :: IO a
action = IO (Font, FontSize)
-> ((Font, FontSize) -> IO ())
-> ((Font, FontSize) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Font, FontSize)
acquire (Font, FontSize) -> IO ()
release (IO a -> (Font, FontSize) -> IO a
forall a b. a -> b -> a
const IO a
action)
 where
  acquire :: IO (Font, FontSize)
acquire = (,) (Font -> FontSize -> (Font, FontSize))
-> IO Font -> IO (FontSize -> (Font, FontSize))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Font
flcFont IO (FontSize -> (Font, FontSize))
-> IO FontSize -> IO (Font, FontSize)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO FontSize
flcSize
  release :: (Font, FontSize) -> IO ()
release (font :: Font
font, size :: FontSize
size) = Font -> FontSize -> IO ()
flcSetFont Font
font FontSize
size



{-# INLINABLE flWithFontStyle #-}
flWithFontStyle :: FLTKHSEnv -> FontStyle -> BackendProgram a -> IO a
flWithFontStyle :: FLTKHSEnv -> FontStyle -> BackendProgram a -> IO a
flWithFontStyle env :: FLTKHSEnv
env font :: FontStyle
font p :: BackendProgram a
p = IO a -> IO a
forall a. IO a -> IO a
withFlFont (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  let fontSize :: FontSize
fontSize = CInt -> FontSize
FontSize (Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round (FontStyle -> Double
_font_size FontStyle
font))
      flfont :: Font
flfont   = FontStyle -> Font
selectFont FontStyle
font
  Font -> FontSize -> IO ()
flcSetFont Font
flfont FontSize
fontSize
  FLTKHSEnv -> BackendProgram a -> IO a
forall a. FLTKHSEnv -> BackendProgram a -> IO a
runBackend FLTKHSEnv
env { flFontColor :: Color
flFontColor = AlphaColour Double -> Color
convColor (FontStyle -> AlphaColour Double
_font_color FontStyle
font) } BackendProgram a
p


{-# INLINABLE selectFont #-}
selectFont :: FontStyle -> Font
selectFont :: FontStyle -> Font
selectFont fs :: FontStyle
fs = case (FontStyle -> String
_font_name FontStyle
fs, FontStyle -> FontSlant
_font_slant FontStyle
fs, FontStyle -> FontWeight
_font_weight FontStyle
fs) of
  ("serif"     , FontSlantNormal , FontWeightNormal) -> Font
times
  ("serif"     , FontSlantNormal , FontWeightBold  ) -> Font
timesBold
  ("serif"     , FontSlantItalic , FontWeightNormal) -> Font
timesItalic
  ("serif"     , FontSlantOblique, FontWeightNormal) -> Font
timesItalic
  ("serif"     , FontSlantItalic , FontWeightBold  ) -> Font
timesBoldItalic
  ("serif"     , FontSlantOblique, FontWeightBold  ) -> Font
timesBoldItalic

  ("sans-serif", FontSlantNormal , FontWeightNormal) -> Font
helvetica
  ("sans-serif", FontSlantNormal , FontWeightBold  ) -> Font
helveticaBold
  ("sans-serif", FontSlantItalic , FontWeightNormal) -> Font
helveticaItalic
  ("sans-serif", FontSlantOblique, FontWeightNormal) -> Font
helveticaItalic
  ("sans-serif", FontSlantItalic , FontWeightBold  ) -> Font
helveticaBoldItalic
  ("sans-serif", FontSlantOblique, FontWeightBold  ) -> Font
helveticaBoldItalic

  ("monospace" , FontSlantNormal , FontWeightNormal) -> Font
courier
  ("monospace" , FontSlantNormal , FontWeightBold  ) -> Font
courierBold
  ("monospace" , FontSlantItalic , FontWeightNormal) -> Font
courierItalic
  ("monospace" , FontSlantOblique, FontWeightNormal) -> Font
courierItalic
  ("monospace" , FontSlantItalic , FontWeightBold  ) -> Font
courierBoldItalic
  ("monospace" , FontSlantOblique, FontWeightBold  ) -> Font
courierBoldItalic

  (_           , FontSlantNormal , FontWeightNormal) -> Font
helvetica
  (_           , FontSlantNormal , FontWeightBold  ) -> Font
helveticaBold
  (_           , FontSlantItalic , FontWeightNormal) -> Font
helveticaItalic
  (_           , FontSlantOblique, FontWeightNormal) -> Font
helveticaItalic
  (_           , FontSlantItalic , FontWeightBold  ) -> Font
helveticaBoldItalic
  (_           , FontSlantOblique, FontWeightBold  ) -> Font
helveticaBoldItalic




{-# INLINABLE convCapStyle #-}
convCapStyle :: LineCap -> CapStyle
convCapStyle :: LineCap -> CapStyle
convCapStyle LineCapButt   = CapStyle
CapStyleFlat
convCapStyle LineCapRound  = CapStyle
CapStyleRound
convCapStyle LineCapSquare = CapStyle
CapStyleSquare

{-# INLINABLE convJoinStyle #-}
convJoinStyle :: LineJoin -> JoinStyle
convJoinStyle :: LineJoin -> JoinStyle
convJoinStyle LineJoinMiter = JoinStyle
JoinStyleMiter
convJoinStyle LineJoinRound = JoinStyle
JoinStyleRound
convJoinStyle LineJoinBevel = JoinStyle
JoinStyleBevel

{-# INLINABLE pureColour #-}
pureColour :: AlphaColour Double -> Colour Double
pureColour :: AlphaColour Double -> Colour Double
pureColour ac :: AlphaColour Double
ac = Double -> Colour Double -> Colour Double
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (Double -> Double
forall a. Fractional a => a -> a
recip Double
a) (AlphaColour Double
ac AlphaColour Double -> Colour Double -> Colour Double
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour Double
forall a. Num a => Colour a
black) where a :: Double
a = AlphaColour Double -> Double
forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
ac

{-# INLINABLE convColor #-}
convColor :: AlphaColour Double -> Color
convColor :: AlphaColour Double -> Color
convColor color :: AlphaColour Double
color =
  let (RGB r :: Word8
r g :: Word8
g b :: Word8
b) = Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 (AlphaColour Double -> Colour Double
pureColour AlphaColour Double
color)
      !col :: Color
col        = CUInt -> Color
Color
        (        Word8 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r
        CUInt -> Int -> CUInt
forall a. Bits a => a -> Int -> a
`shiftL` 24
        CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.|.      Word8 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g
        CUInt -> Int -> CUInt
forall a. Bits a => a -> Int -> a
`shiftL` 16
        CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.|.      Word8 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
        CUInt -> Int -> CUInt
forall a. Bits a => a -> Int -> a
`shiftL` 8
        )
  in  Color
col