{-# 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
)
data FLTKHSEnv = FLTKHSEnv {
FLTKHSEnv -> AlignmentFns
flAlignmentFns :: AlignmentFns
, FLTKHSEnv -> Color
flFontColor :: Color
, FLTKHSEnv -> Color
flPathColor :: Color
, FLTKHSEnv -> Color
flFillColor :: Color
, FLTKHSEnv -> Matrix
flCurrentMatrix :: Matrix
}
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
}
{-# 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)
{-# 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
{-# 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))
{-# 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))
{-# 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)
{-# 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) }
{-# 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