brillo-rendering (empty) → 1.13.3
raw patch · 13 files changed
+1853/−0 lines, 13 filesdep +OpenGLdep +basedep +bmpsetup-changed
Dependencies added: OpenGL, base, bmp, bytestring, containers, vector
Files
- Brillo/Internals/Data/Color.hs +141/−0
- Brillo/Internals/Data/Picture.hs +223/−0
- Brillo/Internals/Rendering/Bitmap.hs +94/−0
- Brillo/Internals/Rendering/Circle.hs +304/−0
- Brillo/Internals/Rendering/Color.hs +20/−0
- Brillo/Internals/Rendering/Common.hs +86/−0
- Brillo/Internals/Rendering/Picture.hs +428/−0
- Brillo/Internals/Rendering/State.hs +70/−0
- Brillo/Internals/Rendering/VectorFont.hs +342/−0
- Brillo/Rendering.hs +76/−0
- LICENSE +22/−0
- Setup.hs +4/−0
- brillo-rendering.cabal +43/−0
+ Brillo/Internals/Data/Color.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_HADDOCK hide #-}++{-# HLINT ignore "Eta reduce" #-}++-- | Data type for representing colors.+module Brillo.Internals.Data.Color (+ Color (..),+ makeColor,+ makeColorI,+ makeRawColor,+ makeRawColorI,+ rgbaOfColor,+ clampColor,+)+where++import Data.Data (Data, Typeable)+++{-| An abstract color value.+ We keep the type abstract so we can be sure that the components+ are in the required range. To make a custom color use 'makeColor'.+-}+data Color+ = -- | Holds the color components. All components lie in the range [0..1.+ RGBA !Float !Float !Float !Float+ deriving (Show, Eq, Data, Typeable)+++instance Num Color where+ (+) :: Color -> Color -> Color+ (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) =+ RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1+ {-# INLINE (+) #-}+++ (-) :: Color -> Color -> Color+ (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) =+ RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1+ {-# INLINE (-) #-}+++ (*) :: Color -> Color -> Color+ (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) =+ RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1+ {-# INLINE (*) #-}+++ abs :: Color -> Color+ abs (RGBA r1 g1 b1 _) =+ RGBA (abs r1) (abs g1) (abs b1) 1+ {-# INLINE abs #-}+++ signum :: Color -> Color+ signum (RGBA r1 g1 b1 _) =+ RGBA (signum r1) (signum g1) (signum b1) 1+ {-# INLINE signum #-}+++ fromInteger :: Integer -> Color+ fromInteger i =+ let f = fromInteger i+ in RGBA f f f 1+ {-# INLINE fromInteger #-}+++-- | 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 r g b a =+ clampColor $+ RGBA r g b a+{-# INLINE makeColor #-}+++-- | Make a custom color. All components are clamped to the range [0..255].+makeColorI :: Int -> Int -> Int -> Int -> Color+makeColorI r g b a =+ clampColor $+ RGBA+ (fromIntegral r / 255)+ (fromIntegral g / 255)+ (fromIntegral b / 255)+ (fromIntegral a / 255)+{-# INLINE makeColorI #-}+++{-| Make a custom color.++ Using this function over `makeColor` avoids clamping the components,+ which saves time. However, if the components are out of range then+ this will result in integer overflow at rendering time, and the actual+ picture you get will be implementation dependent.++ You'll only need to use this function when using the @brillo-raster@+ package that builds a new color for every pixel. If you're just working+ with the Picture data type then it there is no need for raw colors.+-}+makeRawColor :: Float -> Float -> Float -> Float -> Color+makeRawColor r g b a =+ RGBA r g b a+{-# INLINE makeRawColor #-}+++-- | Make a custom color, taking pre-clamped components.+makeRawColorI :: Int -> Int -> Int -> Int -> Color+makeRawColorI r g b a =+ RGBA+ (fromIntegral r / 255)+ (fromIntegral g / 255)+ (fromIntegral b / 255)+ (fromIntegral a / 255)+{-# INLINE makeRawColorI #-}+++-- | Take the RGBA components of a color.+rgbaOfColor :: Color -> (Float, Float, Float, Float)+rgbaOfColor (RGBA r g b a) = (r, g, b, a)+{-# INLINE rgbaOfColor #-}+++-- | Clamp components of a raw color into the required range.+clampColor :: Color -> Color+clampColor cc = do+ let+ (r, g, b, a) = rgbaOfColor cc+ clamp x = min (max x 0.0) 1.0++ RGBA (clamp r) (clamp g) (clamp b) (clamp a)
+ Brillo/Internals/Data/Picture.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Data types for representing pictures.+module Brillo.Internals.Data.Picture (+ Point,+ Vector,+ Path,+ Picture (..),++ -- * Bitmaps+ Rectangle (..),+ BitmapData,+ PixelFormat (..),+ BitmapFormat (..),+ RowOrder (..),+ bitmapSize,+ bitmapOfForeignPtr,+ bitmapDataOfForeignPtr,+ bitmapOfByteString,+ bitmapDataOfByteString,+ bitmapOfBMP,+ bitmapDataOfBMP,+ loadBMP,+ rectAtOrigin,+)+where++import Brillo.Internals.Data.Color (Color)+import Brillo.Internals.Rendering.Bitmap (+ BitmapData (BitmapData, bitmapSize),+ BitmapFormat (..),+ PixelFormat (..),+ Rectangle (..),+ RowOrder (..),+ )+import Codec.BMP (BMP, bmpDimensions, readBMP, unpackBMPToRGBA32)+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe qualified as BSU+import Data.Data (Data, Typeable)+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr)+import Foreign.Marshal.Alloc (finalizerFree, mallocBytes)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (castPtr)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (map)+++#if __GLASGOW_HASKELL__ >= 800+import Data.Semigroup+import Data.List.NonEmpty+#endif+++-- | A point on the x-y plane.+type Point = (Float, Float)+++-- | A vector can be treated as a point, and vis-versa.+type Vector = Point+++-- | A path through the x-y plane.+type Path = [Point]+++-- | A 2D picture+data Picture+ = -- Primitives -------------------------------------++ -- | A blank picture, with nothing in it.+ Blank+ | -- | A convex polygon filled with a solid color.+ Polygon Path+ | -- | A line along an arbitrary path.+ Line Path+ | -- | A circle with the given radius.+ Circle Float+ | -- | A circle with the given radius and thickness.+ -- 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.+ 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`.+ ThickArc Float Float Float Float+ | -- | Text to draw with a vector font+ Text String+ | -- | 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.+ BitmapSection Rectangle BitmapData+ | -- Color ------------------------------------------++ -- | A picture drawn with this color.+ Color Color Picture+ | -- Transforms -------------------------------------++ -- | A picture translated by the given x and y coordinates.+ Translate Float Float Picture+ | -- | A picture rotated clockwise by the given angle (in degrees).+ Rotate Float Picture+ | -- | A picture scaled by the given x and y factors.+ Scale Float Float Picture+ | -- More Pictures ----------------------------------++ -- | A picture consisting of several others.+ Pictures [Picture]+ deriving (Show, Eq, Data, Typeable)+++-- Instances ------------------------------------------------------------------+instance Monoid Picture where+ mempty = Blank+ mconcat = Pictures++#if __GLASGOW_HASKELL__ >= 800+instance Semigroup Picture where+ a <> b = Pictures [a, b]+ sconcat = Pictures . toList+ stimes = stimesIdempotent+#endif+++-- Bitmaps --------------------------------------------------------------------++{-| O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given+ width and height.++ The boolean flag controls whether Brillo should cache the data+ between frames for speed. If you are programatically generating+ 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 width height fmt fptr cacheMe =+ Bitmap $+ bitmapDataOfForeignPtr width height fmt fptr cacheMe+++-- Bitmap width height (bitmapDataOfForeignPtr width height fmt fptr) cacheMe++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+++{-| O(size). Copy a `ByteString` of RGBA data into a bitmap with the given+ width and height.++ The boolean flag controls whether Brillo should cache the data+ between frames for speed. If you are programatically generating+ 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 width height fmt bs cacheMe =+ Bitmap $+ bitmapDataOfByteString width height fmt bs cacheMe+++bitmapDataOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData+bitmapDataOfByteString width height fmt bs cacheMe =+ unsafePerformIO $+ do+ let len = width * height * 4+ ptr <- mallocBytes len+ fptr <- newForeignPtr finalizerFree ptr++ BSU.unsafeUseAsCString bs $+ \cstr -> copyBytes ptr (castPtr cstr) len++ return $ BitmapData len fmt (width, height) cacheMe fptr+{-# NOINLINE bitmapDataOfByteString #-}+++-- | O(size). Copy a `BMP` file into a bitmap.+bitmapOfBMP :: BMP -> Picture+bitmapOfBMP bmp =+ Bitmap $ bitmapDataOfBMP bmp+++-- | O(size). Copy a `BMP` file into a bitmap.+bitmapDataOfBMP :: BMP -> BitmapData+bitmapDataOfBMP bmp =+ unsafePerformIO $+ do+ let (width, height) = bmpDimensions bmp+ let bs = unpackBMPToRGBA32 bmp+ let len = width * height * 4++ ptr <- mallocBytes len+ fptr <- newForeignPtr finalizerFree ptr++ BSU.unsafeUseAsCString bs $+ \cstr -> copyBytes ptr (castPtr cstr) len++ return $ BitmapData len (BitmapFormat BottomToTop PxRGBA) (width, height) True fptr+{-# NOINLINE bitmapDataOfBMP #-}+++-- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap.+loadBMP :: FilePath -> IO Picture+loadBMP filePath =+ do+ ebmp <- readBMP filePath+ case ebmp of+ Left err -> error $ show err+ Right bmp -> return $ bitmapOfBMP bmp+++{-| Construct a rectangle of the given width and height,+ with the lower left corner at the origin.+-}+rectAtOrigin :: Int -> Int -> Rectangle+rectAtOrigin w h = Rectangle (0, 0) (w, h)
+ Brillo/Internals/Rendering/Bitmap.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Helper functions for rendering bitmaps+module Brillo.Internals.Rendering.Bitmap (+ Rectangle (..),+ BitmapData (..),+ BitmapFormat (..),+ PixelFormat (..),+ RowOrder (..),+ bitmapPath,+ freeBitmapData,+)+where++import Data.Data (Data, Typeable)+import Foreign (ForeignPtr, Ptr, Word8, free)+++-- | Represents a rectangular section in a bitmap+data Rectangle+ = Rectangle+ { rectPos :: (Int, Int)+ -- ^ x- and y-pos in the bitmap in pixels+ , rectSize :: (Int, Int)+ -- ^ width/height of the area in pixelsi+ }+ deriving (Show, Read, Eq, Ord, Data, Typeable)+++-- | Abstract 32-bit RGBA bitmap data.+data BitmapData+ = BitmapData+ { bitmapDataLength :: Int -- length (in bytes)+ , bitmapFormat :: BitmapFormat+ , bitmapSize :: (Int, Int)+ -- ^ width, height in pixels+ , bitmapCacheMe :: Bool+ , bitmapPointer :: ForeignPtr Word8+ }+ deriving (Eq, Data, Typeable)+++{-| Description of how the bitmap is layed out in memory.++ * Prior version of Brillo assumed `BitmapFormat BottomToTop PxABGR`+-}+data BitmapFormat+ = BitmapFormat+ { rowOrder :: RowOrder+ , pixelFormat :: PixelFormat+ }+ deriving (Eq, Data, Typeable, Show, Ord)+++{-| Order of rows in an image are either:++ * `TopToBottom` - the top row, followed by the next-lower row and so on.+ * `BottomToTop` - the bottom row followed by the next-higher row and so on.+-}+data RowOrder+ = TopToBottom+ | BottomToTop+ deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded)+++-- | Pixel formats describe the order of the color channels in memory.+data PixelFormat+ = PxRGBA+ | PxABGR+ deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded)+++instance Show BitmapData where+ show _ = "BitmapData"+++-- | Generates the point path to display the bitmap centred+bitmapPath :: Float -> Float -> [(Float, Float)]+bitmapPath width height =+ [ (-width', -height')+ , (width', -height')+ , (width', height')+ , (-width', height')+ ]+ where+ width' = width / 2+ height' = height / 2+++-- | Frees the allocated memory given to OpenGL to avoid a memory leak+freeBitmapData :: Ptr Word8 -> IO ()+freeBitmapData = free+{-# INLINE freeBitmapData #-}
+ Brillo/Internals/Rendering/Circle.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Fast(ish) rendering of circles.+module Brillo.Internals.Rendering.Circle (+ renderCircle,+ renderArc,+)+where++import Brillo.Internals.Rendering.Common (gf)+import GHC.Exts (+ Float (F#),+ Float#,+ cosFloat#,+ divideFloat#,+ geFloat#,+ plusFloat#,+ sinFloat#,+ timesFloat#,+ )+import Graphics.Rendering.OpenGL.GL qualified as GL+++-------------------------------------------------------------------------------++{-| Decide how many line segments to use to render the circle.+ The number of segments we should use to get a nice picture depends on+ the size of the circle on the screen, not its intrinsic radius.+ If the viewport has been zoomed-in then we need to use more segments.+-}+circleSteps :: Float -> Int+circleSteps sDiam+ | sDiam < 8 = 8+ | sDiam < 16 = 16+ | sDiam < 32 = 32+ | otherwise = 64+{-# INLINE circleSteps #-}+++-- Circle ---------------------------------------------------------------------++-- | Render a circle with the given thickness+renderCircle :: Float -> Float -> Float -> Float -> Float -> IO ()+renderCircle 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 lines.+ | thickness == 0+ , radScreen <- scaleFactor * radius+ , steps <- circleSteps radScreen =+ renderCircleLine posX posY steps radius+ -- Some thick circle.+ | radScreen <- scaleFactor * (radius + thickness / 2)+ , steps <- circleSteps radScreen =+ renderCircleStrip posX posY steps radius thickness+++-- | Render a circle as a line.+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)+ in GL.renderPrimitive GL.LineLoop $+ renderCircleLineStep posX posY tStep tStop rad 0.0#+{-# INLINE renderCircleLine #-}+++-- | Render a circle with a given thickness as a triangle strip+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# r1) = r - width / 2+ !(F# r2) = r + width / 2+ in GL.renderPrimitive GL.TriangleStrip $+ renderCircleStripStep+ posX+ posY+ tStep+ tStop+ r1+ 0.0#+ r2+ (tStep `divideFloat#` 2.0#)+{-# INLINE renderCircleStrip #-}+++-- Arc ------------------------------------------------------------------------++-- | Render an arc with the given thickness.+renderArc+ :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO ()+renderArc posX posY scaleFactor radius_ a1 a2 thickness_ =+ go (abs radius_) (abs thickness_)+ where+ go radius thickness+ -- Render zero thickness arcs with lines.+ | thickness == 0+ , radScreen <- scaleFactor * radius+ , steps <- circleSteps radScreen =+ renderArcLine posX posY steps radius a1 a2+ -- Some thick arc.+ | radScreen <- scaleFactor * (radius + thickness / 2)+ , steps <- circleSteps radScreen =+ renderArcStrip posX posY steps radius a1 a2 thickness+++-- | Render an arc as a line.+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# tStart) = degToRad a1+ !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0++ -- force the line to end at the desired angle+ endVertex = addPointOnCircle posX posY rad tStop+ in GL.renderPrimitive GL.LineStrip $+ do+ renderCircleLineStep posX posY tStep tStop rad tStart+ endVertex+{-# 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 =+ let n = fromIntegral steps+ tStep = (2 * pi) / n++ t1 = normalizeAngle $ degToRad a1++ a2' = normalizeAngle $ degToRad a2+ t2 = if a2' == 0 then 2 * pi else a2'++ (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1)+ 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') = r - width / 2+ !(F# r2') = r + width / 2+ 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 renderArcStrip #-}+++-- Step functions -------------------------------------------------------------+renderCircleLineStep+ :: Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> IO ()+renderCircleLineStep posX posY tStep tStop rad tt+ | 1# <- tt `geFloat#` tStop =+ return ()+ | otherwise =+ do+ addPointOnCircle posX posY rad tt+ renderCircleLineStep+ posX+ posY+ tStep+ tStop+ rad+ (tt `plusFloat#` tStep)+{-# INLINE renderCircleLineStep #-}+++renderCircleStripStep+ :: Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> Float#+ -> IO ()+renderCircleStripStep posX posY tStep tStop r1 t1 r2 t2+ | 1# <- t1 `geFloat#` tStop =+ return ()+ | otherwise =+ do+ addPointOnCircle posX posY r1 t1+ addPointOnCircle posX posY r2 t2+ renderCircleStripStep+ posX+ posY+ tStep+ tStop+ r1+ (t1 `plusFloat#` tStep)+ r2+ (t2 `plusFloat#` tStep)+{-# INLINE renderCircleStripStep #-}+++addPoint :: Float# -> Float# -> IO ()+addPoint x y =+ GL.vertex $ GL.Vertex2 (gf (F# x)) (gf (F# y))+{-# INLINE addPoint #-}+++addPointOnCircle :: Float# -> Float# -> Float# -> Float# -> IO ()+addPointOnCircle posX posY rad tt =+ addPoint+ (posX `plusFloat#` (rad `timesFloat#` cosFloat# tt))+ (posY `plusFloat#` (rad `timesFloat#` sinFloat# tt))+{-# INLINE addPointOnCircle #-}+++-- | Convert degrees to radians+degToRad :: Float -> Float+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+ version as well.++-- | Render a sector as a line.+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# tStart) = degToRad a1+ !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0++ -- need to set up the edges of the start/end triangles+ startVertex = GL.vertex $ GL.Vertex2 (gf pX) (gf pY)+ endVertex = addPointOnCircle posX posY rad tStop++ in GL.renderPrimitive GL.LineLoop+ $ do startVertex+ renderCircleLineStep posX posY tStep tStop rad tStart+ endVertex++-- | Render a sector.+renderSector :: Float -> Float -> Float -> Float -> Float -> Float -> IO ()+renderSector posX posY scaleFactor radius a1 a2+ | radScreen <- scaleFactor * radius+ , steps <- circleSteps (2 * radScreen)+ = renderSectorLine posX posY steps radius a1 a2+-}
+ Brillo/Internals/Rendering/Color.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_HADDOCK hide #-}++module Brillo.Internals.Rendering.Color where++import Brillo.Internals.Data.Color (Color (..))+import Graphics.Rendering.OpenGL.GL qualified as GL+import Unsafe.Coerce (unsafeCoerce)+++-- | Convert one of our Colors to OpenGL's representation.+glColor4OfColor :: Color -> GL.Color4 a+glColor4OfColor color =+ case color of+ RGBA r g b a ->+ let rF = unsafeCoerce r+ gF = unsafeCoerce g+ bF = unsafeCoerce b+ aF = unsafeCoerce a+ in GL.Color4 rF gF bF aF+{-# INLINE glColor4OfColor #-}
+ Brillo/Internals/Rendering/Common.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_HADDOCK hide #-}++module Brillo.Internals.Rendering.Common (+ gf,+ gsizei,+ withModelview,+ withClearBuffer,+)+where++import Brillo.Internals.Data.Color (Color)+import Brillo.Internals.Rendering.Color (glColor4OfColor)+import Graphics.Rendering.OpenGL (($=))+import Graphics.Rendering.OpenGL.GL qualified as GL+import Unsafe.Coerce (unsafeCoerce)+++{-| The OpenGL library doesn't seem to provide a nice way convert+ a Float to a GLfloat, even though they're the same thing+ under the covers.++ Using realToFrac is too slow, as it doesn't get fused in at+ least GHC 6.12.1+-}+gf :: Float -> GL.GLfloat+gf = unsafeCoerce+{-# INLINE gf #-}+++-- | Used for similar reasons to above+gsizei :: Int -> GL.GLsizei+gsizei = unsafeCoerce+{-# INLINE gsizei #-}+++{-| 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 (sizeX, sizeY) action =+ do+ GL.matrixMode $= GL.Projection+ GL.preservingMatrix $+ do+ -- setup the co-ordinate system+ GL.loadIdentity+ let (sx, sy) = (fromIntegral sizeX / 2, fromIntegral sizeY / 2)+ GL.ortho (-sx) sx (-sy) sy 0 (-100)++ -- draw the world+ GL.matrixMode $= GL.Modelview 0+ action++ GL.matrixMode $= GL.Projection++ GL.matrixMode $= GL.Modelview 0+++{-| 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 clearColor action =+ do+ -- initialization (done every time in this case)+ -- we don't need the depth buffer for 2d.+ GL.depthFunc GL.$= Just GL.Always++ -- always clear the buffer to white+ GL.clearColor GL.$= glColor4OfColor clearColor++ -- on every loop+ GL.clear [GL.ColorBuffer, GL.DepthBuffer]+ GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat)++ action
+ Brillo/Internals/Rendering/Picture.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_HADDOCK hide #-}++{-# HLINT ignore "Use bimap" #-}+{-# HLINT ignore "Use unless" #-}++module Brillo.Internals.Rendering.Picture (renderPicture)+where++import Control.Monad (forM_, when)+import Data.IORef (IORef, readIORef, writeIORef)+import Data.List (find)+import Foreign.ForeignPtr (withForeignPtr)+import Graphics.Rendering.OpenGL (get, ($=))+import Graphics.Rendering.OpenGL.GL qualified as GL+import Graphics.Rendering.OpenGL.GLU.Errors qualified as GLU+import System.Mem.StableName (makeStableName)++import Brillo.Internals.Data.Color (Color (RGBA))+import Brillo.Internals.Data.Picture (+ BitmapFormat (pixelFormat, rowOrder),+ Picture (..),+ PixelFormat (PxABGR, PxRGBA),+ Rectangle (Rectangle, rectPos, rectSize),+ RowOrder (BottomToTop, TopToBottom),+ rectAtOrigin,+ )+import Brillo.Internals.Rendering.Bitmap (BitmapData (..), bitmapPath)+import Brillo.Internals.Rendering.Circle (renderArc, renderCircle)+import Brillo.Internals.Rendering.Common (gf, gsizei)+import Brillo.Internals.Rendering.State (+ State (+ stateBlendAlpha,+ stateColor,+ stateLineSmooth,+ stateTextures,+ stateWireframe+ ),+ Texture (..),+ )+import Brillo.Internals.Rendering.VectorFont as VF (canvastextFont, renderSafe)+++{-| Render a picture into the current OpenGL context.++ Assumes that the OpenGL matrix mode is set to @Modelview@+-}+renderPicture+ :: State+ -- ^ Current rendering state.+ -> Float+ -- ^ View port scale, which controls the level of detail.+ -- Use 1.0 to start with.+ -> Picture+ -- ^ Picture to render.+ -> IO ()+renderPicture state circScale picture =+ do+ -- Setup render state for world+ setLineSmooth (stateLineSmooth state)+ setBlendAlpha (stateBlendAlpha state)++ -- Draw the picture+ checkErrors "before drawPicture."+ drawPicture state circScale picture+ checkErrors "after drawPicture."+++drawPicture :: State -> Float -> Picture -> IO ()+drawPicture state circScale picture =+ {-# SCC "drawComponent" #-}+ case picture of+ -- nothin'+ Blank ->+ return ()+ -- line+ Line path ->+ GL.renderPrimitive GL.LineStrip $+ vertexPFs path+ -- polygon (where?)+ Polygon path+ | stateWireframe state ->+ GL.renderPrimitive GL.LineLoop $+ vertexPFs path+ | otherwise ->+ GL.renderPrimitive GL.Polygon $+ vertexPFs path+ -- circle+ Circle radius ->+ renderCircle 0 0 circScale radius 0+ ThickCircle radius thickness ->+ renderCircle 0 0 circScale radius thickness+ -- arc+ Arc a1 a2 radius ->+ renderArc 0 0 circScale radius a1 a2 0+ ThickArc a1 a2 radius thickness ->+ renderArc 0 0 circScale radius a1 a2 thickness+ -- Vector font text+ Text str -> do+ let+ characters :: [[(Double, Double)]]+ characters = renderSafe canvastextFont str++ 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++ -- colors with float components.+ Color col p+ | stateColor state -> do+ oldColor <- get GL.currentColor++ let RGBA r g b a = col++ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)+ drawPicture state circScale p+ GL.currentColor $= oldColor+ | otherwise ->+ drawPicture state circScale p+ -- Translation --------------------------+ -- Easy translations are done directly to avoid calling GL.perserveMatrix.+ Translate posX posY (Circle radius) ->+ renderCircle posX posY circScale radius 0+ Translate posX posY (ThickCircle radius thickness) ->+ renderCircle posX posY circScale radius thickness+ Translate posX posY (Arc a1 a2 radius) ->+ renderArc posX posY circScale radius a1 a2 0+ Translate posX posY (ThickArc a1 a2 radius thickness) ->+ renderArc posX posY circScale radius a1 a2 thickness+ Translate tx ty (Rotate deg p) ->+ GL.preservingMatrix $+ do+ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)+ GL.rotate (gf deg) (GL.Vector3 0 0 (-1))+ drawPicture state circScale p+ Translate tx ty p ->+ GL.preservingMatrix $+ do+ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)+ drawPicture state circScale p++ -- Rotation -----------------------------+ -- Easy rotations are done directly to avoid calling GL.perserveMatrix.+ Rotate _ (Circle radius) ->+ renderCircle 0 0 circScale radius 0+ Rotate _ (ThickCircle radius thickness) ->+ renderCircle 0 0 circScale radius thickness+ Rotate deg (Arc a1 a2 radius) ->+ renderArc 0 0 circScale radius (a1 - deg) (a2 - deg) 0+ Rotate deg (ThickArc a1 a2 radius thickness) ->+ renderArc 0 0 circScale radius (a1 - deg) (a2 - deg) thickness+ Rotate deg p ->+ GL.preservingMatrix $+ do+ GL.rotate (gf deg) (GL.Vector3 0 0 (-1))+ drawPicture state circScale p++ -- Scale --------------------------------+ Scale sx sy p ->+ GL.preservingMatrix $+ do+ GL.scale (gf sx) (gf sy) 1+ let mscale = max sx sy+ drawPicture state (circScale * mscale) p+ Bitmap imgData ->+ let (width, height) = bitmapSize imgData+ in drawPicture state circScale $+ BitmapSection (rectAtOrigin width height) imgData+ BitmapSection+ Rectangle+ { rectPos = imgSectionPos+ , rectSize = imgSectionSize+ }+ imgData@BitmapData+ { bitmapSize = (width, height)+ , bitmapCacheMe = cacheMe+ } ->+ do+ let rowInfo =+ -- calculate texture coordinates+ -- remark:+ -- On some hardware, using exact "integer" coordinates causes texture coords+ -- with a component == 0 flip to -1. This appears as the texture flickering+ -- on the left and sometimes show one additional row of pixels outside the+ -- given rectangle+ -- To prevent this we add an "epsilon-border".+ -- This has been testet to fix the problem.+ let defTexCoords =+ map+ (\(x, y) -> (x / fromIntegral width, y / fromIntegral height))+ [ vecMap (+ eps) (+ eps) $ toFloatVec imgSectionPos+ , vecMap (subtract eps) (+ eps) $+ toFloatVec+ ( fst imgSectionPos + fst imgSectionSize+ , snd imgSectionPos+ )+ , vecMap (subtract eps) (subtract eps) $+ toFloatVec+ ( fst imgSectionPos + fst imgSectionSize+ , snd imgSectionPos + snd imgSectionSize+ )+ , vecMap (+ eps) (subtract eps) $+ toFloatVec+ ( fst imgSectionPos+ , snd imgSectionPos + snd imgSectionSize+ )+ ]+ :: [(Float, Float)]+ toFloatVec = vecMap fromIntegral fromIntegral+ vecMap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)+ vecMap f g (x, y) = (f x, g y)+ eps = 0.001 :: Float+ in case rowOrder (bitmapFormat imgData) of+ BottomToTop -> defTexCoords+ TopToBottom -> reverse defTexCoords++ -- 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++ -- Set up wrap and filtering mode+ GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)+ GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)+ GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)++ -- Enable texturing+ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureFunction $= GL.Combine++ -- Set current texture+ GL.textureBinding GL.Texture2D $= Just (texObject tex)++ -- Set to opaque+ oldColor <- get GL.currentColor+ GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0++ -- Draw textured polygon+ GL.renderPrimitive GL.Polygon+ $ forM_+ ( bitmapPath+ (fromIntegral $ fst imgSectionSize)+ (fromIntegral $ snd imgSectionSize)+ `zip` rowInfo+ )+ $ \((polygonCoordX, polygonCoordY), (textureCoordX, textureCoordY)) ->+ do+ GL.texCoord $ GL.TexCoord2 (gf textureCoordX) (gf textureCoordY)+ GL.vertex $ GL.Vertex2 (gf polygonCoordX) (gf polygonCoordY)++ -- Restore color+ GL.currentColor $= oldColor++ -- Disable texturing+ GL.texture GL.Texture2D $= GL.Disabled++ -- Free uncachable texture objects.+ freeTexture tex+ Pictures ps ->+ mapM_ (drawPicture state circScale) ps+++-- Errors ---------------------------------------------------------------------+checkErrors :: String -> IO ()+checkErrors place =+ do+ errors <- get GLU.errors+ when (not $ null errors) $+ mapM_ (handleError place) errors+++handleError :: String -> GLU.Error -> IO ()+handleError place err =+ case err of+ GLU.Error GLU.StackOverflow _ ->+ error $+ unlines+ [ "Brillo / OpenGL Stack Overflow " ++ show place+ , " This program uses the Brillo vector graphics library, which tried to"+ , " draw a picture using more nested transforms (Translate/Rotate/Scale)"+ , " than your OpenGL implementation supports. The OpenGL spec requires"+ , " all implementations to have a transform stack depth of at least 32,"+ , " and Brillo tries not to push the stack when it doesn't have to, but"+ , " that still wasn't enough."+ , ""+ , " You should complain to your harware vendor that they don't provide"+ , " a better way to handle this situation at the OpenGL API level."+ , ""+ , " To make this program work you'll need to reduce the number of nested"+ , " transforms used when defining the Picture given to Brillo. Sorry."+ ]+ _ ->+ error $+ unlines+ [ "Brillo / OpenGL Internal Error " ++ show place+ , " Please report this at https://github.com/ad-si/Brillo/issues."+ , show err+ ]+++-- Textures -------------------------------------------------------------------++{-| Load a texture into the OpenGL context, or retrieve the existing handle+ from our own cache.+-}+loadTexture+ :: IORef [Texture]+ -- ^ Existing texture cache.+ -> BitmapData+ -- ^ Texture data.+ -> Bool+ -- ^ Force cache for newly loaded textures.+ -> IO Texture+loadTexture refTextures imgData@BitmapData{bitmapSize = (width, height)} cacheMe =+ do+ textures <- readIORef refTextures++ -- Try and find this same texture in the cache.+ name <- makeStableName imgData+ let mTexCached =+ find+ ( \tex ->+ texName tex == name+ && texWidth tex == width+ && texHeight tex == height+ )+ textures++ case mTexCached of+ Just tex ->+ return tex+ Nothing ->+ do+ tex <- installTexture imgData+ when cacheMe $+ writeIORef refTextures (tex : textures)+ return tex+++{-| Install a texture into the OpenGL context,+ returning the new texture handle.+-}+installTexture :: BitmapData -> IO Texture+installTexture bitmapData@(BitmapData _ fmt (width, height) cacheMe fptr) =+ do+ let glFormat =+ case pixelFormat fmt of+ PxABGR -> GL.ABGR+ PxRGBA -> GL.RGBA++ -- Allocate texture handle for texture+ [tex] <- GL.genObjectNames 1+ GL.textureBinding GL.Texture2D $= Just tex++ -- Sets the texture in imgData as the current texture+ -- This copies the data from the pointer into OpenGL texture memory,+ -- so it's ok if the foreignptr gets garbage collected after this.+ withForeignPtr fptr $+ \ptr ->+ GL.texImage2D+ GL.Texture2D+ GL.NoProxy+ 0+ GL.RGBA8+ ( GL.TextureSize2D+ (gsizei width)+ (gsizei height)+ )+ 0+ (GL.PixelData glFormat GL.UnsignedByte ptr)++ -- Make a stable name that we can use to identify this data again.+ -- If the user gives us the same texture data at the same size then we+ -- can avoid loading it into texture memory again.+ name <- makeStableName bitmapData++ return+ Texture+ { texName = name+ , texWidth = width+ , texHeight = height+ , texData = fptr+ , texObject = tex+ , texCacheMe = cacheMe+ }+++{-| If this texture does not have its `cacheMe` flag set then delete it from+ OpenGL and free the GPU memory.+-}+freeTexture :: Texture -> IO ()+freeTexture tex+ | texCacheMe tex = return ()+ | otherwise = GL.deleteObjectNames [texObject tex]+++-- Utils ----------------------------------------------------------------------++-- | Turn alpha blending on or off+setBlendAlpha :: Bool -> IO ()+setBlendAlpha state+ | state =+ do+ GL.blend $= GL.Enabled+ GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+ | otherwise =+ do+ GL.blend $= GL.Disabled+ GL.blendFunc $= (GL.One, GL.Zero)+++-- | Turn line smoothing on or off+setLineSmooth :: Bool -> IO ()+setLineSmooth state+ | state = GL.lineSmooth $= GL.Enabled+ | otherwise = GL.lineSmooth $= GL.Disabled+++vertexPFs :: [(Float, Float)] -> IO ()+vertexPFs [] = return ()+vertexPFs ((x, y) : rest) =+ do+ GL.vertex $ GL.Vertex2 (gf x) (gf y)+ vertexPFs rest+{-# INLINE vertexPFs #-}
+ Brillo/Internals/Rendering/State.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_HADDOCK hide #-}++-- | Rendering options+module Brillo.Internals.Rendering.State (+ State (..),+ initState,+ Texture (..),+)+where++import Brillo.Internals.Rendering.Bitmap (BitmapData)+import Data.IORef (IORef, newIORef)+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr)+import Graphics.Rendering.OpenGL.GL qualified as GL+import System.Mem.StableName (StableName)+++{-| Abstract Brillo render state which holds references to textures+ loaded into the GPU context.+-}+data State+ = State+ { stateColor :: !Bool+ -- ^ Whether to use color+ , stateWireframe :: !Bool+ -- ^ Whether to force wireframe mode only+ , stateBlendAlpha :: !Bool+ -- ^ Whether to use alpha blending+ , stateLineSmooth :: !Bool+ -- ^ Whether to use line smoothing+ , stateTextures :: !(IORef [Texture])+ -- ^ Cache of Textures that we've sent to OpenGL.+ }+++-- | A texture that we've sent to OpenGL.+data Texture+ = Texture+ { texName :: StableName BitmapData+ -- ^ Stable name derived from the `BitmapData` that the user gives us.+ , texWidth :: Int+ -- ^ Width of the image, in pixels.+ , texHeight :: Int+ -- ^ Height of the image, in pixels.+ , texData :: ForeignPtr Word8+ -- ^ Pointer to the Raw texture data.+ , texObject :: GL.TextureObject+ -- ^ The OpenGL texture object.+ , texCacheMe :: Bool+ -- ^ Whether we want to leave this in OpenGL texture memory between frames.+ }+++{-| A mutable render state holds references to the textures currently loaded+ into the OpenGL context. To ensure that textures are cached in GPU memory,+ pass the same `State` each time you call `displayPicture` or `renderPicture`.+-}+initState :: IO State+initState =+ do+ textures <- newIORef []+ return+ State+ { stateColor = True+ , stateWireframe = False+ , stateBlendAlpha = True+ , stateLineSmooth = False+ , stateTextures = textures+ }
+ Brillo/Internals/Rendering/VectorFont.hs view
@@ -0,0 +1,342 @@+-- | Inspired by https://hackage.haskell.org/package/VectorFont+module Brillo.Internals.Rendering.VectorFont (+ VectorFont,+ VFWidth,+ VFPoint,+ VFStroke,+ VFGlyph,+ render,+ renderSafe,+ optimizeStrokes,+ canvastextFont,+) where++import Control.Monad (replicateM, (>=>))+import Data.Either (partitionEithers)+import Data.List (minimumBy, permutations)+import Data.Map (Map, findWithDefault, fromList, lookup)+import Data.Ord (comparing)+++type VFWidth = Double+type VFPoint = (Double, Double)+++-- | @VFStroke@ is a series of points joined by straight lines.+type VFStroke = [VFPoint]+++-- | @VFGlyph@ is the symbol's width, plus the strokes needed to draw it+type VFGlyph = (VFWidth, [VFStroke])+++dist :: VFPoint -> VFPoint -> Double+dist (xa, ya) (xb, yb) =+ sqrt $ (xa - xb) ^ (2 :: Int) + (ya - yb) ^ (2 :: Int)+++-- | @VectorFont@ is a map from @Char@ to @VFGlyph@+newtype VectorFont = VectorFont (Map Char VFGlyph)+++{-| Given a @VectorFont@ and a @String@, return+ * @Right@ strokes if the @String@ can be rendered.+ * @Left@ error otherwise.+-}+render :: VectorFont -> String -> Either String [VFStroke]+render f =+ getGlyphs f >=> (Right . renderLine 0)+++getGlyphs :: VectorFont -> String -> Either String [VFGlyph]+getGlyphs f =+ addErrorMsg . leftsOrRights . map (getGlyph f)+++addErrorMsg :: Either String a -> Either String a+addErrorMsg (Left a) = Left $ "Missing chars: " ++ a+addErrorMsg a = a+++-- | Like @T.sequence@ but gives all the @Left@s if any exist+leftsOrRights :: [Either a b] -> Either [a] [b]+leftsOrRights = do+ let+ pick ([], bs) = Right bs+ pick (as, _) = Left as+ pick . partitionEithers+++getGlyph :: VectorFont -> Char -> Either Char VFGlyph+getGlyph (VectorFont m) c =+ maybe (Left c) Right $ c `Data.Map.lookup` m+++{-| Like @render@, but replaces unknown characters with a question mark.++It is guaranteed to render something, and thus+useful if you want to ignore the possibility of errors e.g.+because you're manually checking the output.+-}+renderSafe :: VectorFont -> String -> [VFStroke]+renderSafe f =+ renderLine 0 . map (getGlyphSafe f)+++getGlyphSafe :: VectorFont -> Char -> VFGlyph+getGlyphSafe (VectorFont m) c =+ findWithDefault fallbackGlyph c m+++{-| This is the `?` from @canvastextFont@,+duplicated here to avoid constraining @canvastextFont@ to contain `?`+-}+fallbackGlyph :: VFGlyph+fallbackGlyph =+ ( 18+ , optimizeStrokes+ [+ [ (3, 16)+ , (3, 17)+ , (4, 19)+ , (5, 20)+ , (7, 21)+ , (11, 21)+ , (13, 20)+ , (14, 19)+ , (15, 17)+ , (15, 15)+ , (14, 13)+ , (13, 12)+ , (9, 10)+ , (9, 7)+ ]+ , [(9, 2), (8, 1), (9, 0), (10, 1), (9, 2)]+ ]+ )+++renderLine :: VFWidth -> [VFGlyph] -> [VFStroke]+renderLine _ [] = []+renderLine dx ((w, ss) : sss) = do+ let offset = (fmap . fmap) (\(x, y) -> (x + dx, y))+ offset ss ++ renderLine (dx + w) sss+++{-| Given a set of strokes, try to optimize their order and direction:+* Fewer strokes+* Smaller gaps between strokes+* Left-most starting position+* Bottom-most starting position++This improves the fonts where no thought has been given to this.+However, hand-tweaking is still better.+-}+optimizeStrokes :: [VFStroke] -> [VFStroke]+optimizeStrokes = do+ let pickBest = minimumBy (comparing score)+ pickBest . map joinStrokes . allArrangements . filter (not . null)+++allArrangements :: [[a]] -> [[[a]]]+allArrangements =+ concatMap allDirs . permutations+++allDirs :: [[a]] -> [[[a]]]+allDirs strokes = do+ let opss = replicateM (length strokes) [id, reverse]+ [zipWith ($) ops strokes | ops <- opss]+++-- given an arrangement of strokes, return a score (lower better),+-- preferring (in order):+score :: [VFStroke] -> (Int, Double, VFPoint)+score ss | length ss < 2 = (length ss, 0.0, (0.0, 0.0))+score ss = do+ let+ skips = zipWith (\as bs -> dist (last as) (head bs)) ss (tail ss)+ firstPoint = head $ head ss+ (length ss, sum skips, firstPoint)+++joinStrokes :: (Eq a) => [[a]] -> [[a]]+joinStrokes (s0 : s1 : ss)+ | last s0 == head s1 = joinStrokes $ (s0 ++ tail s1) : ss+ | otherwise = s0 : joinStrokes (s1 : ss)+joinStrokes ss = ss++{- FOURMOLU_DISABLE -}+-- | Based on Hershey font and includes following characters:+-- @!\"#$%&()*+,-.\/0123456789:;\<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ+-- []^_\`abcdefghijklmnopqrstuvwxyz{|}~@+canvastextFont :: VectorFont+canvastextFont = VectorFont $ fromList+ [ (' ',(12,[]))+ , ('!',(6,[[(5,2),(4,1),(5,0),(6,1),(5,2)],[(5,7),(5,21)]]))+ , ('"',(6,[[(4,15),(5,16),(6,18),(6,20),(5,21),(4,20),(5,19)]]))+ , ('#',(17,[[(10,-7),(17,25)],[(11,25),(4,-7)]+ ,[(3,6),(17,6)],[(18,12),(4,12)]]))+ , ('$',(16,[[(3,3),(5,1),(8,0),(12,0),(15,1),(17,3),(17,6),(16,8),(15,9)+ ,(13,10),(7,12),(5,13),(4,14),(3,16),(3,18),(5,20),(8,21),(12,21)+ ,(15,20),(17,18)],[(12,25),(12,-4)],[(8,-4),(8,25)]]))+ , ('%',(20,[[(8,21),(10,19),(10,17),(9,15),(7,14),(5,14),(3,16),(3,18)+ ,(4,20),(6,21),(8,21),(10,20),(13,19),(16,19),(19,20),(21,21),(3,0)]+ ,[(17,7),(15,6),(14,4),(14,2),(16,0)+ ,(18,0),(20,1),(21,3),(21,5),(19,7),(17,7)]]))+ , ('&',(22,[[(23,2),(23,1),(22,0),(20,0),(18,1),(16,3),(11,10),(9,13)+ ,(8,16),(8,18),(9,20),(11,21),(13,20),(14,18),(14,16),(13,14),(12,13)+ ,(5,9),(4,8),(3,6),(3,4),(4,2),(5,1),(7,0),(11,0),(13,1),(15,3),(17,6)+ ,(19,11),(20,13),(21,14),(22,14),(23,13),(23,12)]]))+ , ('(',(10,[[(11,-7),(9,-5),(7,-2),(5,2)+ ,(4,7),(4,11),(5,16),(7,20),(9,23),(11,25)]]))+ , (')',(10,[[(3,-7),(5,-5),(7,-2),(9,2)+ ,(10,7),(10,11),(9,16),(7,20),(5,23),(3,25)]]))+ , ('*',(12,[[(3,12),(13,18)],[(8,21),(8,9)],[(13,12),(3,18)]]))+ , ('+',(22,[[(4,9),(22,9)],[(13,0),(13,18)]]))+ , (',',(6,[[(4,-4),(5,-3),(6,-1),(6,1),(5,2),(4,1),(5,0),(6,1)]]))+ , ('-',(22,[[(4,9),(22,9)]]))+ , ('.',(6,[[(5,2),(4,1),(5,0),(6,1),(5,2)]]))+ , ('/',(18,[[(2,-7),(20,25)]]))+ , ('0',(16,[[(9,21),(6,20),(4,17),(3,12),(3,9),(4,4),(6,1),(9,0),(11,0)+ ,(14,1),(16,4),(17,9),(17,12),(16,17),(14,20),(11,21),(9,21)]]))+ , ('1',(16,[[(6,17),(8,18),(11,21),(11,0)]]))+ , ('2',(16,[[(4,16),(4,17),(5,19),(6,20),(8,21),(12,21),(14,20),(15,19)+ ,(16,17),(16,15),(15,13),(13,10),(3,0),(17,0)]]))+ , ('3',(16,[[(3,4),(4,2),(5,1),(8,0),(11,0),(14,1),(16,3),(17,6),(17,8)+ ,(16,11),(15,12),(13,13),(10,13),(16,21),(5,21)]]))+ , ('4',(16,[[(13,0),(13,21),(3,7),(18,7)]]))+ , ('5',(16,[[(3,4),(4,2),(5,1),(8,0),(11,0),(14,1),(16,3),(17,6),(17,8)+ ,(16,11),(14,13),(11,14),(8,14),(5,13),(4,12),(5,21),(15,21)]]))+ , ('6',(16,[[(4,7),(5,10),(7,12),(10,13),(11,13),(14,12),(16,10),(17,7)+ ,(17,6),(16,3),(14,1),(11,0),(10,0),(7,1),(5,3)+ ,(4,7),(4,12),(5,17),(7,20),(10,21),(12,21),(15,20),(16,18)]]))+ , ('7',(16,[[(3,21),(17,21),(7,0)]]))+ , ('8',(16,[[(8,21),(5,20),(4,18),(4,16),(5,14),(7,13),(11,12),(14,11),(16,9)+ ,(17,7),(17,4),(16,2),(15,1),(12,0),(8,0),(5,1),(4,2),(3,4),(3,7),(4,9)+ ,(6,11),(9,12),(13,13),(15,14),(16,16),(16,18),(15,20),(12,21),(8,21)]]))+ , ('9',(16,[[(4,3),(5,1),(8,0),(10,0),(13,1),(15,4),(16,9),(16,14),(15,18)+ ,(13,20),(10,21),(9,21),(6,20),(4,18),(3,15),(3,14),(4,11),(6,9),(9,8)+ ,(10,8),(13,9),(15,11),(16,14)]]))+ , (':',(6,[[(5,2),(4,1),(5,0),(6,1),(5,2)]+ ,[(5,14),(4,13),(5,12),(6,13),(5,14)]]))+ , (';',(6,[[(4,-4),(5,-3),(6,-1),(6,1),(5,2),(4,1),(5,0),(6,1)]+ ,[(5,14),(4,13),(5,12),(6,13),(5,14)]]))+ , ('<',(20,[[(20,0),(4,9),(20,18)]]))+ , ('=',(22,[[(4,6),(22,6)],[(22,12),(4,12)]]))+ , ('>',(20,[[(4,0),(20,9),(4,18)]]))+ , ('?',(14,[[(3,16),(3,17),(4,19),(5,20),(7,21),(11,21),(13,20),(14,19)+ ,(15,17),(15,15),(14,13),(13,12),(9,10),(9,7)]+ ,[(9,2),(8,1),(9,0),(10,1),(9,2)]]))+ , ('@',(23,[[(11,5),(10,6),(9,8),(9,11),(10,14),(12,16)],[(18,13),(17,15)+ ,(15,16),(12,16),(10,15),(9,14),(8,11),(8,8),(9,6),(11,5),(14,5),(16,6)+ ,(17,8)],[(19,5),(18,6),(18,8),(19,16)],[(18,16),(17,8),(17,6),(19,5)+ ,(21,5),(23,7),(24,10),(24,12),(23,15),(22,17),(20,19),(18,20),(15,21)+ ,(12,21),(9,20),(7,19),(5,17),(4,15),(3,12),(3,9),(4,6),(5,4),(7,2)+ ,(9,1),(12,0),(15,0),(18,1),(20,2),(21,3)]]))+ , ('A',(14,[[(1,0),(9,21),(17,0)],[(14,7),(4,7)]]))+ , ('B',(17,[[(4,11),(13,11),(16,10),(17,9),(18,7),(18,4),(17,2),(16,1)+ ,(13,0),(4,0),(4,21),(13,21),(16,20),(17,19)+ ,(18,17),(18,15),(17,13),(16,12),(13,11)]]))+ , ('C',(17,[[(18,5),(17,3),(15,1),(13,0),(9,0),(7,1),(5,3),(4,5),(3,8),(3,13)+ ,(4,16),(5,18),(7,20),(9,21),(13,21),(15,20),(17,18),(18,16)]]))+ , ('D',(17,[[(4,0),(4,21),(11,21),(14,20),(16,18),(17,16),(18,13),(18,8)+ ,(17,5),(16,3),(14,1),(11,0),(4,0)]]))+ , ('E',(15,[[(4,11),(12,11)],[(17,21),(4,21),(4,0),(17,0)]]))+ , ('F',(14,[[(12,11),(4,11)],[(4,0),(4,21),(17,21)]]))+ , ('G',(17,[[(13,8),(18,8),(18,5),(17,3),(15,1),(13,0),(9,0),(7,1),(5,3)+ ,(4,5),(3,8),(3,13),(4,16),(5,18),(7,20)+ ,(9,21),(13,21),(15,20),(17,18),(18,16)]]))+ , ('H',(16,[[(4,0),(4,21)],[(4,11),(16,11)],[(16,21),(16,0)]]))+ , ('I',(6,[[(4,0),(4,21)]]))+ , ('J',(12,[[(2,7),(2,5),(3,2),(4,1)+ ,(6,0),(8,0),(10,1),(11,2),(12,5),(12,21)]]))+ , ('K',(17,[[(18,0),(9,12)],[(4,21),(4,0)],[(4,7),(18,21)]]))+ , ('L',(13,[[(4,21),(4,0),(16,0)]]))+ , ('M',(20,[[(4,0),(4,21),(12,0),(20,21),(20,0)]]))+ , ('N',(18,[[(4,0),(4,21),(18,0),(18,21)]]))+ , ('O',(18,[[(9,21),(7,20),(5,18),(4,16),(3,13),(3,8),(4,5),(5,3),(7,1),(9,0)+ ,(13,0),(15,1),(17,3),(18,5),(19,8)+ ,(19,13),(18,16),(17,18),(15,20),(13,21),(9,21)]]))+ , ('P',(17,[[(4,0),(4,21),(13,21),(16,20),(17,19)+ ,(18,17),(18,14),(17,12),(16,11),(13,10),(4,10)]]))+ , ('Q',(18,[[(9,21),(7,20),(5,18),(4,16),(3,13),(3,8),(4,5),(5,3),(7,1),(9,0)+ ,(13,0),(15,1),(17,3),(18,5),(19,8),(19,13),(18,16)+ ,(17,18),(15,20),(13,21),(9,21)],[(12,4),(18,-2)]]))+ , ('R',(17,[[(4,0),(4,21),(13,21),(16,20),(17,19),(18,17),(18,15),(17,13)+ ,(16,12),(13,11),(4,11)],[(11,11),(18,0)]]))+ , ('S',(16,[[(3,3),(5,1),(8,0),(12,0),(15,1),(17,3),(17,6),(16,8),(15,9)+ ,(13,10),(7,12),(5,13),(4,14),(3,16),(3,18)+ ,(5,20),(8,21),(12,21),(15,20),(17,18)]]))+ , ('T',(12,[[(1,21),(15,21)],[(8,21),(8,0)]]))+ , ('U',(18,[[(4,21),(4,6),(5,3),(7,1)+ ,(10,0),(12,0),(15,1),(17,3),(18,6),(18,21)]]))+ , ('V',(14,[[(1,21),(9,0),(17,21)]]))+ , ('W',(20,[[(2,21),(7,0),(12,15),(17,0),(22,21)]]))+ , ('X',(16,[[(3,0),(17,21)],[(3,21),(17,0)]]))+ , ('Y',(14,[[(1,21),(9,11),(9,0)],[(9,11),(17,21)]]))+ , ('Z',(16,[[(3,21),(17,21),(3,0),(17,0)]]))+ , ('[',(10,[[(5,-7),(5,25)],[(11,25),(4,25),(4,-7),(11,-7)]]))+ , (']',(10,[[(3,-7),(10,-7),(10,25),(3,25)],[(9,25),(9,-7)]]))+ , ('^',(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)+ ,(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)+ ,(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)]]))+ , ('e',(14,[[(3,8),(14,8),(14,10),(13,12),(12,13),(10,14),(8,14),(6,13),(4,11)+ ,(3,8),(3,6),(4,3),(6,1),(8,0),(10,0),(12,1),(14,3)]]))+ , ('f',(8,[[(2,14),(9,14)],[(10,21),(8,21),(6,20),(5,17),(5,0)]]))+ , ('g',(15,[[(6,-6),(8,-7),(11,-7),(13,-6),(14,-5),(15,-2),(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)]]))+ , ('h',(15,[[(4,21),(4,0)],[(4,10),(7,13)+ ,(9,14),(12,14),(14,13),(15,10),(15,0)]]))+ , ('i',(6,[[(3,21),(4,20),(5,21),(4,22),(3,21)],[(4,14),(4,0)]]))+ , ('j',(6,[[(1,-7),(3,-7),(5,-6),(6,-3),(6,14)]+ ,[(5,21),(6,20),(7,21),(6,22),(5,21)]]))+ , ('k',(13,[[(4,21),(4,0)],[(4,4),(14,14)],[(8,8),(15,0)]]))+ , ('l',(6,[[(3,0),(3,21)]]))+ , ('m',(26,[[(4,0),(4,14)]+ ,[(4,10),(7,13),(9,14),(12,14),(14,13),(15,10),(15,0)]+ ,[(15,10),(18,13),(20,14),(23,14),(25,13),(26,10),(26,0)]]))+ , ('n',(15,[[(4,0),(4,14)]+ ,[(4,10),(7,13),(9,14),(12,14),(14,13),(15,10),(15,0)]]))+ , ('o',(14,[[(11,3),(10,1),(8,0),(6,0),(4,1),(3,3),(2,5),(2,7),(2,9),(3,11)+ ,(4,13),(6,14),(8,14),(10,13),(11,11),(12,9),(12,7),(12,5),(11,3)]]))+ , ('p',(15,[[(4,-7),(4,14)],[(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)]]))+ , ('q',(15,[[(15,-7),(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)]]))+ , ('r',(9,[[(3,0),(3,14)],[(3,8),(4,11),(6,13),(8,14),(10,14)]]))+ , ('s',(13,[[(3,3),(4,1),(7,0),(10,0),(13,1),(14,3),(14,4),(13,6),(11,7),(6,8)+ ,(4,9),(3,11),(4,13),(7,14),(10,14),(13,13),(14,11)]]))+ , ('t',(8,[[(9,14),(2,14)],[(5,21),(5,4),(6,1),(8,0),(10,0)]]))+ , ('u',(15,[[(4,14),(4,4),(5,1),(7,0),(10,0),(12,1),(15,4)]+ ,[(15,0),(15,14)]]))+ , ('v',(12,[[(2,14),(8,0),(14,14)]]))+ , ('w',(18,[[(3,14),(7,0),(11,14),(15,0),(19,14)]]))+ , ('x',(13,[[(3,0),(14,14)],[(3,14),(14,0)]]))+ , ('y',(12,[[(2,14),(8,0)],[(1,-7),(2,-7),(4,-6),(6,-4),(8,0),(14,14)]]))+ , ('z',(13,[[(3,14),(14,14),(3,0),(14,0)]]))+ , ('{',(10,[[(7,-6),(6,-4),(6,-2),(7,0),(8,1),(9,3),(9,5),(8,7),(4,9),(8,11)+ ,(9,13),(9,15),(8,17),(7,18),(6,20),(6,22),(7,24)],[(9,25),(7,24),(6,23)+ ,(5,21),(5,19),(6,17),(7,16),(8,14),(8,12),(6,10)],[(6,8),(8,6),(8,4)+ ,(7,2),(6,1),(5,-1),(5,-3),(6,-5),(7,-6),(9,-7)]]))+ , ('|',(6,[[(4,-7),(4,25)]]))+ , ('}',(10,[[(5,-7),(7,-6),(8,-5),(9,-3),(9,-1),(8,1),(7,2),(6,4),(6,6),(8,8)]+ ,[(8,10),(6,12),(6,14),(7,16),(8,17),(9,19),(9,21),(8,23),(7,24),(5,25)]+ ,[(7,24),(8,22),(8,20),(7,18),(6,17),(5,15),(5,13),(6,11),(10,9),(6,7)+ ,(5,5),(5,3),(6,1),(7,0),(8,-2),(8,-4),(7,-6)]]))+ , ('~',(20+ ,[[(3,6),(3,8),(4,11),(6,12),(8,12),(10,11)+ ,(14,8),(16,7),(18,7),(20,8),(21,10)]+ ,[(21,12),(21,10),(20,7),(18,6),(16,6),(14,7)+ ,(10,10),(8,11),(6,11),(4,10),(3,8)]]))+ ]+{- FOURMOLU_ENABLE -}
+ Brillo/Rendering.hs view
@@ -0,0 +1,76 @@+module Brillo.Rendering (+ -- * Picture data type+ Picture (..),+ Point,+ Vector,+ Path,++ -- * Colors+ Color,+ makeColor,+ makeColorI,+ makeRawColor,+ makeRawColorI,+ rgbaOfColor,+ clampColor,++ -- * Bitmaps+ Rectangle (..),+ BitmapData,+ bitmapSize,+ BitmapFormat (..),+ PixelFormat (..),+ RowOrder (..),+ bitmapOfForeignPtr,+ bitmapDataOfForeignPtr,+ bitmapOfByteString,+ bitmapDataOfByteString,+ bitmapOfBMP,+ bitmapDataOfBMP,+ loadBMP,++ -- * Rendering+ displayPicture,+ renderPicture,+ withModelview,+ withClearBuffer,+ RS.initState,+ RS.State,+)+where++import Brillo.Internals.Data.Color+import Brillo.Internals.Data.Picture+import Brillo.Internals.Rendering.Common+import Brillo.Internals.Rendering.Picture+import Brillo.Internals.Rendering.State qualified as RS+++{-| Set up the OpenGL context, clear the buffer, and render the given picture+ into it.++ This is the same as `renderPicture` composed with `withModelview`+ and `withClearBuffer`. If you want to manage your own OpenGL context then+ you can just call `renderPicture`.++ Using this function assumes that you've already opened a window+ 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 windowSize colorClear state scale picture =+ withModelview windowSize $+ withClearBuffer colorClear $+ renderPicture state scale picture
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2010-2024 The Gloss Development Team,+Copyright (c) 2024-2025 The Brillo Development Team++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ brillo-rendering.cabal view
@@ -0,0 +1,43 @@+cabal-version: 3.0+name: brillo-rendering+version: 1.13.3+license: MIT+license-file: LICENSE+author: Elise Huard, Ben Lippmeier, Adrian Sieber+maintainer: brillo@ad-si.com+category: Graphics+build-type: Simple+synopsis: Brillo picture data types and rendering functions.+description:+ Brillo picture data types and rendering functions.+ These functions don't do any window management.+ If you want Brillo to setup your window as well,+ then use the plain @brillo@ package.++source-repository head+ type: git+ location: https://github.com/ad-si/Brillo++library+ default-language: GHC2021+ exposed-modules: Brillo.Rendering+ other-modules:+ Brillo.Internals.Data.Color+ Brillo.Internals.Data.Picture+ Brillo.Internals.Rendering.Bitmap+ Brillo.Internals.Rendering.Circle+ Brillo.Internals.Rendering.Color+ Brillo.Internals.Rendering.Common+ Brillo.Internals.Rendering.Picture+ Brillo.Internals.Rendering.State+ 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+ , OpenGL >=2.12 && <3.1+ , vector >=0.13 && <0.14++ ghc-options: -Wall -O2