{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_HADDOCK hide #-}

{-# HLINT ignore "Use bimap" #-}
{-# HLINT ignore "Use unless" #-}

module Brillo.Internals.Rendering.Picture (renderPicture)
where

import Control.Monad (forM_, when)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.List (find)
import Foreign.ForeignPtr (withForeignPtr)
import Graphics.Rendering.OpenGL (get, ($=))
import Graphics.Rendering.OpenGL.GL qualified as GL
import Graphics.Rendering.OpenGL.GLU.Errors qualified as GLU
import System.Mem.StableName (makeStableName)

import Brillo.Internals.Data.Color (Color (RGBA))
import Brillo.Internals.Data.Picture (
  BitmapFormat (pixelFormat, rowOrder),
  Picture (..),
  PixelFormat (PxABGR, PxRGBA),
  Rectangle (Rectangle, rectPos, rectSize),
  RowOrder (BottomToTop, TopToBottom),
  rectAtOrigin,
 )
import Brillo.Internals.Rendering.Bitmap (BitmapData (..), bitmapPath)
import Brillo.Internals.Rendering.Circle (renderArc, renderCircle)
import Brillo.Internals.Rendering.Common (gf, gsizei)
import Brillo.Internals.Rendering.State (
  State (
    stateBlendAlpha,
    stateColor,
    stateLineSmooth,
    stateTextures,
    stateWireframe
  ),
  Texture (..),
 )
import Brillo.Internals.Rendering.VectorFont as VF (canvastextFont, renderSafe)


{-| Render a picture into the current OpenGL context.

  Assumes that the OpenGL matrix mode is set to @Modelview@
-}
renderPicture
  :: State
  -- ^ Current rendering state.
  -> Float
  -- ^ View port scale, which controls the level of detail.
  --   Use 1.0 to start with.
  -> Picture
  -- ^ Picture to render.
  -> IO ()
renderPicture :: State -> GLfloat -> Picture -> IO ()
renderPicture State
state GLfloat
circScale Picture
picture =
  do
    -- Setup render state for world
    Bool -> IO ()
setLineSmooth (State -> Bool
stateLineSmooth State
state)
    Bool -> IO ()
setBlendAlpha (State -> Bool
stateBlendAlpha State
state)

    -- Draw the picture
    String -> IO ()
checkErrors String
"before drawPicture."
    State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
picture
    String -> IO ()
checkErrors String
"after drawPicture."


drawPicture :: State -> Float -> Picture -> IO ()
drawPicture :: State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
picture =
  {-# SCC "drawComponent" #-}
  case Picture
picture of
    -- nothin'
    Picture
Blank ->
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- line
    Line Path
path ->
      PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.LineStrip (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Path -> IO ()
vertexPFs Path
path
    -- polygon (where?)
    Polygon Path
path
      | State -> Bool
stateWireframe State
state ->
          PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.LineLoop (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Path -> IO ()
vertexPFs Path
path
      | Bool
otherwise ->
          PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Polygon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Path -> IO ()
vertexPFs Path
path
    -- circle
    Circle GLfloat
radius ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
0
    ThickCircle GLfloat
radius GLfloat
thickness ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
thickness
    -- arc
    Arc GLfloat
a1 GLfloat
a2 GLfloat
radius ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
0
    ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
thickness
    -- Vector font text
    Text String
str -> do
      let
        characters :: [[(Double, Double)]]
        characters :: [[(Double, Double)]]
characters = VectorFont -> String -> [[(Double, Double)]]
renderSafe VectorFont
canvastextFont String
str

      IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        GLfloat -> GLfloat -> GLfloat -> IO ()
forall c. MatrixComponent c => c -> c -> c -> IO ()
GL.scale (GLfloat -> GLfloat
gf GLfloat
5) (GLfloat -> GLfloat
gf GLfloat
5) GLfloat
0
        [[(Double, Double)]] -> ([(Double, Double)] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[(Double, Double)]]
characters (([(Double, Double)] -> IO ()) -> IO ())
-> ([(Double, Double)] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Double, Double)]
stroke -> do
          PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.LineStrip (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            [(Double, Double)] -> ((Double, Double) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Double, Double)]
stroke (((Double, Double) -> IO ()) -> IO ())
-> ((Double, Double) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Double
x, Double
y) -> do
              Vertex2 Double -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 Double -> IO ()) -> Vertex2 Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Vertex2 Double
forall a. a -> a -> Vertex2 a
GL.Vertex2 Double
x Double
y

    -- colors with float components.
    Color Color
col Picture
p
      | State -> Bool
stateColor State
state -> do
          Color4 GLfloat
oldColor <- StateVar (Color4 GLfloat) -> IO (Color4 GLfloat)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> m (Color4 GLfloat)
get StateVar (Color4 GLfloat)
GL.currentColor

          let RGBA GLfloat
r GLfloat
g GLfloat
b GLfloat
a = Color
col

          StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 (GLfloat -> GLfloat
gf GLfloat
r) (GLfloat -> GLfloat
gf GLfloat
g) (GLfloat -> GLfloat
gf GLfloat
b) (GLfloat -> GLfloat
gf GLfloat
a)
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p
          StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= Color4 GLfloat
oldColor
      | Bool
otherwise ->
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p
    -- Translation --------------------------
    -- Easy translations are done directly to avoid calling GL.perserveMatrix.
    Translate GLfloat
posX GLfloat
posY (Circle GLfloat
radius) ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
0
    Translate GLfloat
posX GLfloat
posY (ThickCircle GLfloat
radius GLfloat
thickness) ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
thickness
    Translate GLfloat
posX GLfloat
posY (Arc GLfloat
a1 GLfloat
a2 GLfloat
radius) ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
0
    Translate GLfloat
posX GLfloat
posY (ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness) ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
thickness
    Translate GLfloat
tx GLfloat
ty (Rotate GLfloat
deg Picture
p) ->
      IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        do
          Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (GLfloat -> GLfloat
gf GLfloat
tx) (GLfloat -> GLfloat
gf GLfloat
ty) GLfloat
0)
          GLfloat -> Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate (GLfloat -> GLfloat
gf GLfloat
deg) (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLfloat
0 GLfloat
0 (-GLfloat
1))
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p
    Translate GLfloat
tx GLfloat
ty Picture
p ->
      IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        do
          Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (GLfloat -> GLfloat
gf GLfloat
tx) (GLfloat -> GLfloat
gf GLfloat
ty) GLfloat
0)
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p

    -- Rotation -----------------------------
    -- Easy rotations are done directly to avoid calling GL.perserveMatrix.
    Rotate GLfloat
_ (Circle GLfloat
radius) ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
0
    Rotate GLfloat
_ (ThickCircle GLfloat
radius GLfloat
thickness) ->
      GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
thickness
    Rotate GLfloat
deg (Arc GLfloat
a1 GLfloat
a2 GLfloat
radius) ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius (GLfloat
a1 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
- GLfloat
deg) (GLfloat
a2 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
- GLfloat
deg) GLfloat
0
    Rotate GLfloat
deg (ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness) ->
      GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius (GLfloat
a1 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
- GLfloat
deg) (GLfloat
a2 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
- GLfloat
deg) GLfloat
thickness
    Rotate GLfloat
deg Picture
p ->
      IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        do
          GLfloat -> Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate (GLfloat -> GLfloat
gf GLfloat
deg) (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLfloat
0 GLfloat
0 (-GLfloat
1))
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p

    -- Scale --------------------------------
    Scale GLfloat
sx GLfloat
sy Picture
p ->
      IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        do
          GLfloat -> GLfloat -> GLfloat -> IO ()
forall c. MatrixComponent c => c -> c -> c -> IO ()
GL.scale (GLfloat -> GLfloat
gf GLfloat
sx) (GLfloat -> GLfloat
gf GLfloat
sy) GLfloat
1
          let mscale :: GLfloat
mscale = GLfloat -> GLfloat -> GLfloat
forall a. Ord a => a -> a -> a
max GLfloat
sx GLfloat
sy
          State -> GLfloat -> Picture -> IO ()
drawPicture State
state (GLfloat
circScale GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
* GLfloat
mscale) Picture
p
    Bitmap BitmapData
imgData ->
      let (Int
width, Int
height) = BitmapData -> (Int, Int)
bitmapSize BitmapData
imgData
      in  State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale (Picture -> IO ()) -> Picture -> IO ()
forall a b. (a -> b) -> a -> b
$
            Rectangle -> BitmapData -> Picture
BitmapSection (Int -> Int -> Rectangle
rectAtOrigin Int
width Int
height) BitmapData
imgData
    BitmapSection
      Rectangle
        { rectPos :: Rectangle -> (Int, Int)
rectPos = (Int, Int)
imgSectionPos
        , rectSize :: Rectangle -> (Int, Int)
rectSize = (Int, Int)
imgSectionSize
        }
      imgData :: BitmapData
imgData@BitmapData
        { bitmapSize :: BitmapData -> (Int, Int)
bitmapSize = (Int
width, Int
height)
        , bitmapCacheMe :: BitmapData -> Bool
bitmapCacheMe = Bool
cacheMe
        } ->
        do
          let rowInfo :: Path
rowInfo =
                -- calculate texture coordinates
                -- remark:
                --   On some hardware, using exact "integer" coordinates causes texture coords
                --   with a component == 0  flip to -1. This appears as the texture flickering
                --   on the left and sometimes show one additional row of pixels outside the
                --   given rectangle
                --   To prevent this we add an "epsilon-border".
                --   This has been testet to fix the problem.
                let defTexCoords :: Path
defTexCoords =
                      ((GLfloat, GLfloat) -> (GLfloat, GLfloat)) -> Path -> Path
forall a b. (a -> b) -> [a] -> [b]
map
                        (\(GLfloat
x, GLfloat
y) -> (GLfloat
x GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width, GLfloat
y GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height))
                        [ (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (GLfloat, GLfloat)
toFloatVec (Int, Int)
imgSectionPos
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            (Int, Int) -> (GLfloat, GLfloat)
toFloatVec
                              ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize
                              , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos
                              )
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            (Int, Int) -> (GLfloat, GLfloat)
toFloatVec
                              ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize
                              , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize
                              )
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            (Int, Int) -> (GLfloat, GLfloat)
toFloatVec
                              ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos
                              , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize
                              )
                        ]
                        :: [(Float, Float)]
                    toFloatVec :: (Int, Int) -> (GLfloat, GLfloat)
toFloatVec = (Int -> GLfloat)
-> (Int -> GLfloat) -> (Int, Int) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    vecMap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)
                    vecMap :: forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap a -> c
f b -> d
g (a
x, b
y) = (a -> c
f a
x, b -> d
g b
y)
                    eps :: GLfloat
eps = GLfloat
0.001 :: Float
                in  case BitmapFormat -> RowOrder
rowOrder (BitmapData -> BitmapFormat
bitmapFormat BitmapData
imgData) of
                      RowOrder
BottomToTop -> Path
defTexCoords
                      RowOrder
TopToBottom -> Path -> Path
forall a. [a] -> [a]
reverse Path
defTexCoords

          -- Load the image data into a texture,
          -- or grab it from the cache if we've already done that before.
          Texture
tex <- IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture (State -> IORef [Texture]
stateTextures State
state) BitmapData
imgData Bool
cacheMe

          -- Set up wrap and filtering mode
          TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
GL.textureWrapMode TextureTarget2D
GL.Texture2D TextureCoordName
GL.S StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> m ()
$= (Repetition
GL.Repeated, Clamping
GL.Repeat)
          TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
GL.textureWrapMode TextureTarget2D
GL.Texture2D TextureCoordName
GL.T StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> m ()
$= (Repetition
GL.Repeated, Clamping
GL.Repeat)
          TextureTarget2D
-> StateVar (MinificationFilter, MagnificationFilter)
forall t.
ParameterizedTextureTarget t =>
t -> StateVar (MinificationFilter, MagnificationFilter)
GL.textureFilter TextureTarget2D
GL.Texture2D StateVar (MinificationFilter, MagnificationFilter)
-> (MinificationFilter, MagnificationFilter) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (MinificationFilter, MagnificationFilter)
-> (MinificationFilter, MagnificationFilter) -> m ()
$= ((MagnificationFilter
GL.Nearest, Maybe MagnificationFilter
forall a. Maybe a
Nothing), MagnificationFilter
GL.Nearest)

          -- Enable texturing
          TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
GL.texture TextureTarget2D
GL.Texture2D StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
          StateVar TextureFunction
GL.textureFunction StateVar TextureFunction -> TextureFunction -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar TextureFunction -> TextureFunction -> m ()
$= TextureFunction
GL.Combine

          -- Set current texture
          TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
GL.textureBinding TextureTarget2D
GL.Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Maybe TextureObject) -> Maybe TextureObject -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just (Texture -> TextureObject
texObject Texture
tex)

          -- Set to opaque
          Color4 GLfloat
oldColor <- StateVar (Color4 GLfloat) -> IO (Color4 GLfloat)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> m (Color4 GLfloat)
get StateVar (Color4 GLfloat)
GL.currentColor
          StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
1.0 GLfloat
1.0 GLfloat
1.0 GLfloat
1.0

          -- Draw textured polygon
          PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Polygon
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [((GLfloat, GLfloat), (GLfloat, GLfloat))]
-> (((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
              ( GLfloat -> GLfloat -> Path
bitmapPath
                  (Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLfloat) -> Int -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize)
                  (Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLfloat) -> Int -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize)
                  Path -> Path -> [((GLfloat, GLfloat), (GLfloat, GLfloat))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Path
rowInfo
              )
            ((((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ())
-> (((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((GLfloat
polygonCoordX, GLfloat
polygonCoordY), (GLfloat
textureCoordX, GLfloat
textureCoordY)) ->
              do
                TexCoord2 GLfloat -> IO ()
forall a. TexCoord a => a -> IO ()
GL.texCoord (TexCoord2 GLfloat -> IO ()) -> TexCoord2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> TexCoord2 GLfloat
forall a. a -> a -> TexCoord2 a
GL.TexCoord2 (GLfloat -> GLfloat
gf GLfloat
textureCoordX) (GLfloat -> GLfloat
gf GLfloat
textureCoordY)
                Vertex2 GLfloat -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 GLfloat -> IO ()) -> Vertex2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> Vertex2 GLfloat
forall a. a -> a -> Vertex2 a
GL.Vertex2 (GLfloat -> GLfloat
gf GLfloat
polygonCoordX) (GLfloat -> GLfloat
gf GLfloat
polygonCoordY)

          -- Restore color
          StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> Color4 GLfloat -> m ()
$= Color4 GLfloat
oldColor

          -- Disable texturing
          TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
GL.texture TextureTarget2D
GL.Texture2D StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled

          -- Free uncachable texture objects.
          Texture -> IO ()
freeTexture Texture
tex
    Pictures [Picture]
ps ->
      (Picture -> IO ()) -> [Picture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale) [Picture]
ps


-- Errors ---------------------------------------------------------------------
checkErrors :: String -> IO ()
checkErrors :: String -> IO ()
checkErrors String
place =
  do
    [Error]
errors <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
GettableStateVar [Error] -> m [Error]
get GettableStateVar [Error]
GLU.errors
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Error] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (Error -> IO ()) -> [Error] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Error -> IO ()
handleError String
place) [Error]
errors


handleError :: String -> GLU.Error -> IO ()
handleError :: String -> Error -> IO ()
handleError String
place Error
err =
  case Error
err of
    GLU.Error ErrorCategory
GLU.StackOverflow String
_ ->
      String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines
          [ String
"Brillo / OpenGL Stack Overflow " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
place
          , String
"  This program uses the Brillo vector graphics library, which tried to"
          , String
"  draw a picture using more nested transforms (Translate/Rotate/Scale)"
          , String
"  than your OpenGL implementation supports. The OpenGL spec requires"
          , String
"  all implementations to have a transform stack depth of at least 32,"
          , String
"  and Brillo tries not to push the stack when it doesn't have to, but"
          , String
"  that still wasn't enough."
          , String
""
          , String
"  You should complain to your harware vendor that they don't provide"
          , String
"  a better way to handle this situation at the OpenGL API level."
          , String
""
          , String
"  To make this program work you'll need to reduce the number of nested"
          , String
"  transforms used when defining the Picture given to Brillo. Sorry."
          ]
    Error
_ ->
      String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines
          [ String
"Brillo / OpenGL Internal Error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
place
          , String
"  Please report this at https://github.com/ad-si/Brillo/issues."
          , Error -> String
forall a. Show a => a -> String
show Error
err
          ]


-- Textures -------------------------------------------------------------------

{-| Load a texture into the OpenGL context, or retrieve the existing handle
  from our own cache.
-}
loadTexture
  :: IORef [Texture]
  -- ^ Existing texture cache.
  -> BitmapData
  -- ^ Texture data.
  -> Bool
  -- ^ Force cache for newly loaded textures.
  -> IO Texture
loadTexture :: IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture IORef [Texture]
refTextures imgData :: BitmapData
imgData@BitmapData{bitmapSize :: BitmapData -> (Int, Int)
bitmapSize = (Int
width, Int
height)} Bool
cacheMe =
  do
    [Texture]
textures <- IORef [Texture] -> IO [Texture]
forall a. IORef a -> IO a
readIORef IORef [Texture]
refTextures

    -- Try and find this same texture in the cache.
    StableName BitmapData
name <- BitmapData -> IO (StableName BitmapData)
forall a. a -> IO (StableName a)
makeStableName BitmapData
imgData
    let mTexCached :: Maybe Texture
mTexCached =
          (Texture -> Bool) -> [Texture] -> Maybe Texture
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
            ( \Texture
tex ->
                Texture -> StableName BitmapData
texName Texture
tex StableName BitmapData -> StableName BitmapData -> Bool
forall a. Eq a => a -> a -> Bool
== StableName BitmapData
name
                  Bool -> Bool -> Bool
&& Texture -> Int
texWidth Texture
tex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width
                  Bool -> Bool -> Bool
&& Texture -> Int
texHeight Texture
tex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
height
            )
            [Texture]
textures

    case Maybe Texture
mTexCached of
      Just Texture
tex ->
        Texture -> IO Texture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
tex
      Maybe Texture
Nothing ->
        do
          Texture
tex <- BitmapData -> IO Texture
installTexture BitmapData
imgData
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cacheMe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IORef [Texture] -> [Texture] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Texture]
refTextures (Texture
tex Texture -> [Texture] -> [Texture]
forall a. a -> [a] -> [a]
: [Texture]
textures)
          Texture -> IO Texture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
tex


{-| Install a texture into the OpenGL context,
  returning the new texture handle.
-}
installTexture :: BitmapData -> IO Texture
installTexture :: BitmapData -> IO Texture
installTexture bitmapData :: BitmapData
bitmapData@(BitmapData Int
_ BitmapFormat
fmt (Int
width, Int
height) Bool
cacheMe ForeignPtr Word8
fptr) =
  do
    let glFormat :: PixelFormat
glFormat =
          case BitmapFormat -> PixelFormat
pixelFormat BitmapFormat
fmt of
            PixelFormat
PxABGR -> PixelFormat
GL.ABGR
            PixelFormat
PxRGBA -> PixelFormat
GL.RGBA

    -- Allocate texture handle for texture
    [TextureObject
tex] <- Int -> IO [TextureObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
forall (m :: * -> *). MonadIO m => Int -> m [TextureObject]
GL.genObjectNames Int
1
    TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
GL.textureBinding TextureTarget2D
GL.Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Maybe TextureObject) -> Maybe TextureObject -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
tex

    -- Sets the texture in imgData as the current texture
    -- This copies the data from the pointer into OpenGL texture memory,
    -- so it's ok if the foreignptr gets garbage collected after this.
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \Ptr Word8
ptr ->
        TextureTarget2D
-> Proxy
-> Level
-> PixelInternalFormat
-> TextureSize2D
-> Level
-> PixelData Word8
-> IO ()
forall t a.
TwoDimensionalTextureTarget t =>
t
-> Proxy
-> Level
-> PixelInternalFormat
-> TextureSize2D
-> Level
-> PixelData a
-> IO ()
GL.texImage2D
          TextureTarget2D
GL.Texture2D
          Proxy
GL.NoProxy
          Level
0
          PixelInternalFormat
GL.RGBA8
          ( Level -> Level -> TextureSize2D
GL.TextureSize2D
              (Int -> Level
gsizei Int
width)
              (Int -> Level
gsizei Int
height)
          )
          Level
0
          (PixelFormat -> DataType -> Ptr Word8 -> PixelData Word8
forall a. PixelFormat -> DataType -> Ptr a -> PixelData a
GL.PixelData PixelFormat
glFormat DataType
GL.UnsignedByte Ptr Word8
ptr)

    -- Make a stable name that we can use to identify this data again.
    -- If the user gives us the same texture data at the same size then we
    -- can avoid loading it into texture memory again.
    StableName BitmapData
name <- BitmapData -> IO (StableName BitmapData)
forall a. a -> IO (StableName a)
makeStableName BitmapData
bitmapData

    Texture -> IO Texture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      Texture
        { texName :: StableName BitmapData
texName = StableName BitmapData
name
        , texWidth :: Int
texWidth = Int
width
        , texHeight :: Int
texHeight = Int
height
        , texData :: ForeignPtr Word8
texData = ForeignPtr Word8
fptr
        , texObject :: TextureObject
texObject = TextureObject
tex
        , texCacheMe :: Bool
texCacheMe = Bool
cacheMe
        }


{-| If this texture does not have its `cacheMe` flag set then delete it from
  OpenGL and free the GPU memory.
-}
freeTexture :: Texture -> IO ()
freeTexture :: Texture -> IO ()
freeTexture Texture
tex
  | Texture -> Bool
texCacheMe Texture
tex = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = [TextureObject] -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => [a] -> m ()
forall (m :: * -> *). MonadIO m => [TextureObject] -> m ()
GL.deleteObjectNames [Texture -> TextureObject
texObject Texture
tex]


-- Utils ----------------------------------------------------------------------

-- | Turn alpha blending on or off
setBlendAlpha :: Bool -> IO ()
setBlendAlpha :: Bool -> IO ()
setBlendAlpha Bool
state
  | Bool
state =
      do
        StateVar Capability
GL.blend StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
        StateVar (BlendingFactor, BlendingFactor)
GL.blendFunc StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> m ()
$= (BlendingFactor
GL.SrcAlpha, BlendingFactor
GL.OneMinusSrcAlpha)
  | Bool
otherwise =
      do
        StateVar Capability
GL.blend StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled
        StateVar (BlendingFactor, BlendingFactor)
GL.blendFunc StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> m ()
$= (BlendingFactor
GL.One, BlendingFactor
GL.Zero)


-- | Turn line smoothing on or off
setLineSmooth :: Bool -> IO ()
setLineSmooth :: Bool -> IO ()
setLineSmooth Bool
state
  | Bool
state = StateVar Capability
GL.lineSmooth StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
  | Bool
otherwise = StateVar Capability
GL.lineSmooth StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled


vertexPFs :: [(Float, Float)] -> IO ()
vertexPFs :: Path -> IO ()
vertexPFs [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
vertexPFs ((GLfloat
x, GLfloat
y) : Path
rest) =
  do
    Vertex2 GLfloat -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 GLfloat -> IO ()) -> Vertex2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> Vertex2 GLfloat
forall a. a -> a -> Vertex2 a
GL.Vertex2 (GLfloat -> GLfloat
gf GLfloat
x) (GLfloat -> GLfloat
gf GLfloat
y)
    Path -> IO ()
vertexPFs Path
rest
{-# INLINE vertexPFs #-}