{-# 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)
renderPicture
:: State
-> Float
-> Picture
-> IO ()
renderPicture :: State -> GLfloat -> Picture -> IO ()
renderPicture State
state GLfloat
circScale Picture
picture =
do
Bool -> IO ()
setLineSmooth (State -> Bool
stateLineSmooth State
state)
Bool -> IO ()
setBlendAlpha (State -> Bool
stateBlendAlpha State
state)
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
Picture
Blank ->
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 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 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 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
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
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
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
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 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 =
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
Texture
tex <- IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture (State -> IORef [Texture]
stateTextures State
state) BitmapData
imgData Bool
cacheMe
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)
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
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)
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
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)
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
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
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
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
]
loadTexture
:: IORef [Texture]
-> BitmapData
-> Bool
-> 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
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
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
[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
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)
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
}
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]
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)
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 #-}