diff --git a/Brillo/Internals/Data/Color.hs b/Brillo/Internals/Data/Color.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Data/Color.hs @@ -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) diff --git a/Brillo/Internals/Data/Picture.hs b/Brillo/Internals/Data/Picture.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Data/Picture.hs @@ -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) diff --git a/Brillo/Internals/Rendering/Bitmap.hs b/Brillo/Internals/Rendering/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Bitmap.hs @@ -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 #-} diff --git a/Brillo/Internals/Rendering/Circle.hs b/Brillo/Internals/Rendering/Circle.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Circle.hs @@ -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 +-} diff --git a/Brillo/Internals/Rendering/Color.hs b/Brillo/Internals/Rendering/Color.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Color.hs @@ -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 #-} diff --git a/Brillo/Internals/Rendering/Common.hs b/Brillo/Internals/Rendering/Common.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Common.hs @@ -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 diff --git a/Brillo/Internals/Rendering/Picture.hs b/Brillo/Internals/Rendering/Picture.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/Picture.hs @@ -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 #-} diff --git a/Brillo/Internals/Rendering/State.hs b/Brillo/Internals/Rendering/State.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/State.hs @@ -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 + } diff --git a/Brillo/Internals/Rendering/VectorFont.hs b/Brillo/Internals/Rendering/VectorFont.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Rendering/VectorFont.hs @@ -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 -} diff --git a/Brillo/Rendering.hs b/Brillo/Rendering.hs new file mode 100644 --- /dev/null +++ b/Brillo/Rendering.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/brillo-rendering.cabal b/brillo-rendering.cabal new file mode 100644 --- /dev/null +++ b/brillo-rendering.cabal @@ -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