diff --git a/Brillo/Internals/Data/Color.hs b/Brillo/Internals/Data/Color.hs --- a/Brillo/Internals/Data/Color.hs +++ b/Brillo/Internals/Data/Color.hs @@ -69,16 +69,16 @@ -- | Make a custom color. All components are clamped to the range [0..1]. -makeColor - :: Float - -- ^ Red component. - -> Float - -- ^ Green component. - -> Float - -- ^ Blue component. - -> Float - -- ^ Alpha component. - -> Color +makeColor :: + -- | Red component. + Float -> + -- | Green component. + Float -> + -- | Blue component. + Float -> + -- | Alpha component. + Float -> + Color makeColor r g b a = clampColor $ RGBA r g b a diff --git a/Brillo/Internals/Data/Picture.hs b/Brillo/Internals/Data/Picture.hs --- a/Brillo/Internals/Data/Picture.hs +++ b/Brillo/Internals/Data/Picture.hs @@ -11,11 +11,10 @@ -- * Bitmaps Rectangle (..), - BitmapData, + BitmapData (..), PixelFormat (..), BitmapFormat (..), RowOrder (..), - bitmapSize, bitmapOfForeignPtr, bitmapDataOfForeignPtr, bitmapOfByteString, @@ -29,7 +28,7 @@ import Brillo.Internals.Data.Color (Color) import Brillo.Internals.Rendering.Bitmap ( - BitmapData (BitmapData, bitmapSize), + BitmapData (..), BitmapFormat (..), PixelFormat (..), Rectangle (..), @@ -39,6 +38,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Unsafe qualified as BSU import Data.Data (Data, Typeable) +import Data.Text (Text) import Data.Word (Word8) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr) import Foreign.Marshal.Alloc (finalizerFree, mallocBytes) @@ -72,29 +72,66 @@ -- | A blank picture, with nothing in it. Blank - | -- | A convex polygon filled with a solid color. + | -- | A polygon filled with a solid color, drawn with anti-aliased edges. Polygon Path - | -- | A line along an arbitrary path. + | -- | A polygon filled with a solid color, drawn without anti-aliasing. + PolygonAliased Path + | -- | A line along an arbitrary path, drawn with anti-aliasing. Line Path - | -- | A circle with the given radius. + | -- | A line along an arbitrary path, drawn without anti-aliasing. + LineAliased Path + | -- | A line along an arbitrary path with a given thickness, drawn with anti-aliasing. + ThickLine Path Float + | -- | A line along an arbitrary path with a given thickness, drawn without anti-aliasing. + ThickLineAliased Path Float + | -- | A circle with the given radius, drawn with anti-aliasing. Circle Float - | -- | A circle with the given radius and thickness. - -- If the thickness is 0 then this is equivalent to `Circle`. + | -- | A circle with the given radius, drawn without anti-aliasing. + CircleAliased Float + | {-| A circle with the given radius and thickness, drawn with anti-aliasing. + If the thickness is 0 then this is equivalent to `Circle`. + -} ThickCircle Float Float - | -- | A circular arc drawn counter-clockwise between two angles - -- (in degrees) at the given radius. + | {-| A circle with the given radius and thickness, drawn without anti-aliasing. + If the thickness is 0 then this is equivalent to `CircleAliased`. + -} + ThickCircleAliased Float Float + | {-| A circular arc drawn counter-clockwise between two angles + (in degrees) at the given radius, drawn with anti-aliasing. + -} Arc Float Float Float - | -- | A circular arc drawn counter-clockwise between two angles - -- (in degrees), with the given radius and thickness. - -- If the thickness is 0 then this is equivalent to `Arc`. + | {-| A circular arc drawn counter-clockwise between two angles + (in degrees) at the given radius, drawn without anti-aliasing. + -} + ArcAliased Float Float Float + | {-| A circular arc drawn counter-clockwise between two angles + (in degrees), with the given radius and thickness, drawn with anti-aliasing. + If the thickness is 0 then this is equivalent to `Arc`. + -} ThickArc Float Float Float Float - | -- | Text to draw with a vector font - Text String + | {-| A circular arc drawn counter-clockwise between two angles + (in degrees), with the given radius and thickness, drawn without anti-aliasing. + If the thickness is 0 then this is equivalent to `ArcAliased`. + -} + ThickArcAliased Float Float Float Float + | -- | Text to draw with a vector font, drawn with anti-aliasing. + Text Text + | -- | Text to draw with a vector font, drawn without anti-aliasing. + TextAliased Text + | -- | Text to draw with a vector font and a given thickness, drawn with anti-aliasing. + ThickText Text Float + | -- | Text to draw with a vector font and a given thickness, drawn without anti-aliasing. + ThickTextAliased Text Float + | {-| Text to draw with a TrueType font located at the given path, + rendered at the specified pixel height. + -} + TrueTypeText FilePath Int Text | -- | A bitmap image. Bitmap BitmapData - | -- | A subsection of a bitmap image where - -- the first argument selects a sub section in the bitmap, - -- and second argument determines the bitmap data. + | {-| A subsection of a bitmap image where + the first argument selects a sub section in the bitmap, + and second argument determines the bitmap data. + -} BitmapSection Rectangle BitmapData | -- Color ------------------------------------------ @@ -138,7 +175,8 @@ the image for each frame then use `False`. If you have loaded it from a file then use `True`. -} -bitmapOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture +bitmapOfForeignPtr :: + Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture bitmapOfForeignPtr width height fmt fptr cacheMe = Bitmap $ bitmapDataOfForeignPtr width height fmt fptr cacheMe @@ -146,7 +184,8 @@ -- Bitmap width height (bitmapDataOfForeignPtr width height fmt fptr) cacheMe -bitmapDataOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> BitmapData +bitmapDataOfForeignPtr :: + Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> BitmapData bitmapDataOfForeignPtr width height fmt fptr cacheMe = let len = width * height * 4 in BitmapData len fmt (width, height) cacheMe fptr @@ -160,13 +199,15 @@ the image for each frame then use `False`. If you have loaded it from a file then use `True`. -} -bitmapOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture +bitmapOfByteString :: + Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture bitmapOfByteString width height fmt bs cacheMe = Bitmap $ bitmapDataOfByteString width height fmt bs cacheMe -bitmapDataOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData +bitmapDataOfByteString :: + Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData bitmapDataOfByteString width height fmt bs cacheMe = unsafePerformIO $ do @@ -202,7 +243,8 @@ BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len - return $ BitmapData len (BitmapFormat BottomToTop PxRGBA) (width, height) True fptr + return $ + BitmapData len (BitmapFormat BottomToTop PxRGBA) (width, height) True fptr {-# NOINLINE bitmapDataOfBMP #-} diff --git a/Brillo/Internals/Rendering/Circle.hs b/Brillo/Internals/Rendering/Circle.hs --- a/Brillo/Internals/Rendering/Circle.hs +++ b/Brillo/Internals/Rendering/Circle.hs @@ -5,7 +5,9 @@ -- | Fast(ish) rendering of circles. module Brillo.Internals.Rendering.Circle ( renderCircle, + renderCircleSmooth, renderArc, + renderArcSmooth, ) where @@ -20,9 +22,16 @@ sinFloat#, timesFloat#, ) +import Graphics.Rendering.OpenGL (($=)) import Graphics.Rendering.OpenGL.GL qualified as GL +-- | Tau = 2 * pi, the ratio of circumference to radius +tau :: Float +tau = 2 * pi +{-# INLINE tau #-} + + ------------------------------------------------------------------------------- {-| Decide how many line segments to use to render the circle. @@ -69,8 +78,8 @@ renderCircleLine :: Float -> Float -> Int -> Float -> IO () renderCircleLine (F# posX) (F# posY) steps (F# rad) = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStop) = (2 * pi) + !(F# tStep) = tau / n + !(F# tStop) = tau in GL.renderPrimitive GL.LineLoop $ renderCircleLineStep posX posY tStep tStop rad 0.0# {-# INLINE renderCircleLine #-} @@ -80,8 +89,8 @@ renderCircleStrip :: Float -> Float -> Int -> Float -> Float -> IO () renderCircleStrip (F# posX) (F# posY) steps r width = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStop) = (2 * pi) + F# tStep / 2 + !(F# tStep) = tau / n + !(F# tStop) = tau + F# tStep / 2 !(F# r1) = r - width / 2 !(F# r2) = r + width / 2 in GL.renderPrimitive GL.TriangleStrip $ @@ -97,11 +106,100 @@ {-# INLINE renderCircleStrip #-} +-- | Render a ring with given inner and outer radii as a triangle strip +renderCircleStripRadii :: Float -> Float -> Int -> Float -> Float -> IO () +renderCircleStripRadii (F# posX) (F# posY) steps innerR outerR = + let n = fromIntegral steps + !(F# tStep) = tau / n + !(F# tStop) = tau + F# tStep / 2 + !(F# r1) = innerR + !(F# r2) = outerR + in GL.renderPrimitive GL.TriangleStrip $ + renderCircleStripStep + posX + posY + tStep + tStop + r1 + 0.0# + r2 + (tStep `divideFloat#` 2.0#) +{-# INLINE renderCircleStripRadii #-} + + +{-| Render a circle with the given thickness, with anti-aliasing. + Draws filled shape slightly inset, then anti-aliased edge on boundary. +-} +renderCircleSmooth :: Float -> Float -> Float -> Float -> Float -> IO () +renderCircleSmooth posX posY scaleFactor radius_ thickness_ = + go (abs radius_) (abs thickness_) + where + go radius thickness + -- If the circle is smaller than a pixel, render it as a point. + | thickness == 0 + , radScreen <- scaleFactor * (radius + thickness / 2) + , radScreen <= 1 = + GL.renderPrimitive GL.Points $ + GL.vertex $ + GL.Vertex2 (gf posX) (gf posY) + -- Render zero thickness circles with smoothed lines. + | thickness == 0 + , radScreen <- scaleFactor * radius + , steps <- circleSteps radScreen = + do + GL.lineSmooth $= GL.Enabled + renderCircleLine posX posY steps radius + GL.lineSmooth $= GL.Disabled + -- Solid circle (no inner hole): draw fill then smooth edge on top + | radius - thickness / 2 <= 0 + , radScreen <- scaleFactor * (radius + thickness / 2) + , steps <- circleSteps radScreen * 2 -- More segments for smoother result + = + do + let outerRadius = radius + thickness / 2 + -- Draw fill at full size + renderCircleFan posX posY steps outerRadius + -- Draw anti-aliased edge at exact boundary + GL.lineSmooth $= GL.Enabled + renderCircleLine posX posY steps outerRadius + GL.lineSmooth $= GL.Disabled + -- Thick circle with inner hole: draw fill then smooth edges on top + | radScreen <- scaleFactor * (radius + thickness / 2) + , steps <- circleSteps radScreen * 2 -- More segments for smoother result + = + do + let outerRadius = radius + thickness / 2 + let innerRadius = radius - thickness / 2 + -- Draw fill at full size + renderCircleStripRadii posX posY steps innerRadius outerRadius + -- Draw anti-aliased edges at exact boundaries + GL.lineSmooth $= GL.Enabled + renderCircleLine posX posY steps outerRadius + renderCircleLine posX posY steps innerRadius + GL.lineSmooth $= GL.Disabled + + +-- | Render a filled circle as a triangle fan +renderCircleFan :: Float -> Float -> Int -> Float -> IO () +renderCircleFan (F# posX) (F# posY) steps (F# rad) = + let n = fromIntegral steps + !(F# tStep) = tau / n + !(F# tStop) = tau + in GL.renderPrimitive GL.TriangleFan $ do + -- Center vertex + GL.vertex $ GL.Vertex2 (gf (F# posX)) (gf (F# posY)) + -- Edge vertices + renderCircleLineStep posX posY tStep tStop rad 0.0# + -- Close the fan by repeating the first edge vertex + addPointOnCircle posX posY rad 0.0# +{-# INLINE renderCircleFan #-} + + -- Arc ------------------------------------------------------------------------ -- | Render an arc with the given thickness. -renderArc - :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () +renderArc :: + Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () renderArc posX posY scaleFactor radius_ a1 a2 thickness_ = go (abs radius_) (abs thickness_) where @@ -117,14 +215,60 @@ renderArcStrip posX posY steps radius a1 a2 thickness +{-| Render an arc with the given thickness, with anti-aliasing. + Draws filled shape slightly inset, then anti-aliased edge on boundary. +-} +renderArcSmooth :: + Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () +renderArcSmooth posX posY scaleFactor radius_ a1 a2 thickness_ = + go (abs radius_) (abs thickness_) + where + go radius thickness + -- Render zero thickness arcs with smoothed lines. + | thickness == 0 + , radScreen <- scaleFactor * radius + , steps <- circleSteps radScreen = + do + GL.lineSmooth $= GL.Enabled + renderArcLine posX posY steps radius a1 a2 + GL.lineSmooth $= GL.Disabled + -- Solid arc (no inner hole): draw fill then smooth edge on top + | radius - thickness / 2 <= 0 + , radScreen <- scaleFactor * (radius + thickness / 2) + , steps <- circleSteps radScreen * 2 -- More segments for smoother result + = + do + let outerRadius = radius + thickness / 2 + -- Draw fill at full size + renderArcFan posX posY steps outerRadius a1 a2 + -- Draw anti-aliased edge at exact boundary + GL.lineSmooth $= GL.Enabled + renderArcLine posX posY steps outerRadius a1 a2 + GL.lineSmooth $= GL.Disabled + -- Thick arc with inner hole: draw fill then smooth edges on top + | radScreen <- scaleFactor * (radius + thickness / 2) + , steps <- circleSteps radScreen * 2 -- More segments for smoother result + = + do + let outerRadius = radius + thickness / 2 + let innerRadius = radius - thickness / 2 + -- Draw fill at full size + renderArcStripRadii posX posY steps innerRadius outerRadius a1 a2 + -- Draw anti-aliased edges at exact boundaries + GL.lineSmooth $= GL.Enabled + renderArcLine posX posY steps outerRadius a1 a2 + renderArcLine posX posY steps innerRadius a1 a2 + GL.lineSmooth $= GL.Disabled + + -- | Render an arc as a line. -renderArcLine - :: Float -> Float -> Int -> Float -> Float -> Float -> IO () +renderArcLine :: + Float -> Float -> Int -> Float -> Float -> Float -> IO () renderArcLine (F# posX) (F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n + !(F# tStep) = tau / n !(F# tStart) = degToRad a1 - !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 + !(F# tStop) = degToRad a2 + if a1 >= a2 then tau else 0 -- force the line to end at the desired angle endVertex = addPointOnCircle posX posY rad tStop @@ -135,19 +279,32 @@ {-# INLINE renderArcLine #-} --- | Render an arc with a given thickness as a triangle strip -renderArcStrip - :: Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () -renderArcStrip (F# posX) (F# posY) steps r a1 a2 width = +-- | Render a filled arc (pie slice) as a triangle fan from center +renderArcFan :: Float -> Float -> Int -> Float -> Float -> Float -> IO () +renderArcFan (F# posX) (F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps - tStep = (2 * pi) / n + !(F# tStep) = tau / n + !(F# tStart) = degToRad a1 + !(F# tStop) = degToRad a2 + if a1 >= a2 then tau else 0 + in GL.renderPrimitive GL.TriangleFan $ do + -- Center vertex + GL.vertex $ GL.Vertex2 (gf (F# posX)) (gf (F# posY)) + -- Edge vertices along the arc + renderCircleLineStep posX posY tStep tStop rad tStart + -- Final vertex at exact end angle + addPointOnCircle posX posY rad tStop +{-# INLINE renderArcFan #-} - t1 = normalizeAngle $ degToRad a1 - a2' = normalizeAngle $ degToRad a2 - t2 = if a2' == 0 then 2 * pi else a2' +-- | Render an arc with a given thickness as a triangle strip +renderArcStrip :: + Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () +renderArcStrip (F# posX) (F# posY) steps r a1 a2 width = + let n = fromIntegral steps + tStep = tau / n - (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1) + tStart = degToRad a1 + tStop = degToRad a2 + if a1 >= a2 then tau else 0 tDiff = tStop - tStart tMid = tStart + tDiff / 2 @@ -191,15 +348,67 @@ {-# INLINE renderArcStrip #-} +-- | Render an arc with given inner and outer radii as a triangle strip +renderArcStripRadii :: + Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () +renderArcStripRadii (F# posX) (F# posY) steps innerR outerR a1 a2 = + let n = fromIntegral steps + tStep = tau / n + + tStart = degToRad a1 + tStop = degToRad a2 + if a1 >= a2 then tau else 0 + tDiff = tStop - tStart + tMid = tStart + tDiff / 2 + + !(F# tStep') = tStep + !(F# tStep2') = tStep / 2 + !(F# tStart') = tStart + !(F# tStop') = tStop + !(F# tCut') = tStop - tStep + !(F# tMid') = tMid + !(F# r1') = innerR + !(F# r2') = outerR + in GL.renderPrimitive GL.TriangleStrip $ + do + -- start vector + addPointOnCircle posX posY r1' tStart' + addPointOnCircle posX posY r2' tStart' + + -- If we don't have a complete step then just drop a point + -- between the two ending lines. + if tDiff < tStep + then do + addPointOnCircle posX posY r1' tMid' + + -- end vectors + addPointOnCircle posX posY r2' tStop' + addPointOnCircle posX posY r1' tStop' + else do + renderCircleStripStep + posX + posY + tStep' + tCut' + r1' + tStart' + r2' + (tStart' `plusFloat#` tStep2') + + -- end vectors + addPointOnCircle posX posY r1' tStop' + addPointOnCircle posX posY r2' tStop' +{-# INLINE renderArcStripRadii #-} + + -- Step functions ------------------------------------------------------------- -renderCircleLineStep - :: Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> IO () +renderCircleLineStep :: + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + IO () renderCircleLineStep posX posY tStep tStop rad tt | 1# <- tt `geFloat#` tStop = return () @@ -216,16 +425,16 @@ {-# INLINE renderCircleLineStep #-} -renderCircleStripStep - :: Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> Float# - -> IO () +renderCircleStripStep :: + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + Float# -> + IO () renderCircleStripStep posX posY tStep tStop r1 t1 r2 t2 | 1# <- t1 `geFloat#` tStop = return () @@ -264,15 +473,6 @@ degToRad d = d * pi / 180 {-# INLINE degToRad #-} - --- | Normalise an angle to be between 0 and 2*pi radians -normalizeAngle :: Float -> Float -normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) - where - floor' :: Float -> Float - floor' x = fromIntegral (floor x :: Int) -{-# INLINE normalizeAngle #-} - {- Unused sector drawing code. Sectors are currently drawn as compound Pictures, but we might want this if we end up implementing the ThickSector @@ -282,9 +482,9 @@ renderSectorLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () renderSectorLine pX@(F# posX) pY@(F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n + !(F# tStep) = tau / n !(F# tStart) = degToRad a1 - !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 + !(F# tStop) = degToRad a2 + if a1 >= a2 then tau else 0 -- need to set up the edges of the start/end triangles startVertex = GL.vertex $ GL.Vertex2 (gf pX) (gf pY) diff --git a/Brillo/Internals/Rendering/Common.hs b/Brillo/Internals/Rendering/Common.hs --- a/Brillo/Internals/Rendering/Common.hs +++ b/Brillo/Internals/Rendering/Common.hs @@ -36,12 +36,12 @@ {-| Set up the OpenGL rendering context for orthographic projection and run an action to draw the model. -} -withModelview - :: (Int, Int) - -- ^ Width and height of window. - -> IO () - -- ^ Action to perform. - -> IO () +withModelview :: + -- | Width and height of window. + (Int, Int) -> + -- | Action to perform. + IO () -> + IO () withModelview (sizeX, sizeY) action = do GL.matrixMode $= GL.Projection @@ -64,12 +64,12 @@ {-| Clear the OpenGL buffer with the given background color and run an action to draw the model. -} -withClearBuffer - :: Color - -- ^ Background color - -> IO () - -- ^ Action to perform - -> IO () +withClearBuffer :: + -- | Background color + Color -> + -- | Action to perform + IO () -> + IO () withClearBuffer clearColor action = do -- initialization (done every time in this case) diff --git a/Brillo/Internals/Rendering/Picture.hs b/Brillo/Internals/Rendering/Picture.hs --- a/Brillo/Internals/Rendering/Picture.hs +++ b/Brillo/Internals/Rendering/Picture.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_HADDOCK hide #-} @@ -12,9 +13,11 @@ import Data.IORef (IORef, readIORef, writeIORef) import Data.List (find) import Foreign.ForeignPtr (withForeignPtr) +import GHC.IO.StdHandles (stderr) import Graphics.Rendering.OpenGL (get, ($=)) import Graphics.Rendering.OpenGL.GL qualified as GL import Graphics.Rendering.OpenGL.GLU.Errors qualified as GLU +import System.IO (hPutStrLn) import System.Mem.StableName (makeStableName) import Brillo.Internals.Data.Color (Color (RGBA)) @@ -27,18 +30,32 @@ rectAtOrigin, ) import Brillo.Internals.Rendering.Bitmap (BitmapData (..), bitmapPath) -import Brillo.Internals.Rendering.Circle (renderArc, renderCircle) +import Brillo.Internals.Rendering.Circle ( + renderArc, + renderCircle, + ) import Brillo.Internals.Rendering.Common (gf, gsizei) +import Brillo.Internals.Rendering.Polygon ( + renderComplexPolygon, + renderComplexPolygonSmooth, + ) +import Brillo.Internals.Rendering.Shader ( + renderArcSDF, + renderCircleSDF, + renderThickLineSDF, + ) import Brillo.Internals.Rendering.State ( State ( stateBlendAlpha, stateColor, stateLineSmooth, + stateShaders, stateTextures, stateWireframe ), Texture (..), ) +import Brillo.Internals.Rendering.TrueTypeFont (renderTrueTypeText) import Brillo.Internals.Rendering.VectorFont as VF (canvastextFont, renderSafe) @@ -46,20 +63,21 @@ 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 :: + -- | Current rendering state. + State -> + {-| View port scale, which controls the level of detail. + Use 1.0 to start with. + -} + Float -> + -- | Picture to render. + Picture -> + IO () renderPicture state circScale picture = do -- Setup render state for world - setLineSmooth (stateLineSmooth state) - setBlendAlpha (stateBlendAlpha state) + setLineSmooth state.stateLineSmooth + setBlendAlpha state.stateBlendAlpha -- Draw the picture checkErrors "before drawPicture." @@ -71,30 +89,69 @@ drawPicture state circScale picture = {-# SCC "drawComponent" #-} case picture of - -- nothin' + -- Blank -> return () - -- line - Line path -> + -- + Line path -> do + GL.lineSmooth $= GL.Enabled GL.renderPrimitive GL.LineStrip $ vertexPFs path - -- polygon (where?) + GL.lineSmooth $= GL.Disabled + -- + LineAliased path -> + GL.renderPrimitive GL.LineStrip $ + vertexPFs path + -- + ThickLine path thickness -> + renderThickLineSmoothSDF state 0 0 circScale path thickness + -- + ThickLineAliased path thickness -> do + widthRange <- GL.aliasedLineWidthRange + when (thickness < fst widthRange || thickness > snd widthRange) $ + hPutStrLn stderr $ + "Error: The line width " + <> show thickness + <> " is outside the supported range of " + <> show widthRange + + oldLineWidth <- get GL.lineWidth + GL.lineWidth $= gf thickness + GL.renderPrimitive GL.LineStrip $ vertexPFs path + GL.lineWidth $= oldLineWidth + -- Polygon path - | stateWireframe state -> + | state.stateWireframe -> do + GL.lineSmooth $= GL.Enabled GL.renderPrimitive GL.LineLoop $ vertexPFs path + GL.lineSmooth $= GL.Disabled | otherwise -> - GL.renderPrimitive GL.Polygon $ + renderComplexPolygonSmooth path + -- + PolygonAliased path + | state.stateWireframe -> + GL.renderPrimitive GL.LineLoop $ vertexPFs path + | otherwise -> + renderComplexPolygon path -- circle Circle radius -> + renderCircleSmoothSDF state 0 0 circScale radius 0 + CircleAliased radius -> renderCircle 0 0 circScale radius 0 ThickCircle radius thickness -> + renderCircleSmoothSDF state 0 0 circScale radius thickness + ThickCircleAliased radius thickness -> renderCircle 0 0 circScale radius thickness -- arc Arc a1 a2 radius -> + renderArcSmoothSDF state 0 0 circScale radius a1 a2 0 + ArcAliased a1 a2 radius -> renderArc 0 0 circScale radius a1 a2 0 ThickArc a1 a2 radius thickness -> + renderArcSmoothSDF state 0 0 circScale radius a1 a2 thickness + ThickArcAliased a1 a2 radius thickness -> renderArc 0 0 circScale radius a1 a2 thickness -- Vector font text Text str -> do @@ -102,16 +159,69 @@ characters :: [[(Double, Double)]] characters = renderSafe canvastextFont str + oldLineWidth <- get GL.lineWidth + GL.lineWidth $= gf 3.0 + GL.lineSmooth $= GL.Enabled GL.preservingMatrix $ do GL.scale (gf 5) (gf 5) 0 forM_ characters $ \stroke -> do GL.renderPrimitive GL.LineStrip $ do forM_ stroke $ \(x, y) -> do GL.vertex $ GL.Vertex2 x y + GL.lineSmooth $= GL.Disabled + GL.lineWidth $= oldLineWidth + -- + TextAliased str -> do + let + characters :: [[(Double, Double)]] + characters = renderSafe canvastextFont str + oldLineWidth <- get GL.lineWidth + GL.lineWidth $= gf 3.0 + GL.preservingMatrix $ do + GL.scale (gf 5) (gf 5) 0 + forM_ characters $ \stroke -> do + GL.renderPrimitive GL.LineStrip $ do + forM_ stroke $ \(x, y) -> do + GL.vertex $ GL.Vertex2 x y + GL.lineWidth $= oldLineWidth + -- + ThickText str thickness -> do + let + characters :: [[(Double, Double)]] + characters = renderSafe canvastextFont str + + oldLineWidth <- get GL.lineWidth + GL.lineWidth $= gf thickness + GL.lineSmooth $= GL.Enabled + GL.preservingMatrix $ do + GL.scale (gf 5) (gf 5) 0 + forM_ characters $ \stroke -> do + GL.renderPrimitive GL.LineStrip $ do + forM_ stroke $ \(x, y) -> do + GL.vertex $ GL.Vertex2 x y + GL.lineSmooth $= GL.Disabled + GL.lineWidth $= oldLineWidth + -- + ThickTextAliased str thickness -> do + let + characters :: [[(Double, Double)]] + characters = renderSafe canvastextFont str + + oldLineWidth <- get GL.lineWidth + GL.lineWidth $= gf thickness + GL.preservingMatrix $ do + GL.scale (gf 5) (gf 5) 0 + forM_ characters $ \stroke -> do + GL.renderPrimitive GL.LineStrip $ do + forM_ stroke $ \(x, y) -> do + GL.vertex $ GL.Vertex2 x y + GL.lineWidth $= oldLineWidth + TrueTypeText fontPath pixelHeight str -> + renderTrueTypeText fontPath pixelHeight str -- colors with float components. Color col p - | stateColor state -> do + | state.stateColor -> do oldColor <- get GL.currentColor let RGBA r g b a = col @@ -124,12 +234,20 @@ -- Translation -------------------------- -- Easy translations are done directly to avoid calling GL.perserveMatrix. Translate posX posY (Circle radius) -> + renderCircleSmoothSDF state posX posY circScale radius 0 + Translate posX posY (CircleAliased radius) -> renderCircle posX posY circScale radius 0 Translate posX posY (ThickCircle radius thickness) -> + renderCircleSmoothSDF state posX posY circScale radius thickness + Translate posX posY (ThickCircleAliased radius thickness) -> renderCircle posX posY circScale radius thickness Translate posX posY (Arc a1 a2 radius) -> + renderArcSmoothSDF state posX posY circScale radius a1 a2 0 + Translate posX posY (ArcAliased a1 a2 radius) -> renderArc posX posY circScale radius a1 a2 0 Translate posX posY (ThickArc a1 a2 radius thickness) -> + renderArcSmoothSDF state posX posY circScale radius a1 a2 thickness + Translate posX posY (ThickArcAliased a1 a2 radius thickness) -> renderArc posX posY circScale radius a1 a2 thickness Translate tx ty (Rotate deg p) -> GL.preservingMatrix $ @@ -146,12 +264,20 @@ -- Rotation ----------------------------- -- Easy rotations are done directly to avoid calling GL.perserveMatrix. Rotate _ (Circle radius) -> + renderCircleSmoothSDF state 0 0 circScale radius 0 + Rotate _ (CircleAliased radius) -> renderCircle 0 0 circScale radius 0 Rotate _ (ThickCircle radius thickness) -> + renderCircleSmoothSDF state 0 0 circScale radius thickness + Rotate _ (ThickCircleAliased radius thickness) -> renderCircle 0 0 circScale radius thickness Rotate deg (Arc a1 a2 radius) -> + renderArcSmoothSDF state 0 0 circScale radius (a1 - deg) (a2 - deg) 0 + Rotate deg (ArcAliased a1 a2 radius) -> renderArc 0 0 circScale radius (a1 - deg) (a2 - deg) 0 Rotate deg (ThickArc a1 a2 radius thickness) -> + renderArcSmoothSDF state 0 0 circScale radius (a1 - deg) (a2 - deg) thickness + Rotate deg (ThickArcAliased a1 a2 radius thickness) -> renderArc 0 0 circScale radius (a1 - deg) (a2 - deg) thickness Rotate deg p -> GL.preservingMatrix $ @@ -208,8 +334,8 @@ ( fst imgSectionPos , snd imgSectionPos + snd imgSectionSize ) - ] - :: [(Float, Float)] + ] :: + [(Float, Float)] toFloatVec = vecMap fromIntegral fromIntegral vecMap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d) vecMap f g (x, y) = (f x, g y) @@ -220,7 +346,7 @@ -- Load the image data into a texture, -- or grab it from the cache if we've already done that before. - tex <- loadTexture (stateTextures state) imgData cacheMe + tex <- loadTexture state.stateTextures imgData cacheMe -- Set up wrap and filtering mode GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) @@ -306,14 +432,14 @@ {-| 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 :: + -- | Existing texture cache. + IORef [Texture] -> + -- | Texture data. + BitmapData -> + -- | Force cache for newly loaded textures. + Bool -> + IO Texture loadTexture refTextures imgData@BitmapData{bitmapSize = (width, height)} cacheMe = do textures <- readIORef refTextures @@ -426,3 +552,34 @@ GL.vertex $ GL.Vertex2 (gf x) (gf y) vertexPFs rest {-# INLINE vertexPFs #-} + + +-- SDF-based rendering helpers ------------------------------------------------ + +-- | Render a smooth circle using SDF shader +renderCircleSmoothSDF :: + State -> Float -> Float -> Float -> Float -> Float -> IO () +renderCircleSmoothSDF state posX posY scaleFactor radius thickness = do + color <- get GL.currentColor + let outerR = abs radius + abs thickness / 2 + innerR = max 0 (abs radius - abs thickness / 2) + renderCircleSDF state.stateShaders posX posY scaleFactor outerR innerR color + + +-- | Render a smooth arc using SDF shader +renderArcSmoothSDF :: + State -> Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () +renderArcSmoothSDF state posX posY scaleFactor radius a1 a2 thickness = do + color <- get GL.currentColor + let outerR = abs radius + abs thickness / 2 + innerR = max 0 (abs radius - abs thickness / 2) + renderArcSDF state.stateShaders posX posY scaleFactor outerR innerR a1 a2 color + + +-- | Render a smooth thick line using SDF shader +renderThickLineSmoothSDF :: + State -> Float -> Float -> Float -> [(Float, Float)] -> Float -> IO () +renderThickLineSmoothSDF state offsetX offsetY scaleFactor path thickness = do + color <- get GL.currentColor + let translatedPath = map (\(x, y) -> (x + offsetX, y + offsetY)) path + renderThickLineSDF state.stateShaders translatedPath scaleFactor thickness color diff --git a/Brillo/Internals/Rendering/Polygon.hs b/Brillo/Internals/Rendering/Polygon.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Polygon.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Rendering.Polygon ( + renderComplexPolygon, + renderComplexPolygonSmooth, +) where + +import Brillo.Internals.Rendering.Common +import Graphics.Rendering.OpenGL (($=)) +import Graphics.Rendering.OpenGL.GL qualified as GL +import Graphics.Rendering.OpenGL.GLU.Tessellation + + +combiner :: a -> b -> () +combiner _ _ = () + + +-- written this way to measurably improve performance +zipLoop :: [a] -> [(a, a)] +zipLoop [] = [] +zipLoop (x : xs) = + let + go y [] = [(y, x)] + go y (z : rs) = (y, z) : go z rs + in + go x xs + + +zipWithLoop :: (a -> a -> b) -> [a] -> [b] +zipWithLoop f = map (uncurry f) . zipLoop + + +{-| Signed angle between 2 vectors +https://stackoverflow.com/a/16544330/1779797 +Note: `isConvex` would remain correct if this returned a value +between theta*7/2pi and theta*7/4pi +which probably provides an opportunity for optimization +-} +angle :: (Float, Float) -> (Float, Float) -> Float +angle (x1, y1) (x2, y2) = + let dot = x1 * x2 + y1 * y2 -- cos theta * |v1||v2| + det = y2 * x1 - x2 * y1 -- sin theta * |v1||v2| + in atan2 det dot + + +{-| Approximating 2pi by 7 is reasonable here. +The total rotation theoretically must be a multiple of 2pi, +so a little generosity doesn't break anything, +but might save some cases that would fail due to floating point errors +-} +isConvex :: [(Float, Float)] -> Bool +isConvex ps = + let + -- Combine angles, but return a value greater than 7 + -- if they have opposite signs + angleAdd :: Float -> Float -> Float + angleAdd a b = if signum a * signum b < -0.5 then 10 else a + b + in + -- Check that it doesn't turn more than one full circle in total + all (\theta -> (theta <= 7) && (theta > -7)) $ + scanl angleAdd 0 $ -- Check that the path's direction is consistent + zipWithLoop angle $ -- Compute angles of turns at each vertex + filter (/= (0, 0)) $ -- Discard edges arising from duplicated vertices + -- Produce vectors for each edge + zipWithLoop (\(x1, y1) (x2, y2) -> (x2 - x1, y2 - y1)) ps + + +renderComplexPolygon :: [(Float, Float)] -> IO () +renderComplexPolygon path = + if isConvex path + then GL.renderPrimitive GL.Polygon $ vertexPFs path + else do + Triangulation ts <- + triangulate TessWindingOdd 0 (GL.Normal3 0 0 1) combiner $ + ComplexPolygon + [ ComplexContour + [ AnnotatedVertex (GL.Vertex3 (realToFrac a) (realToFrac b) 0) () + | (a, b) <- path + ] + ] + GL.renderPrimitive GL.Triangles (trisToGLVertices ts) + return () + + +{-| Render a complex polygon with anti-aliased edges + Draws the filled polygon, then overlays anti-aliased edges +-} +renderComplexPolygonSmooth :: [(Float, Float)] -> IO () +renderComplexPolygonSmooth path = do + -- First draw the filled polygon + renderComplexPolygon path + -- Then draw anti-aliased edges on top + GL.lineSmooth $= GL.Enabled + GL.renderPrimitive GL.LineLoop $ vertexPFs path + GL.lineSmooth $= GL.Disabled + + +trisToGLVertices :: [Triangle a] -> IO () +trisToGLVertices [] = return () +trisToGLVertices + ( (Triangle (AnnotatedVertex v1 _) (AnnotatedVertex v2 _) (AnnotatedVertex v3 _)) + : rest + ) = + do + GL.vertex v1 + GL.vertex v2 + GL.vertex v3 + trisToGLVertices rest +{-# INLINE trisToGLVertices #-} + + +vertexPFs :: [(Float, Float)] -> IO () +vertexPFs [] = return () +vertexPFs ((x, y) : rest) = + do + GL.vertex $ GL.Vertex2 (gf x) (gf y) + vertexPFs rest +{-# INLINE vertexPFs #-} diff --git a/Brillo/Internals/Rendering/Shader.hs b/Brillo/Internals/Rendering/Shader.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Shader.hs @@ -0,0 +1,463 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Shader-based rendering for anti-aliased shapes using signed distance fields. +module Brillo.Internals.Rendering.Shader ( + ShaderState (..), + initShaderState, + renderCircleSDF, + renderArcSDF, + renderThickLineSDF, +) where + +import Control.Monad (unless) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Graphics.Rendering.OpenGL (($=)) +import Graphics.Rendering.OpenGL.GL qualified as GL + + +-- | State for shader-based rendering +data ShaderState = ShaderState + { circleProgram :: !(IORef (Maybe GL.Program)) + , arcProgram :: !(IORef (Maybe GL.Program)) + , lineProgram :: !(IORef (Maybe GL.Program)) + } + + +-- | Initialize shader state (programs are compiled lazily on first use) +initShaderState :: IO ShaderState +initShaderState = do + circleRef <- newIORef Nothing + arcRef <- newIORef Nothing + lineRef <- newIORef Nothing + return + ShaderState + { circleProgram = circleRef + , arcProgram = arcRef + , lineProgram = lineRef + } + + +-- | Vertex shader for SDF shapes - uses texture coords for local position +vertexShaderSrc :: String +vertexShaderSrc = + unlines + [ "#version 120" + , "varying vec2 vLocalCoord;" + , "void main() {" + , " vLocalCoord = gl_MultiTexCoord0.xy;" + , " gl_Position = gl_ModelViewProjectionMatrix * gl_Vertex;" + , "}" + ] + + +-- | Fragment shader for filled circle with SDF anti-aliasing +circleFragmentShaderSrc :: String +circleFragmentShaderSrc = + unlines + [ "#version 120" + , "varying vec2 vLocalCoord;" + , "uniform vec4 uColor;" + , "uniform float uOuterRadius;" + , "uniform float uInnerRadius;" -- 0 for solid circle + , "uniform float uPixelSize;" -- Size of a pixel in local coords for AA width + , "" + , "void main() {" + , " float dist = length(vLocalCoord);" + , " // Compute actual pixel size from screen-space derivatives" + , " float pixelSize = length(vec2(dFdx(dist), dFdy(dist)));" + , " // AA width: ~1 pixel, but capped at 25% of radius so small circles remain visible" + , " float aaWidth = min(pixelSize, uOuterRadius * 0.25);" + , "" + , " // Outer edge - AA extends outward from the edge to match aliased circle size" + , " float outerAlpha = 1.0 - smoothstep(uOuterRadius, uOuterRadius + aaWidth, dist);" + , "" + , " // Inner edge (for rings) - AA extends inward from the edge" + , " float innerAlpha = uInnerRadius > 0.0 ? smoothstep(uInnerRadius - aaWidth, uInnerRadius, dist) : 1.0;" + , "" + , " float alpha = outerAlpha * innerAlpha;" + , " if (alpha < 0.001) discard;" + , " gl_FragColor = vec4(uColor.rgb, uColor.a * alpha);" + , "}" + ] + + +{-| Fragment shader for arc with SDF anti-aliasing +Arc is drawn counter-clockwise from start angle to end angle +-} +arcFragmentShaderSrc :: String +arcFragmentShaderSrc = + unlines + [ "#version 120" + , "varying vec2 vLocalCoord;" + , "uniform vec4 uColor;" + , "uniform float uOuterRadius;" + , "uniform float uInnerRadius;" + , "uniform float uStartAngle;" -- In radians + , "uniform float uSweep;" -- Arc sweep in radians (always positive, counter-clockwise) + , "uniform float uPixelSize;" + , "" + , "#define PI 3.14159265359" + , "#define TAU 6.28318530718" + , "" + , "void main() {" + , " float dist = length(vLocalCoord);" + , " float angle = atan(vLocalCoord.y, vLocalCoord.x);" + , " // Compute actual pixel size from screen-space derivatives" + , " float pixelSize = length(vec2(dFdx(dist), dFdy(dist)));" + , " // AA width: ~1 pixel, but capped at 25% of radius so small circles remain visible" + , " float aaWidth = min(pixelSize, uOuterRadius * 0.25);" + , "" + , " // Outer edge - AA extends outward from the edge to match aliased circle size" + , " float outerAlpha = 1.0 - smoothstep(uOuterRadius, uOuterRadius + aaWidth, dist);" + , "" + , " // Inner edge (for rings) - AA extends inward from the edge" + , " float innerAlpha = uInnerRadius > 0.0 ? smoothstep(uInnerRadius - aaWidth, uInnerRadius, dist) : 1.0;" + , "" + , " // Calculate angle relative to start, normalized to [0, 2*PI)" + , " float relAngle = angle - uStartAngle;" + , " // Normalize to [0, 2*PI) - add TAU twice to handle very negative values" + , " relAngle = relAngle - TAU * floor(relAngle / TAU);" + , "" + , " // Soft edges at arc boundaries using signed distance from boundaries" + , " float angularAA = aaWidth / max(dist, 0.001);" + , "" + , " // Distance from start edge (positive = inside arc)" + , " float startDist = relAngle;" + , " // Distance from end edge (positive = inside arc)" + , " float endDist = uSweep - relAngle;" + , "" + , " float startAlpha = smoothstep(-angularAA, angularAA, startDist);" + , " float endAlpha = smoothstep(-angularAA, angularAA, endDist);" + , "" + , " float alpha = outerAlpha * innerAlpha * startAlpha * endAlpha;" + , " if (alpha < 0.001) discard;" + , " gl_FragColor = vec4(uColor.rgb, uColor.a * alpha);" + , "}" + ] + + +{-| Fragment shader for line segment (capsule) with SDF anti-aliasing. +A thick line segment is rendered as a capsule - all points within +a given distance from the line segment. +-} +lineFragmentShaderSrc :: String +lineFragmentShaderSrc = + "#version 120 \n\ + \varying vec2 vLocalCoord; \ + \uniform vec4 uColor; \ + \uniform vec2 uPointA; \ + \uniform vec2 uPointB; \ + \uniform float uThickness; \ + \uniform float uPixelSize; \ + \void main() { \ + \ vec2 pa = vLocalCoord - uPointA; \ + \ vec2 ba = uPointB - uPointA; \ + \ float len2 = dot(ba, ba); \ + \ float h = len2 > 0.0 ? clamp(dot(pa, ba) / len2, 0.0, 1.0) : 0.0; \ + \ float dist = length(pa - ba * h); \ + \ float aaWidth = min(uPixelSize, uThickness * 0.1); \ + \ float d = dist - uThickness; \ + \ float alpha = 1.0 - smoothstep(-aaWidth, aaWidth, d); \ + \ if (alpha < 0.001) discard; \ + \ gl_FragColor = vec4(uColor.rgb, uColor.a * alpha); \ + \}" + + +-- | Compile a shader from source +compileShader :: GL.ShaderType -> String -> IO GL.Shader +compileShader shaderType src = do + shader <- GL.createShader shaderType + GL.shaderSourceBS shader $= GL.packUtf8 src + GL.compileShader shader + ok <- GL.get (GL.compileStatus shader) + unless ok $ do + infoLog <- GL.get (GL.shaderInfoLog shader) + error $ "Shader compilation failed: " ++ infoLog + return shader + + +-- | Create and link a shader program +createProgram :: String -> String -> IO GL.Program +createProgram vertSrc fragSrc = do + vertShader <- compileShader GL.VertexShader vertSrc + fragShader <- compileShader GL.FragmentShader fragSrc + + program <- GL.createProgram + GL.attachShader program vertShader + GL.attachShader program fragShader + + GL.linkProgram program + ok <- GL.get (GL.linkStatus program) + unless ok $ do + infoLog <- GL.get (GL.programInfoLog program) + error $ "Program linking failed: " ++ infoLog + + -- Clean up shaders (they're copied into the program) + GL.deleteObjectName vertShader + GL.deleteObjectName fragShader + + return program + + +-- | Get or create the circle shader program +getCircleProgram :: ShaderState -> IO GL.Program +getCircleProgram state = do + maybeProgram <- readIORef (circleProgram state) + case maybeProgram of + Just prog -> return prog + Nothing -> do + prog <- createProgram vertexShaderSrc circleFragmentShaderSrc + writeIORef (circleProgram state) (Just prog) + return prog + + +-- | Get or create the arc shader program +getArcProgram :: ShaderState -> IO GL.Program +getArcProgram state = do + maybeProgram <- readIORef (arcProgram state) + case maybeProgram of + Just prog -> return prog + Nothing -> do + prog <- createProgram vertexShaderSrc arcFragmentShaderSrc + writeIORef (arcProgram state) (Just prog) + return prog + + +-- | Get or create the line shader program +getLineProgram :: ShaderState -> IO GL.Program +getLineProgram state = do + maybeProgram <- readIORef (lineProgram state) + case maybeProgram of + Just prog -> return prog + Nothing -> do + prog <- createProgram vertexShaderSrc lineFragmentShaderSrc + writeIORef (lineProgram state) (Just prog) + return prog + + +-- | Render a circle/ring using SDF shader +renderCircleSDF :: + ShaderState -> + Float -> -- posX + Float -> -- posY + Float -> -- scaleFactor (pixels per unit) + Float -> -- outer radius + Float -> -- inner radius (0 for solid) + GL.Color4 GL.GLfloat -> -- color + IO () +renderCircleSDF state posX posY scaleFactor outerR innerR color = do + program <- getCircleProgram state + + -- Save current program + oldProgram <- GL.get GL.currentProgram + + GL.currentProgram $= Just program + + -- Set uniforms + uColorLoc <- GL.get (GL.uniformLocation program "uColor") + uOuterLoc <- GL.get (GL.uniformLocation program "uOuterRadius") + uInnerLoc <- GL.get (GL.uniformLocation program "uInnerRadius") + uPixelLoc <- GL.get (GL.uniformLocation program "uPixelSize") + + GL.uniform uColorLoc $= color + GL.uniform uOuterLoc $= (realToFrac outerR :: GL.GLfloat) + GL.uniform uInnerLoc $= (realToFrac innerR :: GL.GLfloat) + GL.uniform uPixelLoc $= (realToFrac (1.0 / scaleFactor) :: GL.GLfloat) + + -- Draw a quad that covers the circle + let r = outerR + 2.0 / scaleFactor -- Add padding for AA + x1 = posX - r + x2 = posX + r + y1 = posY - r + y2 = posY + r + -- Local coords relative to circle center + l1 = -r + l2 = r + + -- Draw quad with position (vertex) and local coords (texCoord) + GL.renderPrimitive GL.Quads $ do + GL.texCoord $ + GL.TexCoord2 (realToFrac l1 :: GL.GLfloat) (realToFrac l1 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x1 :: GL.GLfloat) (realToFrac y1 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l2 :: GL.GLfloat) (realToFrac l1 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x2 :: GL.GLfloat) (realToFrac y1 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l2 :: GL.GLfloat) (realToFrac l2 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x2 :: GL.GLfloat) (realToFrac y2 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l1 :: GL.GLfloat) (realToFrac l2 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x1 :: GL.GLfloat) (realToFrac y2 :: GL.GLfloat) + + GL.currentProgram $= oldProgram + + +-- | Render an arc using SDF shader +renderArcSDF :: + ShaderState -> + Float -> -- posX + Float -> -- posY + Float -> -- scaleFactor + Float -> -- outer radius + Float -> -- inner radius + Float -> -- start angle (degrees) + Float -> -- end angle (degrees) + GL.Color4 GL.GLfloat -> -- color + IO () +renderArcSDF state posX posY scaleFactor outerR innerR startDeg endDeg color = do + program <- getArcProgram state + + oldProgram <- GL.get GL.currentProgram + GL.currentProgram $= Just program + + -- Set uniforms + uColorLoc <- GL.get (GL.uniformLocation program "uColor") + uOuterLoc <- GL.get (GL.uniformLocation program "uOuterRadius") + uInnerLoc <- GL.get (GL.uniformLocation program "uInnerRadius") + uStartLoc <- GL.get (GL.uniformLocation program "uStartAngle") + uSweepLoc <- GL.get (GL.uniformLocation program "uSweep") + uPixelLoc <- GL.get (GL.uniformLocation program "uPixelSize") + + -- Convert to radians and calculate sweep (counter-clockwise from start to end) + let startRad = startDeg * pi / 180.0 + endRad = endDeg * pi / 180.0 + -- Sweep is how far we go counter-clockwise from start to end + -- If start >= end, we wrap around through 360 degrees + sweep = + if startDeg >= endDeg + then (endRad + 2 * pi) - startRad + else endRad - startRad + + GL.uniform uColorLoc $= color + GL.uniform uOuterLoc $= (realToFrac outerR :: GL.GLfloat) + GL.uniform uInnerLoc $= (realToFrac innerR :: GL.GLfloat) + GL.uniform uStartLoc $= (realToFrac startRad :: GL.GLfloat) + GL.uniform uSweepLoc $= (realToFrac sweep :: GL.GLfloat) + GL.uniform uPixelLoc $= (realToFrac (1.0 / scaleFactor) :: GL.GLfloat) + + -- Draw a quad that covers the arc + let r = outerR + 2.0 / scaleFactor + x1 = posX - r + x2 = posX + r + y1 = posY - r + y2 = posY + r + l1 = -r + l2 = r + + GL.renderPrimitive GL.Quads $ do + GL.texCoord $ + GL.TexCoord2 (realToFrac l1 :: GL.GLfloat) (realToFrac l1 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x1 :: GL.GLfloat) (realToFrac y1 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l2 :: GL.GLfloat) (realToFrac l1 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x2 :: GL.GLfloat) (realToFrac y1 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l2 :: GL.GLfloat) (realToFrac l2 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x2 :: GL.GLfloat) (realToFrac y2 :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac l1 :: GL.GLfloat) (realToFrac l2 :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac x1 :: GL.GLfloat) (realToFrac y2 :: GL.GLfloat) + + GL.currentProgram $= oldProgram + + +-- | Render a single line segment using SDF shader (capsule shape) +renderLineSegmentSDF :: + ShaderState -> + Float -> -- ax + Float -> -- ay + Float -> -- bx + Float -> -- by + Float -> -- scaleFactor (pixels per unit) + Float -> -- thickness (diameter) + GL.Color4 GL.GLfloat -> -- color + IO () +renderLineSegmentSDF state ax ay bx by scaleFactor thickness color = do + program <- getLineProgram state + + oldProgram <- GL.get GL.currentProgram + GL.currentProgram $= Just program + + -- Set uniforms + uColorLoc <- GL.get (GL.uniformLocation program "uColor") + uPointALoc <- GL.get (GL.uniformLocation program "uPointA") + uPointBLoc <- GL.get (GL.uniformLocation program "uPointB") + uThicknessLoc <- GL.get (GL.uniformLocation program "uThickness") + uPixelLoc <- GL.get (GL.uniformLocation program "uPixelSize") + + let halfThick = thickness / 2.0 + + GL.uniform uColorLoc $= color + GL.uniform uPointALoc + $= GL.Vector2 (realToFrac ax :: GL.GLfloat) (realToFrac ay) + GL.uniform uPointBLoc + $= GL.Vector2 (realToFrac bx :: GL.GLfloat) (realToFrac by) + GL.uniform uThicknessLoc $= (realToFrac halfThick :: GL.GLfloat) + GL.uniform uPixelLoc $= (realToFrac (1.0 / scaleFactor) :: GL.GLfloat) + + -- Compute bounding box with padding for AA + let padding = 2.0 / scaleFactor + r = halfThick + padding + minX = min ax bx - r + maxX = max ax bx + r + minY = min ay by - r + maxY = max ay by + r + + -- Draw quad covering the capsule + -- vLocalCoord receives the vertex position (world space) + GL.renderPrimitive GL.Quads $ do + GL.texCoord $ + GL.TexCoord2 (realToFrac minX :: GL.GLfloat) (realToFrac minY :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac minX :: GL.GLfloat) (realToFrac minY :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac maxX :: GL.GLfloat) (realToFrac minY :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac maxX :: GL.GLfloat) (realToFrac minY :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac maxX :: GL.GLfloat) (realToFrac maxY :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac maxX :: GL.GLfloat) (realToFrac maxY :: GL.GLfloat) + + GL.texCoord $ + GL.TexCoord2 (realToFrac minX :: GL.GLfloat) (realToFrac maxY :: GL.GLfloat) + GL.vertex $ + GL.Vertex2 (realToFrac minX :: GL.GLfloat) (realToFrac maxY :: GL.GLfloat) + + GL.currentProgram $= oldProgram + + +-- | Render an entire path as connected thick line segments using SDF +renderThickLineSDF :: + ShaderState -> + [(Float, Float)] -> -- Path points + Float -> -- scaleFactor + Float -> -- thickness + GL.Color4 GL.GLfloat -> -- color + IO () +renderThickLineSDF _state [] _ _ _ = return () +renderThickLineSDF _state [_] _ _ _ = return () -- Single point, nothing to draw +renderThickLineSDF state path scaleFactor thickness color = do + -- Render each segment as a capsule + -- Overlapping capsules at joins naturally create rounded joins + let segments = zip path (drop 1 path) + mapM_ renderSegment segments + where + renderSegment ((ax, ay), (bx, by)) = + renderLineSegmentSDF state ax ay bx by scaleFactor thickness color diff --git a/Brillo/Internals/Rendering/State.hs b/Brillo/Internals/Rendering/State.hs --- a/Brillo/Internals/Rendering/State.hs +++ b/Brillo/Internals/Rendering/State.hs @@ -9,6 +9,7 @@ where import Brillo.Internals.Rendering.Bitmap (BitmapData) +import Brillo.Internals.Rendering.Shader (ShaderState, initShaderState) import Data.IORef (IORef, newIORef) import Data.Word (Word8) import Foreign.ForeignPtr (ForeignPtr) @@ -31,6 +32,8 @@ -- ^ Whether to use line smoothing , stateTextures :: !(IORef [Texture]) -- ^ Cache of Textures that we've sent to OpenGL. + , stateShaders :: !ShaderState + -- ^ Shader programs for SDF-based rendering. } @@ -60,6 +63,7 @@ initState = do textures <- newIORef [] + shaders <- initShaderState return State { stateColor = True @@ -67,4 +71,5 @@ , stateBlendAlpha = True , stateLineSmooth = False , stateTextures = textures + , stateShaders = shaders } diff --git a/Brillo/Internals/Rendering/TrueTypeFont.hs b/Brillo/Internals/Rendering/TrueTypeFont.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/TrueTypeFont.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Rendering support for TrueType fonts using the FreeType bindings. +module Brillo.Internals.Rendering.TrueTypeFont ( + renderTrueTypeText, +) where + +import Brillo.Internals.Rendering.Common (gf) +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) +import Control.Exception (try) +import Control.Monad (foldM, forM, forM_) +import Data.Either (partitionEithers) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word8) +import Foreign (Ptr, nullPtr, peek) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr) +import Foreign.Storable (peekElemOff, pokeElemOff) +import FreeType ( + FT_Bitmap (bBuffer, bRows, bWidth), + FT_Face, + FT_FaceRec (frGlyph), + FT_GlyphSlotRec ( + gsrAdvance, + gsrBitmap, + gsrBitmap_left, + gsrBitmap_top + ), + FT_Vector (vX), + ft_Done_Face, + ft_Done_FreeType, + ft_Init_FreeType, + ft_Load_Char, + ft_New_Face, + ft_Set_Pixel_Sizes, + pattern FT_LOAD_RENDER, + ) +import FreeType.Exception (FtError) +import Graphics.Rendering.OpenGL ( + TextureFunction (Modulate), + get, + textureBinding, + ($=), + ) +import Graphics.Rendering.OpenGL.GL qualified as GL +import Graphics.UI.GLFW qualified as GLFW +import System.IO.Unsafe (unsafePerformIO) + + +-- Glyph data ---------------------------------------------------------------- + +data Glyph + = Glyph + { glyphTexture :: !(Maybe GL.TextureObject) + , glyphSize :: !(Int, Int) + , glyphBearing :: !(Int32, Int32) + , glyphAdvance :: !Int32 + } + + +type FontKey = (FilePath, Int) +type FontCache = Map FontKey (Map Char Glyph) + + +fontCache :: MVar FontCache +fontCache = unsafePerformIO (newMVar Map.empty) +{-# NOINLINE fontCache #-} + + +-- | Detect the content scale factor (DPI scale) for HiDPI/Retina displays +getContentScale :: IO Float +getContentScale = do + mWindow <- GLFW.getCurrentContext + case mWindow of + Nothing -> pure 1.0 -- No window context, assume scale 1.0 + Just win -> do + (fbWidth, fbHeight) <- GLFW.getFramebufferSize win + (winWidth, winHeight) <- GLFW.getWindowSize win + -- Calculate scale factor from framebuffer vs window size + -- Use width as primary, fall back to height if width is zero + let scaleX = if winWidth > 0 then fromIntegral fbWidth / fromIntegral winWidth else 1.0 + scaleY = if winHeight > 0 then fromIntegral fbHeight / fromIntegral winHeight else 1.0 + -- Use the maximum scale factor to ensure crisp rendering + pure $ max scaleX scaleY + + +renderTrueTypeText :: FilePath -> Int -> Text -> IO () +renderTrueTypeText fontPath pixelHeight str + | T.null str = pure () + | otherwise = do + -- Detect DPI scale factor for HiDPI/Retina displays + scaleFactor <- getContentScale + let scaledHeight = round (fromIntegral pixelHeight * scaleFactor) + + glyphs <- getOrLoadFont fontPath scaledHeight + let fallbackGlyph = Map.lookup '?' glyphs + GL.texture GL.Texture2D $= GL.Enabled + oldTexFunc <- get GL.textureFunction + GL.textureFunction $= Modulate + GL.preservingMatrix $ do + -- Scale down by the same factor to maintain logical size + GL.scale + (1.0 / realToFrac scaleFactor) + (1.0 / realToFrac scaleFactor) + (1.0 :: GL.GLfloat) + _ <- + foldM + (renderGlyph glyphs fallbackGlyph scaledHeight) + (0, 0) + (T.unpack str) + pure () + GL.textureFunction $= oldTexFunc + GL.texture GL.Texture2D $= GL.Disabled + + +renderGlyph :: + Map Char Glyph -> + Maybe Glyph -> + Int -> + (Float, Float) -> + Char -> + IO (Float, Float) +renderGlyph glyphs fallback lineHeight (penX, penY) = \case + '\n' -> + pure (0, penY - fromIntegral lineHeight) + ch -> + do + let glyph = Map.lookup ch glyphs <|> fallback + case glyph of + Nothing -> + pure (penX, penY) + Just + Glyph{glyphTexture, glyphSize = (w, h), glyphBearing = (bx, by), glyphAdvance} -> + do + let advance = fromIntegral glyphAdvance / 64 + xpos = penX + fromIntegral bx + ypos = penY + fromIntegral by - fromIntegral h + width = fromIntegral w + height = fromIntegral h + case glyphTexture of + Nothing -> + pure (penX + advance, penY) + Just tex -> do + textureBinding GL.Texture2D $= Just tex + GL.renderPrimitive GL.Quads $ do + GL.texCoord $ GL.TexCoord2 0 (0 :: GL.GLfloat) + GL.vertex $ GL.Vertex3 (gf xpos) (gf (ypos + height)) 0 + GL.texCoord $ GL.TexCoord2 0 (1 :: GL.GLfloat) + GL.vertex $ GL.Vertex3 (gf xpos) (gf ypos) 0 + GL.texCoord $ GL.TexCoord2 1 (1 :: GL.GLfloat) + GL.vertex $ GL.Vertex3 (gf (xpos + width)) (gf ypos) 0 + GL.texCoord $ GL.TexCoord2 1 (0 :: GL.GLfloat) + GL.vertex $ GL.Vertex3 (gf (xpos + width)) (gf (ypos + height)) 0 + pure (penX + advance, penY) + + +-- Font loading -------------------------------------------------------------- + +getOrLoadFont :: FilePath -> Int -> IO (Map Char Glyph) +getOrLoadFont fontPath pixelHeight = + modifyMVar fontCache $ + \cache -> + case Map.lookup key cache of + Just font -> + pure (cache, font) + Nothing -> do + font <- loadFont fontPath pixelHeight + pure (Map.insert key font cache, font) + where + key = (fontPath, pixelHeight) + + +loadFont :: FilePath -> Int -> IO (Map Char Glyph) +loadFont fontPath pixelHeight = do + library <- ft_Init_FreeType + face <- ft_New_Face library fontPath 0 + ft_Set_Pixel_Sizes face 0 (fromIntegral pixelHeight) + GL.rowAlignment GL.Unpack $= 1 + glyphs <- forM [0 .. 255] $ loadGlyph face + ft_Done_Face face + ft_Done_FreeType library + let (errs, okGlyphs) = partitionEithers glyphs + case errs of + [] -> pure (Map.fromList okGlyphs) + (err : _) -> ioError (userError err) + + +loadGlyph :: FT_Face -> Int -> IO (Either String (Char, Glyph)) +loadGlyph face codepoint = do + let ch = toEnum codepoint + loadResult <- + try (ft_Load_Char face (fromIntegral codepoint) FT_LOAD_RENDER) :: + IO (Either FtError ()) + case loadResult of + Left err -> + pure . Left $ + "FreeType load error for char " <> show ch <> ": " <> show err + Right () -> do + faceRec <- peek face + glyphSlot <- peek (frGlyph faceRec) + let bitmap = gsrBitmap glyphSlot + width = fromIntegral (bWidth bitmap) :: Int + rows = fromIntegral (bRows bitmap) :: Int + bearingX = fromIntegral (gsrBitmap_left glyphSlot) :: Int32 + bearingY = fromIntegral (gsrBitmap_top glyphSlot) :: Int32 + advance = fromIntegral (vX (gsrAdvance glyphSlot)) :: Int32 + buffer = bBuffer bitmap + + texture <- + if width == 0 || rows == 0 || buffer == nullPtr + then pure Nothing + else do + rgbaData <- buildRgbaBuffer width rows buffer + tex <- GL.genObjectName + GL.textureBinding GL.Texture2D $= Just tex + withForeignPtr rgbaData $ \ptr -> + GL.texImage2D + GL.Texture2D + GL.NoProxy + 0 + GL.RGBA8 + (GL.TextureSize2D (fromIntegral width) (fromIntegral rows)) + 0 + (GL.PixelData GL.RGBA GL.UnsignedByte ptr) + GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.ClampToEdge) + GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.ClampToEdge) + GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') + pure (Just tex) + + pure $ + Right + ( ch + , Glyph + { glyphTexture = texture + , glyphSize = (width, rows) + , glyphBearing = (bearingX, bearingY) + , glyphAdvance = advance + } + ) + + +buildRgbaBuffer :: Int -> Int -> Ptr Word8 -> IO (ForeignPtr Word8) +buildRgbaBuffer width rows src = do + let pixelCount = width * rows + byteCount = pixelCount * 4 + dest <- mallocForeignPtrBytes byteCount + withForeignPtr dest $ \ptr -> do + forM_ [0 .. pixelCount - 1] $ \i -> do + alpha <- peekElemOff src i + let base = i * 4 + pokeElemOff ptr base (255 :: Word8) + pokeElemOff ptr (base + 1) (255 :: Word8) + pokeElemOff ptr (base + 2) (255 :: Word8) + pokeElemOff ptr (base + 3) alpha + pure dest diff --git a/Brillo/Internals/Rendering/VectorFont.hs b/Brillo/Internals/Rendering/VectorFont.hs --- a/Brillo/Internals/Rendering/VectorFont.hs +++ b/Brillo/Internals/Rendering/VectorFont.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Inspired by https://hackage.haskell.org/package/VectorFont module Brillo.Internals.Rendering.VectorFont ( VectorFont, @@ -12,10 +14,13 @@ ) where import Control.Monad (replicateM, (>=>)) +import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.List (minimumBy, permutations) import Data.Map (Map, findWithDefault, fromList, lookup) import Data.Ord (comparing) +import Data.Text (Text) +import Data.Text qualified as T type VFWidth = Double @@ -39,22 +44,22 @@ newtype VectorFont = VectorFont (Map Char VFGlyph) -{-| Given a @VectorFont@ and a @String@, return - * @Right@ strokes if the @String@ can be rendered. +{-| Given a @VectorFont@ and a @Text@, return + * @Right@ strokes if the @Text@ can be rendered. * @Left@ error otherwise. -} -render :: VectorFont -> String -> Either String [VFStroke] +render :: VectorFont -> Text -> Either Text [VFStroke] render f = getGlyphs f >=> (Right . renderLine 0) -getGlyphs :: VectorFont -> String -> Either String [VFGlyph] +getGlyphs :: VectorFont -> Text -> Either Text [VFGlyph] getGlyphs f = - addErrorMsg . leftsOrRights . map (getGlyph f) + addErrorMsg . first T.pack . leftsOrRights . map (getGlyph f) . T.unpack -addErrorMsg :: Either String a -> Either String a -addErrorMsg (Left a) = Left $ "Missing chars: " ++ a +addErrorMsg :: Either Text a -> Either Text a +addErrorMsg (Left a) = Left $ "Missing chars: " <> a addErrorMsg a = a @@ -78,9 +83,9 @@ useful if you want to ignore the possibility of errors e.g. because you're manually checking the output. -} -renderSafe :: VectorFont -> String -> [VFStroke] +renderSafe :: VectorFont -> Text -> [VFStroke] renderSafe f = - renderLine 0 . map (getGlyphSafe f) + renderLine 0 . map (getGlyphSafe f) . T.unpack getGlyphSafe :: VectorFont -> Char -> VFGlyph @@ -153,17 +158,20 @@ -- preferring (in order): score :: [VFStroke] -> (Int, Double, VFPoint) score ss | length ss < 2 = (length ss, 0.0, (0.0, 0.0)) -score ss = do +score ss@((firstPoint : _) : _) = do let - skips = zipWith (\as bs -> dist (last as) (head bs)) ss (tail ss) - firstPoint = head $ head ss + skips = zipWith (\as bs -> dist (last as) (safeHead bs)) ss (drop 1 ss) + safeHead (x : _) = x + safeHead [] = (0.0, 0.0) (length ss, sum skips, firstPoint) +score _ = (0, 0.0, (0.0, 0.0)) joinStrokes :: (Eq a) => [[a]] -> [[a]] -joinStrokes (s0 : s1 : ss) - | last s0 == head s1 = joinStrokes $ (s0 ++ tail s1) : ss +joinStrokes (s0 : s1@(h1 : t1) : ss) + | last s0 == h1 = joinStrokes $ (s0 ++ t1) : ss | otherwise = s0 : joinStrokes (s1 : ss) +joinStrokes (s0 : s1 : ss) = s0 : joinStrokes (s1 : ss) joinStrokes ss = ss {- FOURMOLU_DISABLE -} @@ -281,11 +289,11 @@ , ('^',(12,[[(2,12),(8,18),(14,12)],[(11,15),(8,19),(5,15)]])) , ('_',(12,[[(0,-2),(16,-2)]])) , ('`',(6,[[(5,17),(6,16),(5,15),(4,16),(4,18),(5,20),(6,21)]])) - , ('a',(15,[[(15,0),(15,14)],[(15,11),(13,13),(11,14),(8,14),(6,13),(4,11) + , ('a',(16,[[(15,0),(15,14)],[(15,11),(13,13),(11,14),(8,14),(6,13),(4,11) ,(3,8),(3,6),(4,3),(6,1),(8,0),(11,0),(13,1),(15,3)]])) , ('b',(15,[[(4,11),(6,13),(8,14),(11,14),(13,13),(15,11),(16,8),(16,6),(15,3) ,(13,1),(11,0),(8,0),(6,1),(4,3)],[(4,0),(4,21)]])) - , ('c',(14,[[(15,3),(13,1),(11,0),(8,0),(6,1),(4,3),(3,6),(3,8),(4,11),(6,13) + , ('c',(15,[[(15,3),(13,1),(11,0),(8,0),(6,1),(4,3),(3,6),(3,8),(4,11),(6,13) ,(8,14),(11,14),(13,13),(15,11)]])) , ('d',(14,[[(12,11),(10,13),(8,14),(6,14),(4,13),(2,11),(1,8),(1,6),(2,3) ,(4,1),(6,0),(8,0),(10,1),(12,3)],[(12,0),(12,21)]])) diff --git a/Brillo/Rendering.hs b/Brillo/Rendering.hs --- a/Brillo/Rendering.hs +++ b/Brillo/Rendering.hs @@ -16,8 +16,7 @@ -- * Bitmaps Rectangle (..), - BitmapData, - bitmapSize, + BitmapData (..), BitmapFormat (..), PixelFormat (..), RowOrder (..), @@ -57,19 +56,20 @@ and set that to the active context. If you don't want to do your own window management then use the @brillo@ package instead. -} -displayPicture - :: (Int, Int) - -- ^ Window width and height. - -> Color - -- ^ Color to clear the window with. - -> RS.State - -- ^ Current rendering state. - -> Float - -- ^ View port scale, which controls the level of detail. - -- Use 1.0 to start with. - -> Picture - -- ^ Picture to draw. - -> IO () +displayPicture :: + -- | Window width and height. + (Int, Int) -> + -- | Color to clear the window with. + Color -> + -- | Current rendering state. + RS.State -> + {-| View port scale, which controls the level of detail. + Use 1.0 to start with. + -} + Float -> + -- | Picture to draw. + Picture -> + IO () displayPicture windowSize colorClear state scale picture = withModelview windowSize $ withClearBuffer colorClear $ diff --git a/brillo-rendering.cabal b/brillo-rendering.cabal --- a/brillo-rendering.cabal +++ b/brillo-rendering.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: brillo-rendering -version: 1.13.3 +version: 2.0.0 license: MIT license-file: LICENSE author: Elise Huard, Ben Lippmeier, Adrian Sieber @@ -14,6 +14,8 @@ If you want Brillo to setup your window as well, then use the plain @brillo@ package. +tested-with: GHC ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 + source-repository head type: git location: https://github.com/ad-si/Brillo @@ -29,15 +31,20 @@ Brillo.Internals.Rendering.Color Brillo.Internals.Rendering.Common Brillo.Internals.Rendering.Picture + Brillo.Internals.Rendering.Polygon + Brillo.Internals.Rendering.Shader Brillo.Internals.Rendering.State + Brillo.Internals.Rendering.TrueTypeFont Brillo.Internals.Rendering.VectorFont build-depends: , base >=4.8 && <5 , bmp >=1.2 && <1.3 - , bytestring >=0.11 && <0.12 - , containers >=0.5 && <0.7 + , bytestring >=0.11 && <0.13 + , containers >=0.5 && <0.9 + , freetype2 >=0.2 && <0.4 + , GLFW-b >=3.3 && <4 , OpenGL >=2.12 && <3.1 - , vector >=0.13 && <0.14 + , text >=2.0 && <2.2 ghc-options: -Wall -O2