diff --git a/Brillo.hs b/Brillo.hs new file mode 100644 --- /dev/null +++ b/Brillo.hs @@ -0,0 +1,71 @@ +{-| Brillo hides the pain of drawing simple vector graphics behind a nice data type and + a few display functions. + + Getting something on the screen is as easy as: + + @ + import Brillo + main = `display` (InWindow \"Nice Window\" (200, 200) (10, 10)) `white` (`Circle` 80) + @ + + Once the window is open you can use the following: + +@ +* Quit + - esc-key + +* Move Viewport + - arrow keys + - left-click drag + +* Zoom Viewport + - page up/down-keys + - control-left-click drag + - right-click drag + - mouse wheel + +* Rotate Viewport + - home/end-keys + - alt-left-click drag + +* Reset Viewport + 'r'-key +@ + + + Animations can be constructed similarly using the `animate`. + + If you want to run a simulation based around finite time steps then try + `simulate`. + + If you want to manage your own key\/mouse events then use `play`. + + Brillo uses OpenGL under the hood, but you don't have to worry about any of that. + + Brillo programs should be compiled with @-threaded@, otherwise the GHC runtime + will limit the frame-rate to around 20Hz. + + +For more information, check out . +-} +module Brillo ( + module Brillo.Data.Picture, + module Brillo.Data.Color, + module Brillo.Data.Bitmap, + Display (..), + display, + animate, + simulate, + play, +) +where + +import Brillo.Data.Bitmap +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Interface.Pure.Animate +import Brillo.Interface.Pure.Display +import Brillo.Interface.Pure.Game +import Brillo.Interface.Pure.Simulate + diff --git a/Brillo/Data/Bitmap.hs b/Brillo/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Bitmap.hs @@ -0,0 +1,20 @@ +-- | Functions to load bitmap data from various places. +module Brillo.Data.Bitmap ( + Rectangle (..), + BitmapData, + bitmapSize, + BitmapFormat (..), + RowOrder (..), + PixelFormat (..), + bitmapOfForeignPtr, + bitmapDataOfForeignPtr, + bitmapOfByteString, + bitmapDataOfByteString, + bitmapOfBMP, + bitmapDataOfBMP, + loadBMP, +) +where + +import Brillo.Rendering + diff --git a/Brillo/Data/Color.hs b/Brillo/Data/Color.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Color.hs @@ -0,0 +1,205 @@ +-- | Predefined and custom colors. +module Brillo.Data.Color ( + -- ** Color data type + Color, + makeColor, + makeColorI, + rgbaOfColor, + + -- ** Color functions + mixColors, + addColors, + dim, + bright, + light, + dark, + withRed, + withGreen, + withBlue, + withAlpha, + + -- ** Pre-defined colors + greyN, + black, + white, + + -- *** Primary + red, + green, + blue, + + -- *** Secondary + yellow, + cyan, + magenta, + + -- *** Tertiary + rose, + violet, + azure, + aquamarine, + chartreuse, + orange, +) +where + +import Brillo.Rendering + + +-- Color functions ------------------------------------------------------------ + +-- | Mix two colors with the given ratios. +mixColors + :: Float + -- ^ Proportion of first color. + -> Float + -- ^ Proportion of second color. + -> Color + -- ^ First color. + -> Color + -- ^ Second color. + -> Color + -- ^ Resulting color. +mixColors m1 m2 c1 c2 = + let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 + + -- Normalise mixing proportions to ratios. + m12 = m1 + m2 + m1' = m1 / m12 + m2' = m2 / m12 + + -- Colors components should be added via sum of squares, + -- otherwise the result will be too dark. + r1s = r1 * r1 + r2s = r2 * r2 + g1s = g1 * g1 + g2s = g2 * g2 + b1s = b1 * b1 + b2s = b2 * b2 + in makeColor + (sqrt (m1' * r1s + m2' * r2s)) + (sqrt (m1' * g1s + m2' * g2s)) + (sqrt (m1' * b1s + m2' * b2s)) + ((m1 * a1 + m2 * a2) / m12) + + +{-| Add RGB components of a color component-wise, + then normalise them to the highest resulting one. + The alpha components are averaged. +-} +addColors :: Color -> Color -> Color +addColors c1 c2 = + let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 + in normalizeColor + (r1 + r2) + (g1 + g2) + (b1 + b2) + ((a1 + a2) / 2) + + +-- | Make a dimmer version of a color, scaling towards black. +dim :: Color -> Color +dim c = + let (r, g, b, a) = rgbaOfColor c + in makeColor (r / 1.2) (g / 1.2) (b / 1.2) a + + +-- | Make a brighter version of a color, scaling towards white. +bright :: Color -> Color +bright c = + let (r, g, b, a) = rgbaOfColor c + in makeColor (r * 1.2) (g * 1.2) (b * 1.2) a + + +-- | Lighten a color, adding white. +light :: Color -> Color +light c = + let (r, g, b, a) = rgbaOfColor c + in makeColor (r + 0.2) (g + 0.2) (b + 0.2) a + + +-- | Darken a color, adding black. +dark :: Color -> Color +dark c = + let (r, g, b, a) = rgbaOfColor c + in makeColor (r - 0.2) (g - 0.2) (b - 0.2) a + + +------------------------------------------------------------------------------- + +-- | Set the red value of a `Color`. +withRed :: Float -> Color -> Color +withRed r c = + let (_, g, b, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the green value of a `Color`. +withGreen :: Float -> Color -> Color +withGreen g c = + let (r, _, b, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the blue value of a `Color`. +withBlue :: Float -> Color -> Color +withBlue b c = + let (r, g, _, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the alpha value of a `Color`. +withAlpha :: Float -> Color -> Color +withAlpha a c = + let (r, g, b, _) = rgbaOfColor c + in makeColor r g b a + + +-- Pre-defined Colors --------------------------------------------------------- + +{-| A greyness of a given order. + + Range is 0 = black, to 1 = white. +-} +greyN :: Float -> Color +greyN n = makeRawColor n n n 1.0 + + +black, white :: Color +black = makeRawColor 0.0 0.0 0.0 1.0 +white = makeRawColor 1.0 1.0 1.0 1.0 + + +-- Colors from the additive color wheel. +red, green, blue :: Color +red = makeRawColor 1.0 0.0 0.0 1.0 +green = makeRawColor 0.0 1.0 0.0 1.0 +blue = makeRawColor 0.0 0.0 1.0 1.0 + + +-- secondary +yellow, cyan, magenta :: Color +yellow = addColors red green +cyan = addColors green blue +magenta = addColors red blue + + +-- tertiary +rose, violet, azure, aquamarine, chartreuse, orange :: Color +rose = addColors red magenta +violet = addColors magenta blue +azure = addColors blue cyan +aquamarine = addColors cyan green +chartreuse = addColors green yellow +orange = addColors yellow red + + +------------------------------------------------------------------------------- + +-- | Normalise a color to the value of its largest RGB component. +normalizeColor :: Float -> Float -> Float -> Float -> Color +normalizeColor r g b a = + let m = maximum [r, g, b] + in makeColor (r / m) (g / m) (b / m) a diff --git a/Brillo/Data/Controller.hs b/Brillo/Data/Controller.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Controller.hs @@ -0,0 +1,14 @@ +module Brillo.Data.Controller (Controller (..)) +where + +import Brillo.Data.ViewPort + + +-- | Functions to asynchronously control a `Brillo` display. +data Controller + = Controller + { controllerSetRedraw :: IO () + -- ^ Indicate that we want the picture to be redrawn. + , controllerModifyViewPort :: (ViewPort -> IO ViewPort) -> IO () + -- ^ Modify the current viewport, also indicating that it should be redrawn. + } diff --git a/Brillo/Data/Display.hs b/Brillo/Data/Display.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Display.hs @@ -0,0 +1,11 @@ +module Brillo.Data.Display (Display (..)) +where + + +-- | Describes how Brillo should display its output. +data Display + = -- | Display in a window with the given name, size and position. + InWindow String (Int, Int) (Int, Int) + | -- | Display full screen. + FullScreen + deriving (Eq, Read, Show) diff --git a/Brillo/Data/Picture.hs b/Brillo/Data/Picture.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Picture.hs @@ -0,0 +1,219 @@ +module Brillo.Data.Picture ( + Picture (..), + Point, + Vector, + Path, + + -- * Aliases for Picture constructors + blank, + polygon, + line, + circle, + thickCircle, + arc, + thickArc, + text, + bitmap, + bitmapSection, + -- , bitmap + color, + translate, + rotate, + scale, + pictures, + + -- * Compound shapes + lineLoop, + circleSolid, + arcSolid, + sectorWire, + rectanglePath, + rectangleWire, + rectangleSolid, + rectangleUpperPath, + rectangleUpperWire, + rectangleUpperSolid, +) +where + +import Brillo.Geometry.Angle +import Brillo.Rendering + + +-- Constructors ---------------------------------------------------------------- +-- NOTE: The docs here should be identical to the ones on the constructors. + +-- | A blank picture, with nothing in it. +blank :: Picture +blank = Blank + + +-- | A convex polygon filled with a solid color. +polygon :: Path -> Picture +polygon = Polygon + + +-- | A line along an arbitrary path. +line :: Path -> Picture +line = Line + + +-- | A circle with the given radius. +circle :: Float -> Picture +circle = Circle + + +{-| A circle with the given thickness and radius. + If the thickness is 0 then this is equivalent to `Circle`. +-} +thickCircle :: Float -> Float -> Picture +thickCircle = ThickCircle + + +{-| A circular arc drawn counter-clockwise between two angles (in degrees) + at the given radius. +-} +arc :: Float -> Float -> Float -> Picture +arc = Arc + + +{-| 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 -> Picture +thickArc = ThickArc + + +-- | Some text to draw with a vector font. +text :: String -> Picture +text = Text + + +-- | A bitmap image +bitmap :: BitmapData -> Picture +bitmap bitmapData = Bitmap bitmapData + + +{-| a subsection of a bitmap image + first argument selects a sub section in the bitmap + second argument determines the bitmap data +-} +bitmapSection :: Rectangle -> BitmapData -> Picture +bitmapSection = BitmapSection + + +-- | A picture drawn with this color. +color :: Color -> Picture -> Picture +color = Color + + +-- | A picture translated by the given x and y coordinates. +translate :: Float -> Float -> Picture -> Picture +translate = Translate + + +-- | A picture rotated clockwise by the given angle (in degrees). +rotate :: Float -> Picture -> Picture +rotate = Rotate + + +-- | A picture scaled by the given x and y factors. +scale :: Float -> Float -> Picture -> Picture +scale = Scale + + +-- | A picture consisting of several others. +pictures :: [Picture] -> Picture +pictures = Pictures + + +-- Other Shapes --------------------------------------------------------------- + +-- | A closed loop along a path. +lineLoop :: Path -> Picture +lineLoop [] = Line [] +lineLoop (x : xs) = Line ((x : xs) ++ [x]) + + +-- Circles and Arcs ----------------------------------------------------------- + +-- | A solid circle with the given radius. +circleSolid :: Float -> Picture +circleSolid r = + thickCircle (r / 2) r + + +-- | A solid arc, drawn counter-clockwise between two angles (in degrees) at the given radius. +arcSolid :: Float -> Float -> Float -> Picture +arcSolid a1 a2 r = + thickArc a1 a2 (r / 2) r + + +{-| A wireframe sector of a circle. + An arc is draw counter-clockwise from the first to the second angle (in degrees) at + the given radius. Lines are drawn from the origin to the ends of the arc. +-} + +--- +-- NOTE: We take the absolute value of the radius incase it's negative. +-- It would also make sense to draw the sector flipped around the +-- origin, but I think taking the absolute value will be less surprising +-- for the user. +-- +sectorWire :: Float -> Float -> Float -> Picture +sectorWire a1 a2 r_ = + let r = abs r_ + in Pictures + [ Arc a1 a2 r + , Line [(0, 0), (r * cos (degToRad a1), r * sin (degToRad a1))] + , Line [(0, 0), (r * cos (degToRad a2), r * sin (degToRad a2))] + ] + + +-- Rectangles ----------------------------------------------------------------- +-- NOTE: Only the first of these rectangle functions has haddocks on the +-- arguments to reduce the amount of noise in the extracted docs. + +-- | A path representing a rectangle centered about the origin +rectanglePath + :: Float + -- ^ width of rectangle + -> Float + -- ^ height of rectangle + -> Path +rectanglePath sizeX sizeY = + let sx = sizeX / 2 + sy = sizeY / 2 + in [(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)] + + +-- | A wireframe rectangle centered about the origin. +rectangleWire :: Float -> Float -> Picture +rectangleWire sizeX sizeY = + lineLoop $ rectanglePath sizeX sizeY + + +-- | A wireframe rectangle in the y > 0 half of the x-y plane. +rectangleUpperWire :: Float -> Float -> Picture +rectangleUpperWire sizeX sizeY = + lineLoop $ rectangleUpperPath sizeX sizeY + + +-- | A path representing a rectangle in the y > 0 half of the x-y plane. +rectangleUpperPath :: Float -> Float -> Path +rectangleUpperPath sizeX sy = + let sx = sizeX / 2 + in [(-sx, 0), (-sx, sy), (sx, sy), (sx, 0)] + + +-- | A solid rectangle centered about the origin. +rectangleSolid :: Float -> Float -> Picture +rectangleSolid sizeX sizeY = + Polygon $ rectanglePath sizeX sizeY + + +-- | A solid rectangle in the y > 0 half of the x-y plane. +rectangleUpperSolid :: Float -> Float -> Picture +rectangleUpperSolid sizeX sizeY = + Polygon $ rectangleUpperPath sizeX sizeY diff --git a/Brillo/Data/Point.hs b/Brillo/Data/Point.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Point.hs @@ -0,0 +1,32 @@ +module Brillo.Data.Point ( + Point, + Path, + pointInBox, +) +where + +import Brillo.Data.Picture + + +{-| Test whether a point lies within a rectangular box that is oriented + on the x-y plane. The points P1-P2 are opposing points of the box, + but need not be in a particular order. + +@ + P2 +-------+ + | | + | + P0 | + | | + +-------+ P1 +@ +-} +pointInBox + :: Point + -> Point + -> Point + -> Bool +pointInBox (x0, y0) (x1, y1) (x2, y2) = + x0 >= min x1 x2 + && x0 <= max x1 x2 + && y0 >= min y1 y2 + && y0 <= max y1 y2 diff --git a/Brillo/Data/Point/Arithmetic.hs b/Brillo/Data/Point/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Point/Arithmetic.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BangPatterns #-} + +{-| +== Point and vector arithmetic + +Vectors aren't numbers according to Haskell, because they don't +support all numeric operations sensibly. We define component-wise +addition, subtraction, and negation along with scalar multiplication +in this module, which is intended to be imported qualified. +-} +module Brillo.Data.Point.Arithmetic ( + Point, + (+), + (-), + (*), + negate, +) where + +import Brillo.Rendering (Point) +import Prelude (Float) +import Prelude qualified as P + + +infixl 6 +, - +infixl 7 * + + +-- | Add two vectors, or add a vector to a point. +(+) :: Point -> Point -> Point +(x1, y1) + (x2, y2) = + let + !x = x1 P.+ x2 + !y = y1 P.+ y2 + in + (x, y) + + +-- | Subtract two vectors, or subtract a vector from a point. +(-) :: Point -> Point -> Point +(x1, y1) - (x2, y2) = + let + !x = x1 P.- x2 + !y = y1 P.- y2 + in + (x, y) + + +-- | Negate a vector. +negate :: Point -> Point +negate (x, y) = + let + !x' = P.negate x + !y' = P.negate y + in + (x', y') + + +-- | Multiply a scalar by a vector. +(*) :: Float -> Point -> Point +(*) s (x, y) = + let + !x' = s P.* x + !y' = s P.* y + in + (x', y') diff --git a/Brillo/Data/Vector.hs b/Brillo/Data/Vector.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/Vector.hs @@ -0,0 +1,90 @@ +{-# OPTIONS -fno-warn-missing-methods #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Geometric functions concerning vectors. +module Brillo.Data.Vector ( + Vector, + magV, + argV, + dotV, + detV, + mulSV, + rotateV, + angleVV, + normalizeV, + unitVectorAtAngle, +) +where + +import Brillo.Data.Picture +import Brillo.Geometry.Angle + + +-- | The magnitude of a vector. +magV :: Vector -> Float +magV (x, y) = + sqrt (x * x + y * y) +{-# INLINE magV #-} + + +-- | The angle of this vector, relative to the +ve x-axis. +argV :: Vector -> Float +argV (x, y) = + normalizeAngle $ atan2 y x +{-# INLINE argV #-} + + +-- | The dot product of two vectors. +dotV :: Vector -> Vector -> Float +dotV (x1, x2) (y1, y2) = + x1 * y1 + x2 * y2 +{-# INLINE dotV #-} + + +-- | The determinant of two vectors. +detV :: Vector -> Vector -> Float +detV (x1, y1) (x2, y2) = + x1 * y2 - y1 * x2 +{-# INLINE detV #-} + + +-- | Multiply a vector by a scalar. +mulSV :: Float -> Vector -> Vector +mulSV s (x, y) = + (s * x, s * y) +{-# INLINE mulSV #-} + + +-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. +rotateV :: Float -> Vector -> Vector +rotateV r (x, y) = + ( x * cos r - y * sin r + , x * sin r + y * cos r + ) +{-# INLINE rotateV #-} + + +-- | Compute the inner angle (in radians) between two vectors. +angleVV :: Vector -> Vector -> Float +angleVV p1 p2 = + let m1 = magV p1 + m2 = magV p2 + d = p1 `dotV` p2 + aDiff = acos $ d / (m1 * m2) + in aDiff +{-# INLINE angleVV #-} + + +-- | Normalise a vector, so it has a magnitude of 1. +normalizeV :: Vector -> Vector +normalizeV v = mulSV (1 / magV v) v +{-# INLINE normalizeV #-} + + +{-| Produce a unit vector at a given angle relative to the +ve x-axis. + The provided angle is in radians. +-} +unitVectorAtAngle :: Float -> Vector +unitVectorAtAngle r = + (cos r, sin r) +{-# INLINE unitVectorAtAngle #-} diff --git a/Brillo/Data/ViewPort.hs b/Brillo/Data/ViewPort.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/ViewPort.hs @@ -0,0 +1,82 @@ +module Brillo.Data.ViewPort ( + ViewPort (..), + viewPortInit, + applyViewPortToPicture, + invertViewPort, +) +where + +import Brillo.Data.Picture +import Brillo.Data.Point.Arithmetic qualified as Pt + + +{-| The 'ViewPort' represents the global transformation applied to the displayed picture. + When the user pans, zooms, or rotates the display then this changes the 'ViewPort'. +-} +data ViewPort + = ViewPort + { viewPortTranslate :: !(Float, Float) + -- ^ Global translation. + , viewPortRotate :: !Float + -- ^ Global rotation (in degrees). + , viewPortScale :: !Float + -- ^ Global scaling (of both x and y coordinates). + } + + +-- | The initial state of the viewport. +viewPortInit :: ViewPort +viewPortInit = + ViewPort + { viewPortTranslate = (0, 0) + , viewPortRotate = 0 + , viewPortScale = 1 + } + + +-- | Translates, rotates, and scales an image according to the 'ViewPort'. +applyViewPortToPicture :: ViewPort -> Picture -> Picture +applyViewPortToPicture + ViewPort + { viewPortScale = vscale + , viewPortTranslate = (transX, transY) + , viewPortRotate = vrotate + } = + Scale vscale vscale . Rotate vrotate . Translate transX transY + + +{-| Takes a point using screen coordinates, and uses the `ViewPort` to convert + it to Picture coordinates. This is the inverse of `applyViewPortToPicture` + for points. +-} +invertViewPort :: ViewPort -> Point -> Point +invertViewPort + ViewPort + { viewPortScale = vscale + , viewPortTranslate = vtrans + , viewPortRotate = vrotate + } + pos = + rotateV (degToRad vrotate) (mulSV (1 / vscale) pos) Pt.- vtrans + + +-- | Convert degrees to radians +degToRad :: Float -> Float +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} + + +-- | Multiply a vector by a scalar. +mulSV :: Float -> Vector -> Vector +mulSV s (x, y) = + (s * x, s * y) +{-# INLINE mulSV #-} + + +-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. +rotateV :: Float -> Vector -> Vector +rotateV r (x, y) = + ( x * cos r - y * sin r + , x * sin r + y * cos r + ) +{-# INLINE rotateV #-} diff --git a/Brillo/Data/ViewState.hs b/Brillo/Data/ViewState.hs new file mode 100644 --- /dev/null +++ b/Brillo/Data/ViewState.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE PatternGuards #-} + +module Brillo.Data.ViewState ( + Command (..), + CommandConfig, + defaultCommandConfig, + ViewState (..), + viewStateInit, + viewStateInitWithConfig, + updateViewStateWithEvent, + updateViewStateWithEventMaybe, +) +where + +import Brillo.Data.Point.Arithmetic qualified as Pt +import Brillo.Data.Vector +import Brillo.Data.ViewPort +import Brillo.Geometry.Angle +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Event +import Control.Monad (mplus) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe + + +-- | The commands suported by the view controller. +data Command + = CRestore + | CTranslate + | CRotate + | CScale + | -- bump zoom + CBumpZoomOut + | CBumpZoomIn + | -- bump translate + CBumpLeft + | CBumpRight + | CBumpUp + | CBumpDown + | -- bump rotate + CBumpClockwise + | CBumpCClockwise + deriving (Show, Eq, Ord) + + +type CommandConfig = [(Command, [(Key, Maybe Modifiers)])] + + +{-| The default commands. Left click pans, wheel zooms, right click + rotates, "r" key resets. +-} +defaultCommandConfig :: CommandConfig +defaultCommandConfig = + [ + ( CRestore + , [(Char 'r', Nothing)] + ) + , + ( CTranslate + , + [ + ( MouseButton LeftButton + , Just (Modifiers{shift = Up, ctrl = Up, alt = Up}) + ) + ] + ) + , + ( CScale + , + [ + ( MouseButton LeftButton + , Just (Modifiers{shift = Up, ctrl = Down, alt = Up}) + ) + , + ( MouseButton RightButton + , Just (Modifiers{shift = Up, ctrl = Up, alt = Up}) + ) + ] + ) + , + ( CRotate + , + [ + ( MouseButton LeftButton + , Just (Modifiers{shift = Up, ctrl = Up, alt = Down}) + ) + , + ( MouseButton RightButton + , Just (Modifiers{shift = Up, ctrl = Down, alt = Up}) + ) + ] + ) + , -- bump zoom + + ( CBumpZoomOut + , + [ (MouseButton WheelDown, Nothing) + , (SpecialKey KeyPageDown, Nothing) + ] + ) + , + ( CBumpZoomIn + , + [ (MouseButton WheelUp, Nothing) + , (SpecialKey KeyPageUp, Nothing) + ] + ) + , -- bump translate + + ( CBumpLeft + , [(SpecialKey KeyLeft, Nothing)] + ) + , + ( CBumpRight + , [(SpecialKey KeyRight, Nothing)] + ) + , + ( CBumpUp + , [(SpecialKey KeyUp, Nothing)] + ) + , + ( CBumpDown + , [(SpecialKey KeyDown, Nothing)] + ) + , -- bump rotate + + ( CBumpClockwise + , [(SpecialKey KeyHome, Nothing)] + ) + , + ( CBumpCClockwise + , [(SpecialKey KeyEnd, Nothing)] + ) + ] + + +-- | Check if the provided key combination is some brillo viewport command. +isCommand + :: Map Command [(Key, Maybe Modifiers)] + -> Command + -> Key + -> Modifiers + -> Bool +isCommand commands c key keyMods + | Just csMatch <- Map.lookup c commands = + or $ map (isCommand2 c key keyMods) csMatch + | otherwise = + False + + +-- | Check if the provided key combination is some brillo viewport command. +isCommand2 :: Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool +isCommand2 _ key keyMods cMatch + | (keyC, mModsC) <- cMatch + , keyC == key + , case mModsC of + Nothing -> True + Just modsC -> modsC == keyMods = + True + | otherwise = + False + + +-- ViewControl State ----------------------------------------------------------- + +{-| State for controlling the viewport. + These are used by the viewport control component. +-} +data ViewState + = ViewState + { viewStateCommands :: !(Map Command [(Key, Maybe Modifiers)]) + -- ^ The command list for the viewport controller. + -- These can be safely overwridden at any time by deleting + -- or adding entries to the list. + -- Entries at the front of the list take precedence. + , viewStateScaleStep :: !Float + -- ^ How much to scale the world by for each step of the mouse wheel. + , viewStateRotateFactor :: !Float + -- ^ How many degrees to rotate the world by for each pixel of x motion. + , viewStateScaleFactor :: !Float + -- ^ Ratio to scale the world by for each pixel of y motion. + , viewStateTranslateMark :: !(Maybe (Float, Float)) + -- ^ During viewport translation, + -- where the mouse was clicked on the window to start the translate. + , viewStateRotateMark :: !(Maybe (Float, Float)) + -- ^ During viewport rotation, + -- where the mouse was clicked on the window to starte the rotate. + , viewStateScaleMark :: !(Maybe (Float, Float)) + -- ^ During viewport scale, + -- where the mouse was clicked on the window to start the scale. + , viewStateViewPort :: ViewPort + -- ^ The current viewport. + } + + +-- | The initial view state. +viewStateInit :: ViewState +viewStateInit = + viewStateInitWithConfig defaultCommandConfig + + +-- | Initial view state, with user defined config. +viewStateInitWithConfig :: CommandConfig -> ViewState +viewStateInitWithConfig commandConfig = + ViewState + { viewStateCommands = Map.fromList commandConfig + , viewStateScaleStep = 0.85 + , viewStateRotateFactor = 0.6 + , viewStateScaleFactor = 0.01 + , viewStateTranslateMark = Nothing + , viewStateRotateMark = Nothing + , viewStateScaleMark = Nothing + , viewStateViewPort = viewPortInit + } + + +-- | Apply an event to a `ViewState`. +updateViewStateWithEvent :: Event -> ViewState -> ViewState +updateViewStateWithEvent ev viewState = + fromMaybe viewState $ updateViewStateWithEventMaybe ev viewState + + +{-| Like 'updateViewStateWithEvent', but returns 'Nothing' if no update + was needed. +-} +updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState +updateViewStateWithEventMaybe (EventKey key keyState keyMods pos) viewState + | isCommand commands CRestore key keyMods + , keyState == Down = + Just $ viewState{viewStateViewPort = viewPortInit} + | isCommand commands CBumpZoomOut key keyMods + , keyState == Down = + Just $ controlZoomIn viewState + | isCommand commands CBumpZoomIn key keyMods + , keyState == Down = + Just $ controlZoomOut viewState + | isCommand commands CBumpLeft key keyMods + , keyState == Down = + Just $ viewState{viewStateViewPort = motionBump port (20, 0)} + | isCommand commands CBumpRight key keyMods + , keyState == Down = + Just $ viewState{viewStateViewPort = motionBump port (-20, 0)} + | isCommand commands CBumpUp key keyMods + , keyState == Down = + Just $ viewState{viewStateViewPort = motionBump port (0, -20)} + | isCommand commands CBumpDown key keyMods + , keyState == Down = + Just $ viewState{viewStateViewPort = motionBump port (0, 20)} + | isCommand commands CBumpClockwise key keyMods + , keyState == Down = + Just $ + viewState + { viewStateViewPort = + port{viewPortRotate = viewPortRotate port + 5} + } + | isCommand commands CBumpCClockwise key keyMods + , keyState == Down = + Just $ + viewState + { viewStateViewPort = + port{viewPortRotate = viewPortRotate port - 5} + } + -- Start Translation. + | isCommand commands CTranslate key keyMods + , keyState == Down + , not $ currentlyRotating || currentlyScaling = + Just $ viewState{viewStateTranslateMark = Just pos} + -- Start Rotation. + | isCommand commands CRotate key keyMods + , keyState == Down + , not $ currentlyTranslating || currentlyScaling = + Just $ viewState{viewStateRotateMark = Just pos} + -- Start Scale. + | isCommand commands CScale key keyMods + , keyState == Down + , not $ currentlyTranslating || currentlyRotating = + Just $ viewState{viewStateScaleMark = Just pos} + -- Kill current translate/rotate/scale command when the mouse button + -- is released. + | keyState == Up = + let killTranslate vs = vs{viewStateTranslateMark = Nothing} + killRotate vs = vs{viewStateRotateMark = Nothing} + killScale vs = vs{viewStateScaleMark = Nothing} + in Just $ + (if currentlyTranslating then killTranslate else id) $ + (if currentlyRotating then killRotate else id) $ + (if currentlyScaling then killScale else id) $ + viewState + | otherwise = + Nothing + where + commands = viewStateCommands viewState + port = viewStateViewPort viewState + currentlyTranslating = isJust $ viewStateTranslateMark viewState + currentlyRotating = isJust $ viewStateRotateMark viewState + currentlyScaling = isJust $ viewStateScaleMark viewState + +-- Note that only a translation or rotation applies, not both at the same time. +updateViewStateWithEventMaybe (EventMotion pos) viewState = + motionScale (viewStateScaleMark viewState) pos viewState + `mplus` motionTranslate (viewStateTranslateMark viewState) pos viewState + `mplus` motionRotate (viewStateRotateMark viewState) pos viewState +updateViewStateWithEventMaybe (EventResize _) _ = + Nothing + + +-- | Zoom in a `ViewState` by the scale step. +controlZoomIn :: ViewState -> ViewState +controlZoomIn + viewState@ViewState + { viewStateViewPort = port + , viewStateScaleStep = scaleStep + } = + viewState + { viewStateViewPort = + port{viewPortScale = viewPortScale port / scaleStep} + } + + +-- | Zoom out a `ViewState` by the scale step. +controlZoomOut :: ViewState -> ViewState +controlZoomOut + viewState@ViewState + { viewStateViewPort = port + , viewStateScaleStep = scaleStep + } = + viewState + { viewStateViewPort = + port{viewPortScale = viewPortScale port * scaleStep} + } + + +-- | Offset a viewport. +motionBump :: ViewPort -> (Float, Float) -> ViewPort +motionBump + port@ViewPort + { viewPortTranslate = trans + , viewPortScale = scale + , viewPortRotate = r + } + (bumpX, bumpY) = + port{viewPortTranslate = trans Pt.- o} + where + offset = (bumpX / scale, bumpY / scale) + o = rotateV (degToRad r) offset + + +-- | Apply a translation to the `ViewState`. +motionTranslate + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. + -> ViewState + -> Maybe ViewState +motionTranslate Nothing _ _ = Nothing +motionTranslate (Just (markX, markY)) (posX, posY) viewState = + Just $ + viewState + { viewStateViewPort = port{viewPortTranslate = trans Pt.- o} + , viewStateTranslateMark = Just (posX, posY) + } + where + port = viewStateViewPort viewState + trans = viewPortTranslate port + scale = viewPortScale port + r = viewPortRotate port + dX = markX - posX + dY = markY - posY + offset = (dX / scale, dY / scale) + o = rotateV (degToRad r) offset + + +-- | Apply a rotation to the `ViewState`. +motionRotate + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. + -> ViewState + -> Maybe ViewState +motionRotate Nothing _ _ = Nothing +motionRotate (Just (markX, _markY)) (posX, posY) viewState = + Just $ + viewState + { viewStateViewPort = + port{viewPortRotate = rotate - rotateFactor * (posX - markX)} + , viewStateRotateMark = Just (posX, posY) + } + where + port = viewStateViewPort viewState + rotate = viewPortRotate port + rotateFactor = viewStateRotateFactor viewState + + +-- | Apply a scale to the `ViewState`. +motionScale + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. + -> ViewState + -> Maybe ViewState +motionScale Nothing _ _ = Nothing +motionScale (Just (_markX, markY)) (posX, posY) viewState = + Just $ + viewState + { viewStateViewPort = + let + -- Limit the amount of downward scaling so it maxes + -- out at 1 percent of the original. There's not much + -- point scaling down to no pixels, or going negative + -- so that the image is inverted. + ss = + if posY > markY + then scale - scale * (scaleFactor * (posY - markY)) + else scale + scale * (scaleFactor * (markY - posY)) + + ss' = max 0.01 ss + in + port{viewPortScale = ss'} + , viewStateScaleMark = Just (posX, posY) + } + where + port = viewStateViewPort viewState + scale = viewPortScale port + scaleFactor = viewStateScaleFactor viewState diff --git a/Brillo/Geometry/Angle.hs b/Brillo/Geometry/Angle.hs new file mode 100644 --- /dev/null +++ b/Brillo/Geometry/Angle.hs @@ -0,0 +1,28 @@ +-- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians. +module Brillo.Geometry.Angle ( + degToRad, + radToDeg, + normalizeAngle, +) +where + + +-- | Convert degrees to radians +degToRad :: Float -> Float +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} + + +-- | Convert radians to degrees +radToDeg :: Float -> Float +radToDeg r = r * 180 / pi +{-# INLINE radToDeg #-} + + +-- | Normalize 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 #-} diff --git a/Brillo/Geometry/Line.hs b/Brillo/Geometry/Line.hs new file mode 100644 --- /dev/null +++ b/Brillo/Geometry/Line.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE PatternGuards #-} + +{-| Geometric functions concerning lines and segments. + + A @Line@ is taken to be infinite in length, while a @Seg@ is finite length + line segment represented by its two endpoints. +-} +module Brillo.Geometry.Line ( + segClearsBox, + + -- * Closest points + closestPointOnLine, + closestPointOnLineParam, + + -- * Line-Line intersection + intersectLineLine, + + -- * Seg-Line intersection + intersectSegLine, + intersectSegHorzLine, + intersectSegVertLine, + + -- * Seg-Seg intersection + intersectSegSeg, + intersectSegHorzSeg, + intersectSegVertSeg, +) +where + +import Brillo.Data.Point +import Brillo.Data.Point.Arithmetic qualified as Pt +import Brillo.Data.Vector + + +-- | Check if line segment (P1-P2) clears a box (P3-P4) by being well outside it. +segClearsBox + :: Point + -- ^ P1 First point of segment. + -> Point + -- ^ P2 Second point of segment. + -> Point + -- ^ P3 Lower left point of box. + -> Point + -- ^ P4 Upper right point of box. + -> Bool +segClearsBox (x1, y1) (x2, y2) (xa, ya) (xb, yb) + | x1 < xa, x2 < xa = True + | x1 > xb, x2 > xb = True + | y1 < ya, y2 < ya = True + | y1 > yb, y2 > yb = True + | otherwise = False + + +{-| Given an infinite line which intersects `P1` and `P1`, + return the point on that line that is closest to `P3` +-} +closestPointOnLine + :: Point + -- ^ `P1` + -> Point + -- ^ `P2` + -> Point + -- ^ `P3` + -> Point + -- ^ the point on the line P1-P2 that is closest to `P3` +{-# INLINE closestPointOnLine #-} +closestPointOnLine p1 p2 p3 = + p1 Pt.+ (u `mulSV` (p2 Pt.- p1)) + where + u = closestPointOnLineParam p1 p2 p3 + + +{-| Given an infinite line which intersects P1 and P2, + let P4 be the point on the line that is closest to P3. + + Return an indication of where on the line P4 is relative to P1 and P2. + +@ + if P4 == P1 then 0 + if P4 == P2 then 1 + if P4 is halfway between P1 and P2 then 0.5 +@ + +@ + | + P1 + | + P4 +---- P3 + | + P2 + | +@ +-} +{-# INLINE closestPointOnLineParam #-} +closestPointOnLineParam + :: Point + -- ^ `P1` + -> Point + -- ^ `P2` + -> Point + -- ^ `P3` + -> Float +closestPointOnLineParam p1 p2 p3 = + (p3 Pt.- p1) `dotV` (p2 Pt.- p1) + / (p2 Pt.- p1) `dotV` (p2 Pt.- p1) + + +-- Line-Line intersection ----------------------------------------------------- + +{-| Given four points specifying two lines, get the point where the two lines + cross, if any. Note that the lines extend off to infinity, so the + intersection point might not line between either of the two pairs of points. + +@ + \\ / + P1 P4 + \\ / + + + / \\ + P3 P2 + / \\ +@ +-} +intersectLineLine + :: Point + -- ^ `P1` + -> Point + -- ^ `P2` + -> Point + -- ^ `P3` + -> Point + -- ^ `P4` + -> Maybe Point +intersectLineLine (x1, y1) (x2, y2) (x3, y3) (x4, y4) = + let dx12 = x1 - x2 + dx34 = x3 - x4 + + dy12 = y1 - y2 + dy34 = y3 - y4 + + den = dx12 * dy34 - dy12 * dx34 + in if den == 0 + then Nothing + else + let + det12 = x1 * y2 - y1 * x2 + det34 = x3 * y4 - y3 * x4 + + numx = det12 * dx34 - dx12 * det34 + numy = det12 * dy34 - dy12 * det34 + in + Just (numx / den, numy / den) + + +-- Segment-Line intersection -------------------------------------------------- + +{-| Get the point where a segment @P1-P2@ crosses an infinite line @P3-P4@, + if any. +-} +intersectSegLine + :: Point + -- ^ `P1` + -> Point + -- ^ `P2` + -> Point + -- ^ `P3` + -> Point + -- ^ `P4` + -> Maybe Point +intersectSegLine p1 p2 p3 p4 + -- TODO: merge closest point check with intersection, reuse subterms. + | Just p0 <- intersectLineLine p1 p2 p3 p4 + , t12 <- closestPointOnLineParam p1 p2 p0 + , t12 >= 0 && t12 <= 1 = + Just p0 + | otherwise = + Nothing + + +{-| Get the point where a segment crosses a horizontal line, if any. + +@ + + P1 + / + -------+--------- + / y0 + P2 + +@ +-} +intersectSegHorzLine + :: Point + -- ^ P1 First point of segment. + -> Point + -- ^ P2 Second point of segment. + -> Float + -- ^ y value of line. + -> Maybe Point +intersectSegHorzLine (x1, y1) (x2, y2) y0 + -- seg is on line + | y1 == y0, y2 == y0 = Nothing + -- seg is above line + | y1 > y0, y2 > y0 = Nothing + -- seg is below line + | y1 < y0, y2 < y0 = Nothing + -- seg is a single point on the line. + -- this should be caught by the first case, + -- but we'll test for it anyway. + | y2 - y1 == 0 = + Just (x1, y1) + | otherwise = + Just + ( (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + , y0 + ) + + +{-| Get the point where a segment crosses a vertical line, if any. + +@ + | + | + P1 + | / + + + / | + P2 + | + | x0 +@ +-} +intersectSegVertLine + :: Point + -- ^ P1 First point of segment. + -> Point + -- ^ P2 Second point of segment. + -> Float + -- ^ x value of line. + -> Maybe Point +intersectSegVertLine (x1, y1) (x2, y2) x0 + -- seg is on line + | x1 == x0, x2 == x0 = Nothing + -- seg is to right of line + | x1 > x0, x2 > x0 = Nothing + -- seg is to left of line + | x1 < x0, x2 < x0 = Nothing + -- seg is a single point on the line. + -- this should be caught by the first case, + -- but we'll test for it anyway. + | x2 - x1 == 0 = + Just (x1, y1) + | otherwise = + Just + ( x0 + , (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 + ) + + +-- Segment-Segment intersection ----------------------------------------------- + +{-| Get the point where a segment @P1-P2@ crosses another segement @P3-P4@, + if any. +-} +intersectSegSeg + :: Point + -- ^ `P1` + -> Point + -- ^ `P2` + -> Point + -- ^ `P3` + -> Point + -- ^ `P4` + -> Maybe Point +intersectSegSeg p1 p2 p3 p4 + -- TODO: merge closest point checks with intersection, reuse subterms. + | Just p0 <- intersectLineLine p1 p2 p3 p4 + , t12 <- closestPointOnLineParam p1 p2 p0 + , t23 <- closestPointOnLineParam p3 p4 p0 + , t12 >= 0 && t12 <= 1 + , t23 >= 0 && t23 <= 1 = + Just p0 + | otherwise = + Nothing + + +{-| Check if an arbitrary segment intersects a horizontal segment. + +@ + + P2 + / +(xa, y3) +---+----+ (xb, y3) + / + P1 + +@ +-} +intersectSegHorzSeg + :: Point + -- ^ P1 First point of segment. + -> Point + -- ^ P2 Second point of segment. + -> Float + -- ^ (y3) y value of horizontal segment. + -> Float + -- ^ (xa) Leftmost x value of horizontal segment. + -> Float + -- ^ (xb) Rightmost x value of horizontal segment. + -> Maybe Point + -- ^ (x3, y3) Intersection point, if any. +intersectSegHorzSeg p1@(x1, y1) p2@(x2, y2) y0 xa xb + | segClearsBox p1 p2 (xa, y0) (xb, y0) = + Nothing + | x0 < xa = Nothing + | x0 > xb = Nothing + | otherwise = Just (x0, y0) + where + x0 + | (y2 - y1) == 0 = x1 + | otherwise = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + + +{-| Check if an arbitrary segment intersects a vertical segment. + +@ + (x3, yb) + + | + P1 + | / + + + / | + P2 + | + + (x3, ya) +@ +-} +intersectSegVertSeg + :: Point + -- ^ P1 First point of segment. + -> Point + -- ^ P2 Second point of segment. + -> Float + -- ^ (x3) x value of vertical segment + -> Float + -- ^ (ya) Lowest y value of vertical segment. + -> Float + -- ^ (yb) Highest y value of vertical segment. + -> Maybe Point + -- ^ (x3, y3) Intersection point, if any. +intersectSegVertSeg p1@(x1, y1) p2@(x2, y2) x0 ya yb + | segClearsBox p1 p2 (x0, ya) (x0, yb) = + Nothing + | y0 < ya = Nothing + | y0 > yb = Nothing + | otherwise = Just (x0, y0) + where + y0 + | (x2 - x1) == 0 = y1 + | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 diff --git a/Brillo/Interface/Environment.hs b/Brillo/Interface/Environment.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/Environment.hs @@ -0,0 +1,18 @@ +module Brillo.Interface.Environment where + +import Data.IORef (newIORef) + +import Brillo.Internals.Interface.Backend (defaultBackendState) +import Brillo.Internals.Interface.Backend.Types qualified as Backend.Types + + +{-| Get the size of the screen, in pixels. + + This will be the size of the rendered brillo image when + fullscreen mode is enabled. +-} +getScreenSize :: IO (Int, Int) +getScreenSize = do + backendStateRef <- newIORef defaultBackendState + Backend.Types.initializeBackend backendStateRef False + Backend.Types.getScreenSize backendStateRef diff --git a/Brillo/Interface/IO/Animate.hs b/Brillo/Interface/IO/Animate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/IO/Animate.hs @@ -0,0 +1,72 @@ +-- | Animate a picture in a window. +module Brillo.Interface.IO.Animate ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + animateIO, + animateFixedIO, + Controller (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Animate +import Brillo.Internals.Interface.Backend + + +{-| Open a new window and display the given animation. + + Once the window is open you can use the same commands as with @display@. +-} +animateIO + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> (Float -> IO Picture) + -- ^ Function to produce the next frame of animation. + -- It is passed the time in seconds since the program started. + -> (Controller -> IO ()) + -- ^ Callback to take the display controller. + -> IO () +animateIO + display + backColor + frameFunIO + eatControllerIO = + animateWithBackendIO + defaultBackendState + True -- pannable + display + backColor + frameFunIO + eatControllerIO + + +-- | Like `animateIO` but don't allow the display to be panned around. +animateFixedIO + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> (Float -> IO Picture) + -- ^ Function to produce the next frame of animation. + -- It is passed the time in seconds since the program started. + -> (Controller -> IO ()) + -- ^ Callback to take the display controller. + -> IO () +animateFixedIO + display + backColor + frameFunIO + eatControllerIO = + animateWithBackendIO + defaultBackendState + False + display + backColor + frameFunIO + eatControllerIO diff --git a/Brillo/Interface/IO/Display.hs b/Brillo/Interface/IO/Display.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/IO/Display.hs @@ -0,0 +1,69 @@ +-- | Display mode is for drawing a static picture. +module Brillo.Interface.IO.Display ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + displayIO, + Controller (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Display + + +{-| Open a new window and display an infrequently updated picture. + + Once the window is open you can use the same commands as with @display@. + + * This wrapper is intended for mostly static pictures that do not + need to be updated more than once per second. For example, the picture + could show network activity over the last minute, a daily stock price, + or a weather forecast. If you want to show a real-time animation where + the frames are redrawn more frequently then use the `animate` wrapper + instead. + + * The provided picture generating action will be invoked, and the + display redrawn in two situation: + 1) We receive a display event, like someone clicks on the window. + 2) When `controllerSetRedraw` has been set, some indeterminate time + between the last redraw, and one second from that. + + * Note that calling `controllerSetRedraw` indicates that the picture should + be redrawn, but does not cause this to happen immediately, due to + limitations in the GLFW window manager. The display runs on + a one second timer interrupt, and if there have been no display events + we need to wait for the next timer interrupt before redrawing. + Having the timer interrupt period at 1 second keeps the CPU usage + due to the context switches at under 1%. + + * Also note that the picture generating action is called for every display + event, so if the user pans the display then it will be invoked at 10hz + or more during the pan. If you are generating the picture by reading some + on-disk files then you should track when the files were last updated + and cache the picture between updates. Caching the picture avoids + repeatedly reading and re-parsing your files during a pan. Consider + storing your current picture in an IORef, passing an action that just + reads this IORef, and forking a new thread that watches your files for updates. +-} +displayIO + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> IO Picture + -- ^ Action to produce the current picture. + -> (Controller -> IO ()) + -- ^ Callback to take the display controller. + -> IO () +displayIO dis backColor makePicture eatController = + displayWithBackend + defaultBackendState + dis + backColor + makePicture + eatController diff --git a/Brillo/Interface/IO/Game.hs b/Brillo/Interface/IO/Game.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/IO/Game.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExplicitForAll #-} + +{-| This game mode lets you manage your own input. Pressing ESC will not abort the program. + You also don't get automatic pan and zoom controls like with `display`. +-} +module Brillo.Interface.IO.Game ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + playIO, + Event (..), + Key (..), + SpecialKey (..), + MouseButton (..), + KeyState (..), + Modifiers (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Game + + +-- | Play a game in a window, using IO actions to build the pictures. +playIO + :: forall world + . Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> world + -- ^ The initial world. + -> (world -> IO Picture) + -- ^ An action to convert the world a picture. + -> (Event -> world -> IO world) + -- ^ A function to handle input events. + -> (Float -> world -> IO world) + -- ^ A function to step the world one iteration. + -- It is passed the period of time (in seconds) needing to be advanced. + -> IO () +playIO + display + backColor + simResolution + worldStart + worldToPicture + worldHandleEvent + worldAdvance = + playWithBackendIO + defaultBackendState + display + backColor + simResolution + worldStart + worldToPicture + worldHandleEvent + worldAdvance + False diff --git a/Brillo/Interface/IO/Interact.hs b/Brillo/Interface/IO/Interact.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/IO/Interact.hs @@ -0,0 +1,52 @@ +-- | Display mode is for drawing a static picture. +module Brillo.Interface.IO.Interact ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + interactIO, + Controller (..), + Event (..), + Key (..), + SpecialKey (..), + MouseButton (..), + KeyState (..), + Modifiers (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Event +import Brillo.Internals.Interface.Interact + + +{-| Open a new window and interact with an infrequently updated picture. + + Similar to `displayIO`, except that you manage your own events. +-} +interactIO + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> world + -- ^ Initial world state. + -> (world -> IO Picture) + -- ^ A function to produce the current picture. + -> (Event -> world -> IO world) + -- ^ A function to handle input events. + -> (Controller -> IO ()) + -- ^ Callback to take the display controller. + -> IO () +interactIO dis backColor worldInit makePicture handleEvent eatController = + interactWithBackend + defaultBackendState + dis + backColor + worldInit + makePicture + handleEvent + eatController diff --git a/Brillo/Interface/IO/Simulate.hs b/Brillo/Interface/IO/Simulate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/IO/Simulate.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RankNTypes #-} + +-- We export this stuff separately so we don't clutter up the +-- API of the Brillo module. + +{-| Simulate mode is for producing an animation of some model who's picture + changes over finite time steps. The behavior of the model can also depent + on the current `ViewPort`. +-} +module Brillo.Interface.IO.Simulate ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + simulateIO, + ViewPort (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Simulate + + +simulateIO + :: forall model + . Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> model + -- ^ The initial model. + -> (model -> IO Picture) + -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> IO model) + -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). + -> IO () +simulateIO = simulateWithBackendIO defaultBackendState diff --git a/Brillo/Interface/Pure/Animate.hs b/Brillo/Interface/Pure/Animate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/Pure/Animate.hs @@ -0,0 +1,37 @@ +-- | Display mode is for drawing a static picture. +module Brillo.Interface.Pure.Animate ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + animate, +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Animate +import Brillo.Internals.Interface.Backend + + +{-| Open a new window and display the given animation. + + Once the window is open you can use the same commands as with `display`. +-} +animate + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> (Float -> Picture) + -- ^ Function to produce the next frame of animation. + -- It is passed the time in seconds since the program started. + -> IO () +animate display backColor frameFun = + animateWithBackendIO + defaultBackendState + True -- pannable + display + backColor + (return . frameFun) + (const (return ())) diff --git a/Brillo/Interface/Pure/Display.hs b/Brillo/Interface/Pure/Display.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/Pure/Display.hs @@ -0,0 +1,32 @@ +-- | Display mode is for drawing a static picture. +module Brillo.Interface.Pure.Display ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + display, +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Display + + +-- | Open a new window and display the given picture. +display + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Picture + -- ^ The picture to draw. + -> IO () +display dis backColor picture = + displayWithBackend + defaultBackendState + dis + backColor + (return picture) + (const (return ())) diff --git a/Brillo/Interface/Pure/Game.hs b/Brillo/Interface/Pure/Game.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/Pure/Game.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- We export this stuff separately so we don't clutter up the +-- API of the Brillo module. + +{-| This game mode lets you manage your own input. Pressing ESC will still abort the program, + but you don't get automatic pan and zoom controls like with `displayInWindow`. +-} +module Brillo.Interface.Pure.Game ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + play, + Event (..), + Key (..), + SpecialKey (..), + MouseButton (..), + KeyState (..), + Modifiers (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Game + + +-- | Play a game in a window. Like `simulate`, but you manage your own input events. +play + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> world + -- ^ The initial world. + -> (world -> Picture) + -- ^ A function to convert the world a picture. + -> (Event -> world -> world) + -- ^ A function to handle input events. + -> (Float -> world -> world) + -- ^ A function to step the world one iteration. + -- It is passed the period of time (in seconds) needing to be advanced. + -> IO () +play + display + backColor + simResolution + worldStart + worldToPicture + worldHandleEvent + worldAdvance = + do + _ <- + playWithBackendIO + defaultBackendState + display + backColor + simResolution + worldStart + (return . worldToPicture) + (\event world -> return $ worldHandleEvent event world) + (\time world -> return $ worldAdvance time world) + True + return () diff --git a/Brillo/Interface/Pure/Simulate.hs b/Brillo/Interface/Pure/Simulate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Interface/Pure/Simulate.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} + +-- We export this stuff separately so we don't clutter up the +-- API of the Brillo module. + +{-| Simulate mode is for producing an animation of some model who's picture + changes over finite time steps. The behavior of the model can also depent + on the current `ViewPort`. +-} +module Brillo.Interface.Pure.Simulate ( + module Brillo.Data.Display, + module Brillo.Data.Picture, + module Brillo.Data.Color, + simulate, + ViewPort (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Simulate + + +{-| Run a finite-time-step simulation in a window. You decide how the model is represented, + how to convert the model to a picture, and how to advance the model for each unit of time. + This function does the rest. + + Once the window is open you can use the same commands as with `display`. +-} +simulate + :: Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> model + -- ^ The initial model. + -> (model -> Picture) + -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> model) + -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). + -> IO () +simulate + display + backColor + simResolution + modelStart + modelToPicture + modelStep = + do + _ <- + simulateWithBackendIO + defaultBackendState + display + backColor + simResolution + modelStart + (return . modelToPicture) + (\view time model -> return $ modelStep view time model) + return () diff --git a/Brillo/Internals/Color.hs b/Brillo/Internals/Color.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Color.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Color where + +import Brillo.Data.Color +import Graphics.Rendering.OpenGL.GL qualified as GL + +import Unsafe.Coerce + + +-- | Convert one of our Colors to OpenGL's representation. +glColor4OfColor :: Color -> GL.Color4 a +glColor4OfColor color = + case rgbaOfColor color of + (r, g, b, a) -> + let rF = unsafeCoerce r + gF = unsafeCoerce g + bF = unsafeCoerce b + aF = unsafeCoerce a + in GL.Color4 rF gF bF aF diff --git a/Brillo/Internals/Interface/Animate.hs b/Brillo/Internals/Interface/Animate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Animate.hs @@ -0,0 +1,111 @@ +module Brillo.Internals.Interface.Animate (animateWithBackendIO) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Animate.State qualified as AN +import Brillo.Internals.Interface.Animate.Timing +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Callback qualified as Callback +import Brillo.Internals.Interface.Common.Exit +import Brillo.Internals.Interface.ViewState.KeyMouse +import Brillo.Internals.Interface.ViewState.Motion +import Brillo.Internals.Interface.ViewState.Reshape +import Brillo.Internals.Interface.Window +import Brillo.Rendering +import Control.Monad +import Data.IORef +import GHC.Float (double2Float) +import System.Mem + + +animateWithBackendIO + :: (Backend a) + => a + -- ^ Initial State of the backend + -> Bool + -- ^ Whether to allow the image to be panned around. + -> Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> (Float -> IO Picture) + -- ^ Function to produce the next frame of animation. + -- It is passed the time in seconds since the program started. + -> (Controller -> IO ()) + -- ^ Eat the controller. + -> IO () +animateWithBackendIO + backend + pannable + display + backColor + frameOp + eatController = + do + -- + viewSR <- newIORef viewStateInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ + + let displayFun backendRef = do + -- extract the current time from the state + timeS <- animateSR `getsIORef` AN.stateAnimateTime + + -- call the user action to get the animation frame + picture <- frameOp (double2Float timeS) + + renderS <- readIORef renderSR + portS <- viewStateViewPort <$> readIORef viewSR + + windowSize <- getWindowDimensions backendRef + + -- render the frame + displayPicture + windowSize + backColor + renderS + (viewPortScale portS) + (applyViewPortToPicture portS picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks = + [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle (\s -> postRedisplay s) + , callback_exit () + , callback_viewState_motion viewSR + , callback_viewState_reshape + ] + ++ ( if pannable + then [callback_viewState_keyMouse viewSR] + else [] + ) + + createWindow backend display backColor callbacks $ + \backendRef -> + eatController $ + Controller + { controllerSetRedraw = + postRedisplay backendRef + , controllerModifyViewPort = + \modViewPort -> + do + viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState{viewStateViewPort = port'} + writeIORef viewSR viewState' + postRedisplay backendRef + } + + +getsIORef :: IORef a -> (a -> r) -> IO r +getsIORef ref fun = + liftM fun $ readIORef ref diff --git a/Brillo/Internals/Interface/Animate/State.hs b/Brillo/Internals/Interface/Animate/State.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Animate/State.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.Animate.State ( + State (..), + stateInit, +) +where + + +-- | Animation State +data State + = State + { stateAnimate :: !Bool + -- ^ Whether the animation is running. + , stateAnimateCount :: !Integer + -- ^ How many times we've entered the animation loop. + , stateAnimateStart :: !Bool + -- ^ Whether this is the first frame of the animation. + , stateAnimateTime :: !Double + -- ^ Number of msec the animation has been running for + , stateDisplayTime :: !Double + -- ^ The time when we entered the display callback for the current frame. + , stateDisplayTimeLast :: !Double + , stateDisplayTimeClamp :: !Double + -- ^ Clamp the minimum time between frames to this value (in seconds) + -- Setting this to < 10ms probably isn't worthwhile. + , stateGateTimeStart :: !Double + -- ^ The time when the last call to the users render function finished. + , stateGateTimeEnd :: !Double + -- ^ The time when displayInWindow last finished (after sleeping to clamp fps). + , stateGateTimeElapsed :: !Double + -- ^ How long it took to draw this frame + } + + +stateInit :: State +stateInit = + State + { stateAnimate = True + , stateAnimateCount = 0 + , stateAnimateStart = True + , stateAnimateTime = 0 + , stateDisplayTime = 0 + , stateDisplayTimeLast = 0 + , stateDisplayTimeClamp = 0.01 + , stateGateTimeStart = 0 + , stateGateTimeEnd = 0 + , stateGateTimeElapsed = 0 + } diff --git a/Brillo/Internals/Interface/Animate/Timing.hs b/Brillo/Internals/Interface/Animate/Timing.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Animate/Timing.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +{-| Handles timing of animation. + The main point is that we want to restrict the framerate to something + sensible, instead of just displaying at the machines maximum possible + rate and soaking up 100% cpu. + + We also keep track of the elapsed time since the start of the program, + so we can pass this to the user's animation function. +-} +module Brillo.Internals.Interface.Animate.Timing ( + animateBegin, + animateEnd, +) +where + +import Brillo.Internals.Interface.Animate.State +import Brillo.Internals.Interface.Backend +import Control.Monad +import Data.IORef + + +{-| Handles animation timing details. + Call this function at the start of each frame. +-} +animateBegin :: IORef State -> DisplayCallback +animateBegin stateRef backendRef = + do + -- write the current time into the display state + displayTime <- elapsedTime backendRef + displayTimeLast <- stateRef `getsIORef` stateDisplayTime + let displayTimeElapsed = displayTime - displayTimeLast + + modifyIORef' stateRef $ \s -> + s + { stateDisplayTime = displayTime + , stateDisplayTimeLast = displayTimeLast + } + + -- increment the animation time + animate <- stateRef `getsIORef` stateAnimate + animateCount <- stateRef `getsIORef` stateAnimateCount + animateTime <- stateRef `getsIORef` stateAnimateTime + animateStart <- stateRef `getsIORef` stateAnimateStart + + {- when (animateCount `mod` 5 == 0) + $ putStr $ " displayTime = " ++ show displayTime ++ "\n" + ++ " displayTimeLast = " ++ show displayTimeLast ++ "\n" + ++ " displayTimeElapsed = " ++ show displayTimeElapsed ++ "\n" + ++ " fps = " ++ show (truncate $ 1 / displayTimeElapsed) ++ "\n" + -} + when (animate && not animateStart) $ + modifyIORef' stateRef $ \s -> + s + { stateAnimateTime = animateTime + displayTimeElapsed + } + + when animate $ + modifyIORef' stateRef $ \s -> + s + { stateAnimateCount = animateCount + 1 + , stateAnimateStart = False + } + + +{-| Handles animation timing details. + Call this function at the end of each frame. +-} +animateEnd :: IORef State -> DisplayCallback +animateEnd stateRef backendRef = + do + -- timing gate, limits the maximum frame frequency (FPS) + timeClamp <- stateRef `getsIORef` stateDisplayTimeClamp + + -- the start of this gate + gateTimeStart <- elapsedTime backendRef + + -- end of the previous gate + gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd + let gateTimeElapsed = gateTimeStart - gateTimeEnd + + when (gateTimeElapsed < timeClamp) $ + do sleep backendRef (timeClamp - gateTimeElapsed) + + gateTimeFinal <- elapsedTime backendRef + + modifyIORef' stateRef $ \s -> + s + { stateGateTimeEnd = gateTimeFinal + , stateGateTimeElapsed = gateTimeElapsed + } + + +getsIORef :: IORef a -> (a -> r) -> IO r +getsIORef ref fun = + liftM fun $ readIORef ref diff --git a/Brillo/Internals/Interface/Backend.hs b/Brillo/Internals/Interface/Backend.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Backend.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +-- Import window managed backend specific modules. +module Brillo.Internals.Interface.Backend ( + module Brillo.Internals.Interface.Backend.Types, + module Brillo.Internals.Interface.Backend.GLFW, + defaultBackendState, +) +where + +import Brillo.Internals.Interface.Backend.GLFW +import Brillo.Internals.Interface.Backend.Types + + +defaultBackendState :: GLFWState +defaultBackendState = initBackendState diff --git a/Brillo/Internals/Interface/Backend/GLFW.hs b/Brillo/Internals/Interface/Backend/GLFW.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Backend/GLFW.hs @@ -0,0 +1,736 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Support for using GLFW as the window manager backend. +module Brillo.Internals.Interface.Backend.GLFW (GLFWState) +where + +import Control.Concurrent (threadDelay) +import Control.Exception qualified as X +import Control.Monad (unless, when) +import Data.IORef (IORef, modifyIORef', readIORef, writeIORef) +import Data.Maybe (fromJust) +import Graphics.Rendering.OpenGL (($=)) +import Graphics.Rendering.OpenGL qualified as GL +import Graphics.UI.GLFW qualified as GLFW + +import Brillo.Internals.Interface.Backend.Types + + +-- | State of the GLFW backend library. +data GLFWState + = GLFWState + { modifiers :: Modifiers + -- ^ Status of Ctrl, Alt or Shift (Up or Down?) + , mousePosition :: (Int, Int) + -- ^ Latest mouse position + , mouseWheelPos :: Int + -- ^ Latest mousewheel position + , dirtyScreen :: Bool + -- ^ Does the screen need to be redrawn? + , display :: IO () + -- ^ Action that draws on the screen + , idle :: IO () + -- ^ Action perforrmed when idling + , optWinHdl :: Maybe GLFW.Window + -- ^ The Window Handle + } + + +-- | Initial GLFW state. +glfwStateInit :: GLFWState +glfwStateInit = + GLFWState + { modifiers = Modifiers Up Up Up + , mousePosition = (0, 0) + , mouseWheelPos = 0 + , dirtyScreen = True + , display = return () + , idle = return () + , optWinHdl = Nothing + } + + +-- | Fetch the window handle from the state if it has been initialized. +winHdl :: GLFWState -> GLFW.Window +winHdl state = + case optWinHdl state of + Just handle -> handle + Nothing -> error "GLFW backend: requested uninitialized window handle" + + +instance Backend GLFWState where + initBackendState = glfwStateInit + initializeBackend = initializeGLFW + exitBackend = exitGLFW + openWindow = openWindowGLFW + dumpBackendState = dumpStateGLFW + installDisplayCallback = installDisplayCallbackGLFW + installWindowCloseCallback = installWindowCloseCallbackGLFW + installReshapeCallback = installReshapeCallbackGLFW + installKeyMouseCallback = installKeyMouseCallbackGLFW + installMotionCallback = installMotionCallbackGLFW + installIdleCallback = installIdleCallbackGLFW + runMainLoop = runMainLoopGLFW + postRedisplay = postRedisplayGLFW + getWindowDimensions = (\ref -> windowHandle ref >>= \win -> GLFW.getWindowSize win) + getScreenSize = getScreenSizeGLFW + elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt) + sleep = (\_ sec -> threadDelay (floor (sec * 1000000.0))) -- GLFW.sleep sec) + + +-- Initialise ----------------------------------------------------------------- + +-- | Initialise the GLFW backend. +initializeGLFW :: IORef GLFWState -> Bool -> IO () +initializeGLFW _ debug = + do + let simpleErrorCallback e s = + putStrLn $ unwords ["GLFW backend: ", show e, show s] + GLFW.setErrorCallback (Just simpleErrorCallback) + + _ <- GLFW.init + glfwVersion <- GLFW.getVersion + + when debug $ + putStr $ + " glfwVersion = " ++ show glfwVersion ++ "\n" + + +-- Exit ----------------------------------------------------------------------- + +-- | Tell the GLFW backend to close the window and exit. +exitGLFW :: IORef GLFWState -> IO () +exitGLFW ref = do + win <- windowHandle ref + GLFW.setWindowShouldClose win True + + +-- Open Window ---------------------------------------------------------------- + +-- | Open a new window. +openWindowGLFW + :: IORef GLFWState + -> Display + -> IO () +openWindowGLFW ref (InWindow title (sizeX, sizeY) pos) = + do + win <- + GLFW.createWindow + sizeX + sizeY + title + Nothing + Nothing + + modifyIORef' ref (\s -> s{optWinHdl = win}) + uncurry (GLFW.setWindowPos (fromJust win)) pos + GLFW.makeContextCurrent win + + -- Try to enable sync-to-vertical-refresh by setting the number + -- of buffer swaps per vertical refresh to 1. + GLFW.swapInterval 1 +openWindowGLFW ref FullScreen = + do + mon <- GLFW.getPrimaryMonitor + vmode <- GLFW.getVideoMode (fromJust mon) + + let sizeX = GLFW.videoModeWidth (fromJust vmode) + let sizeY = GLFW.videoModeHeight (fromJust vmode) + + win <- + GLFW.createWindow + sizeX + sizeY + "" + mon + Nothing + + modifyIORef' ref (\s -> s{optWinHdl = win}) + GLFW.makeContextCurrent win + + -- Try to enable sync-to-vertical-refresh by setting the number + -- of buffer swaps per vertical refresh to 1. + GLFW.swapInterval 1 + -- GLFW.enableMouseCursor + GLFW.setCursorInputMode (fromJust win) GLFW.CursorInputMode'Normal + + +windowHandle :: IORef GLFWState -> IO GLFW.Window +windowHandle ref = + do + s <- readIORef ref + return $ winHdl s + + +getScreenSizeGLFW :: IORef GLFWState -> IO (Int, Int) +getScreenSizeGLFW _state = do + monitor <- GLFW.getPrimaryMonitor + vmode <- GLFW.getVideoMode (fromJust monitor) + + let sizeX = GLFW.videoModeWidth (fromJust vmode) + let sizeY = GLFW.videoModeHeight (fromJust vmode) + + pure (sizeX, sizeY) + + +-- Dump State ----------------------------------------------------------------- + +-- | Print out the internal GLFW state. +dumpStateGLFW :: IORef GLFWState -> IO () +dumpStateGLFW ref = + do + win <- windowHandle ref + (ww, wh) <- GLFW.getWindowSize win + + -- GLFW-b does not provide a general function to query windowHints + -- could be added by adding additional getWindowHint which + -- uses glfwGetWindowAttrib behind the scenes as has been done + -- already for e.g. getWindowVisible which uses glfwGetWindowAttrib + {- + r <- GLFW.getWindowHint NumRedBits + g <- GLFW.getWindowHint NumGreenBits + b <- GLFW.getWindowHint NumBlueBits + a <- GLFW.getWindowHint NumAlphaBits + let rgbaBD = [r,g,b,a] + + depthBD <- GLFW.getWindowHint NumDepthBits + + ra <- GLFW.getWindowHint NumAccumRedBits + ga <- GLFW.getWindowHint NumAccumGreenBits + ba <- GLFW.getWindowHint NumAccumBlueBits + aa <- GLFW.getWindowHint NumAccumAlphaBits + let accumBD = [ra,ga,ba,aa] + + stencilBD <- GLFW.getWindowHint NumStencilBits + + auxBuffers <- GLFW.getWindowHint NumAuxBuffers + + fsaaSamples <- GLFW.getWindowHint NumFsaaSamples + + putStr $ "* dumpGlfwState\n" + ++ " windowWidth = " ++ show ww ++ "\n" + ++ " windowHeight = " ++ show wh ++ "\n" + ++ " depth rgba = " ++ show rgbaBD ++ "\n" + ++ " depth = " ++ show depthBD ++ "\n" + ++ " accum = " ++ show accumBD ++ "\n" + ++ " stencil = " ++ show stencilBD ++ "\n" + ++ " aux Buffers = " ++ show auxBuffers ++ "\n" + ++ " FSAA Samples = " ++ show fsaaSamples ++ "\n" + ++ "\n" + -} + + putStr $ + "* dumpGlfwState\n" + ++ " windowWidth = " + ++ show ww + ++ "\n" + ++ " windowHeight = " + ++ show wh + ++ "\n" + ++ "\n" + + +-- Display Callback ----------------------------------------------------------- + +-- | Callback for when GLFW needs us to redraw the contents of the window. +installDisplayCallbackGLFW + :: IORef GLFWState -> [Callback] -> IO () +installDisplayCallbackGLFW stateRef callbacks = + modifyIORef' stateRef $ \s -> + s + { display = callbackDisplay stateRef callbacks + } + + +callbackDisplay + :: IORef GLFWState + -> [Callback] + -> IO () +callbackDisplay stateRef callbacks = + do + -- clear the display + GL.clear [GL.ColorBuffer, GL.DepthBuffer] + GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) + + -- set the OpenGL viewport to account for any HiDPI discrepancy + (width, height) <- windowHandle stateRef >>= GLFW.getFramebufferSize + GL.viewport + $= ( GL.Position 0 0 + , GL.Size (fromIntegral width) (fromIntegral height) + ) + + -- get the display callbacks from the chain + let funs = [f stateRef | (Display f) <- callbacks] + sequence_ funs + + return () + + +-- Close Callback ------------------------------------------------------------- + +{-| Callback for when the user closes the window. + We can do some cleanup here. +-} +installWindowCloseCallbackGLFW + :: IORef GLFWState -> IO () +installWindowCloseCallbackGLFW ref = + do + win <- windowHandle ref + GLFW.setWindowCloseCallback win (Just winClosed) + where + winClosed :: GLFW.WindowCloseCallback + winClosed _win = do + return () + + +-- Reshape -------------------------------------------------------------------- + +-- | Callback for when the user reshapes the window. +installReshapeCallbackGLFW + :: IORef GLFWState -> [Callback] -> IO () +installReshapeCallbackGLFW stateRef callbacks = + do + win <- windowHandle stateRef + GLFW.setWindowSizeCallback win (Just $ callbackReshape stateRef callbacks) + + +callbackReshape + :: IORef GLFWState + -> [Callback] + -> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO () +callbackReshape glfwState callbacks _win sizeX sizeY = + sequence_ $ + map + (\f -> f (sizeX, sizeY)) + [f glfwState | Reshape f <- callbacks] + + +-- KeyMouse ----------------------------------------------------------------------- + +{-| Callbacks for when the user presses a key or moves / clicks the mouse. + This is a bit verbose because we have to do impedence matching between + GLFW's event system, and the one use by Brillo which was originally + based on GLUT. The main problem is that GLUT only provides a single callback + slot for character keys, arrow keys, mouse buttons and mouse wheel movement, + while GLFW provides a single slot for each. +-} +installKeyMouseCallbackGLFW + :: IORef GLFWState + -> [Callback] + -> IO () +installKeyMouseCallbackGLFW stateRef callbacks = + do + win <- windowHandle stateRef + GLFW.setKeyCallback win (Just $ callbackKeyboard stateRef callbacks) + GLFW.setCharCallback win (Just $ callbackChar stateRef callbacks) + GLFW.setMouseButtonCallback win (Just $ callbackMouseButton stateRef callbacks) + GLFW.setScrollCallback win (Just $ callbackMouseWheel stateRef callbacks) + + +-- GLFW calls this on a non-character keyboard action. +callbackKeyboard + :: IORef GLFWState + -> [Callback] + -> GLFW.KeyCallback -- = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO () + -- -> GLFW.Key -> Bool + -- -> IO () +callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers = + do + let keystate = keystateglfw == GLFW.KeyState'Pressed + (modsSet, GLFWState mods pos _ _ _ _ _) <- + setModifiers stateRef key keystate + let key' = fromGLFW key + let keystate' = if keystate then Down else Up + let isCharKey (Char _) = True + isCharKey _ = False + + -- Call the Brillo KeyMouse actions with the new state. + unless (modsSet || isCharKey key' && keystate) $ + sequence_ $ + map + (\f -> f key' keystate' mods pos) + [f stateRef | KeyMouse f <- callbacks] + + +setModifiers + :: IORef GLFWState + -> GLFW.Key + -> Bool + -> IO (Bool, GLFWState) +setModifiers stateRef key pressed = + do + glfwState <- readIORef stateRef + let mods = modifiers glfwState + let mods' = case key of + GLFW.Key'LeftShift -> mods{shift = if pressed then Down else Up} + GLFW.Key'LeftControl -> mods{ctrl = if pressed then Down else Up} + GLFW.Key'LeftAlt -> mods{alt = if pressed then Down else Up} + _ -> mods + + if (mods' /= mods) + then do + let glfwState' = glfwState{modifiers = mods'} + writeIORef stateRef glfwState' + return (True, glfwState') + else return (False, glfwState) + + +-- GLFW calls this on a when the user presses or releases a character key. +callbackChar + :: IORef GLFWState + -> [Callback] + -> GLFW.CharCallback +-- Window -> Char -> IO () +-- -> Char -> Bool -> IO () + +callbackChar stateRef callbacks _win char -- keystate + = + do + (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef + let key' = charToSpecial char + -- TODO: is this correct? GLFW does not provide the keystate + -- in a character callback, here we asume that its pressed + let keystate = True + + -- Only key presses of characters are passed to this callback, + -- character key releases are caught by the 'keyCallback'. This is an + -- intentional feature of GLFW. What this means that a key press of + -- the '>' char (on a US Intl keyboard) is captured by this callback, + -- but a release is captured as a '.' with the shift-modifier in the + -- keyCallback. + let keystate' = if keystate then Down else Up + + -- Call all the Brillo KeyMouse actions with the new state. + sequence_ $ + map + (\f -> f key' keystate' mods pos) + [f stateRef | KeyMouse f <- callbacks] + + +-- GLFW calls on this when the user clicks or releases a mouse button. +callbackMouseButton + :: IORef GLFWState + -> [Callback] + -> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () +callbackMouseButton stateRef callbacks _win key keystate _modifier = + do + (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef + let key' = fromGLFW key + let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up + + -- Call all the Brillo KeyMouse actions with the new state. + sequence_ $ + map + (\f -> f key' keystate' mods pos) + [f stateRef | KeyMouse f <- callbacks] + + +-- GLFW calls on this when the user moves the mouse wheel. +callbackMouseWheel + :: IORef GLFWState + -> [Callback] + -> GLFW.ScrollCallback +-- -> Int +-- -> IO () +-- ScrollCallback = Window -> Double -> Double -> IO () +callbackMouseWheel stateRef callbacks _win x _y = + do + (key, keystate) <- setMouseWheel stateRef (floor x) + (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef + + -- Call all the Brillo KeyMouse actions with the new state. + sequence_ $ + map + (\f -> f key keystate mods pos) + [f stateRef | KeyMouse f <- callbacks] + + +setMouseWheel + :: IORef GLFWState + -> Int + -> IO (Key, KeyState) +setMouseWheel stateRef w = + do + glfwState <- readIORef stateRef + writeIORef stateRef $ glfwState{mouseWheelPos = w} + case compare w (mouseWheelPos glfwState) of + LT -> return (MouseButton WheelDown, Down) + GT -> return (MouseButton WheelUp, Down) + EQ -> return (SpecialKey KeyUnknown, Up) + + +-- Motion Callback ------------------------------------------------------------ + +-- | Callback for when the user moves the mouse. +installMotionCallbackGLFW + :: IORef GLFWState + -> [Callback] + -> IO () +installMotionCallbackGLFW stateRef callbacks = + do + win <- windowHandle stateRef + GLFW.setCursorPosCallback win (Just $ callbackMotion stateRef callbacks) + + +-- CursorPosCallback = Window -> Double -> Double -> IO () + +callbackMotion + :: IORef GLFWState + -> [Callback] + -> GLFW.CursorPosCallback +callbackMotion stateRef callbacks _win x y = + do + pos <- setMousePos stateRef (floor x) (floor y) + + -- Call all the Brillo Motion actions with the new state. + sequence_ $ + map + (\f -> f pos) + [f stateRef | Motion f <- callbacks] + + +setMousePos + :: IORef GLFWState + -> Int + -> Int + -> IO (Int, Int) +setMousePos stateRef x y = + do + let pos = (x, y) + + modifyIORef' stateRef $ \s -> + s + { mousePosition = pos + } + + return pos + + +-- Idle Callback -------------------------------------------------------------- + +{-| Callback for when GLFW has finished its jobs and it's time for us to do + something for our application. +-} +installIdleCallbackGLFW + :: IORef GLFWState + -> [Callback] + -> IO () +installIdleCallbackGLFW stateRef callbacks = + modifyIORef' stateRef $ \s -> + s + { idle = callbackIdle stateRef callbacks + } + + +callbackIdle + :: IORef GLFWState + -> [Callback] + -> IO () +callbackIdle stateRef callbacks = + sequence_ $ + [f stateRef | Idle f <- callbacks] + + +-- Main Loop ------------------------------------------------------------------ + +runMainLoopGLFW :: IORef GLFWState -> IO () +runMainLoopGLFW stateRef = do + X.catch go handleException + GLFW.destroyWindow =<< windowHandle stateRef + GLFW.terminate + where + handleException :: X.SomeException -> IO () + handleException = print + + clearDirtyFlag :: IO () + clearDirtyFlag = + modifyIORef' + stateRef + (\state -> state{dirtyScreen = False}) + + display' :: IO () + display' = readIORef stateRef >>= display + + idle' :: IO () + idle' = readIORef stateRef >>= idle + + swapBuffers' :: IO () + swapBuffers' = windowHandle stateRef >>= GLFW.swapBuffers + + windowShouldClose :: IO Bool + windowShouldClose = windowHandle stateRef >>= GLFW.windowShouldClose + + unlessM :: (Monad m) => m Bool -> m () -> m () + unlessM testAction action = do + sentinel <- testAction + unless sentinel action + + go :: IO () + go = do + -- Perform drawing, clear the dirty flag, do idle processing + display' + clearDirtyFlag + idle' + + -- Swap buffers. This swaps the GL buffers and will block + -- until the next v-sync. In GLFW, this effectively pegs the + -- maximum frame rate to 60fps, but will also stop the + -- application from consuming 100% CPU. + swapBuffers' + + -- Poll for GLFW events; quit if necessary. + GLFW.pollEvents + unlessM windowShouldClose go + + +-- Redisplay ------------------------------------------------------------------ +postRedisplayGLFW + :: IORef GLFWState + -> IO () +postRedisplayGLFW stateRef = + modifyIORef' stateRef $ \s -> + s + { dirtyScreen = True + } + + +-- Key Code Conversion -------------------------------------------------------- +class GLFWKey a where + fromGLFW :: a -> Key + + +instance GLFWKey GLFW.Key where + fromGLFW key = + case key of + GLFW.Key'A -> charToSpecial 'a' + GLFW.Key'B -> charToSpecial 'b' + GLFW.Key'C -> charToSpecial 'c' + GLFW.Key'D -> charToSpecial 'd' + GLFW.Key'E -> charToSpecial 'e' + GLFW.Key'F -> charToSpecial 'f' + GLFW.Key'G -> charToSpecial 'g' + GLFW.Key'H -> charToSpecial 'h' + GLFW.Key'I -> charToSpecial 'i' + GLFW.Key'J -> charToSpecial 'j' + GLFW.Key'K -> charToSpecial 'k' + GLFW.Key'L -> charToSpecial 'l' + GLFW.Key'M -> charToSpecial 'm' + GLFW.Key'N -> charToSpecial 'n' + GLFW.Key'O -> charToSpecial 'o' + GLFW.Key'P -> charToSpecial 'p' + GLFW.Key'Q -> charToSpecial 'q' + GLFW.Key'R -> charToSpecial 'r' + GLFW.Key'S -> charToSpecial 's' + GLFW.Key'T -> charToSpecial 't' + GLFW.Key'U -> charToSpecial 'u' + GLFW.Key'V -> charToSpecial 'v' + GLFW.Key'W -> charToSpecial 'w' + GLFW.Key'X -> charToSpecial 'x' + GLFW.Key'Y -> charToSpecial 'y' + GLFW.Key'Z -> charToSpecial 'z' + GLFW.Key'Space -> SpecialKey KeySpace + GLFW.Key'Escape -> SpecialKey KeyEsc + GLFW.Key'F1 -> SpecialKey KeyF1 + GLFW.Key'F2 -> SpecialKey KeyF2 + GLFW.Key'F3 -> SpecialKey KeyF3 + GLFW.Key'F4 -> SpecialKey KeyF4 + GLFW.Key'F5 -> SpecialKey KeyF5 + GLFW.Key'F6 -> SpecialKey KeyF6 + GLFW.Key'F7 -> SpecialKey KeyF7 + GLFW.Key'F8 -> SpecialKey KeyF8 + GLFW.Key'F9 -> SpecialKey KeyF9 + GLFW.Key'F10 -> SpecialKey KeyF10 + GLFW.Key'F11 -> SpecialKey KeyF11 + GLFW.Key'F12 -> SpecialKey KeyF12 + GLFW.Key'F13 -> SpecialKey KeyF13 + GLFW.Key'F14 -> SpecialKey KeyF14 + GLFW.Key'F15 -> SpecialKey KeyF15 + GLFW.Key'F16 -> SpecialKey KeyF16 + GLFW.Key'F17 -> SpecialKey KeyF17 + GLFW.Key'F18 -> SpecialKey KeyF18 + GLFW.Key'F19 -> SpecialKey KeyF19 + GLFW.Key'F20 -> SpecialKey KeyF20 + GLFW.Key'F21 -> SpecialKey KeyF21 + GLFW.Key'F22 -> SpecialKey KeyF22 + GLFW.Key'F23 -> SpecialKey KeyF23 + GLFW.Key'F24 -> SpecialKey KeyF24 + GLFW.Key'F25 -> SpecialKey KeyF25 + GLFW.Key'Up -> SpecialKey KeyUp + GLFW.Key'Down -> SpecialKey KeyDown + GLFW.Key'Left -> SpecialKey KeyLeft + GLFW.Key'Right -> SpecialKey KeyRight + GLFW.Key'Tab -> SpecialKey KeyTab + GLFW.Key'Enter -> SpecialKey KeyEnter + GLFW.Key'Backspace -> SpecialKey KeyBackspace + GLFW.Key'Insert -> SpecialKey KeyInsert + GLFW.Key'Delete -> SpecialKey KeyDelete + GLFW.Key'PageUp -> SpecialKey KeyPageUp + GLFW.Key'PageDown -> SpecialKey KeyPageDown + GLFW.Key'Home -> SpecialKey KeyHome + GLFW.Key'End -> SpecialKey KeyEnd + GLFW.Key'Pad0 -> SpecialKey KeyPad0 + GLFW.Key'Pad1 -> SpecialKey KeyPad1 + GLFW.Key'Pad2 -> SpecialKey KeyPad2 + GLFW.Key'Pad3 -> SpecialKey KeyPad3 + GLFW.Key'Pad4 -> SpecialKey KeyPad4 + GLFW.Key'Pad5 -> SpecialKey KeyPad5 + GLFW.Key'Pad6 -> SpecialKey KeyPad6 + GLFW.Key'Pad7 -> SpecialKey KeyPad7 + GLFW.Key'Pad8 -> SpecialKey KeyPad8 + GLFW.Key'Pad9 -> SpecialKey KeyPad9 + GLFW.Key'PadDivide -> SpecialKey KeyPadDivide + GLFW.Key'PadMultiply -> SpecialKey KeyPadMultiply + GLFW.Key'PadSubtract -> SpecialKey KeyPadSubtract + GLFW.Key'PadAdd -> SpecialKey KeyPadAdd + GLFW.Key'PadDecimal -> SpecialKey KeyPadDecimal + GLFW.Key'PadEqual -> Char '=' + GLFW.Key'PadEnter -> SpecialKey KeyPadEnter + _ -> SpecialKey KeyUnknown + + +{-| Convert char keys to special keys to work around a bug in + GLFW 2.7. On OS X, GLFW sometimes registers special keys as char keys, + so we convert them back here. + GLFW 2.7 is current as of Nov 2011, and is shipped with the Hackage + binding GLFW-b 0.2.* +-} +charToSpecial :: Char -> Key +charToSpecial c = case (fromEnum c) of + 32 -> SpecialKey KeySpace + 63232 -> SpecialKey KeyUp + 63233 -> SpecialKey KeyDown + 63234 -> SpecialKey KeyLeft + 63235 -> SpecialKey KeyRight + 63236 -> SpecialKey KeyF1 + 63237 -> SpecialKey KeyF2 + 63238 -> SpecialKey KeyF3 + 63239 -> SpecialKey KeyF4 + 63240 -> SpecialKey KeyF5 + 63241 -> SpecialKey KeyF6 + 63242 -> SpecialKey KeyF7 + 63243 -> SpecialKey KeyF8 + 63244 -> SpecialKey KeyF9 + 63245 -> SpecialKey KeyF10 + 63246 -> SpecialKey KeyF11 + 63247 -> SpecialKey KeyF12 + 63248 -> SpecialKey KeyF13 + 63272 -> SpecialKey KeyDelete + 63273 -> SpecialKey KeyHome + 63275 -> SpecialKey KeyEnd + 63276 -> SpecialKey KeyPageUp + 63277 -> SpecialKey KeyPageDown + _ -> Char c + + +instance GLFWKey GLFW.MouseButton where + fromGLFW mouse = + case mouse of + GLFW.MouseButton'1 -> MouseButton LeftButton + GLFW.MouseButton'2 -> MouseButton RightButton + GLFW.MouseButton'3 -> MouseButton MiddleButton + GLFW.MouseButton'4 -> MouseButton $ AdditionalButton 4 + GLFW.MouseButton'5 -> MouseButton $ AdditionalButton 5 + GLFW.MouseButton'6 -> MouseButton $ AdditionalButton 6 + GLFW.MouseButton'7 -> MouseButton $ AdditionalButton 7 + GLFW.MouseButton'8 -> MouseButton $ AdditionalButton 8 diff --git a/Brillo/Internals/Interface/Backend/Types.hs b/Brillo/Internals/Interface/Backend/Types.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Backend/Types.hs @@ -0,0 +1,246 @@ +{-# OPTIONS -fspec-constr-count=5 #-} +{-# LANGUAGE Rank2Types #-} + +module Brillo.Internals.Interface.Backend.Types ( + module Brillo.Internals.Interface.Backend.Types, + module Brillo.Data.Display, +) +where + +import Brillo.Data.Display +import Data.IORef + + +{-| The functions every backend window managed backend needs to support. + + The Backend module interfaces with the window manager, and handles opening + and closing the window, and managing key events etc. + + It doesn't know anything about drawing lines or setting colors. + When we get a display callback, Brillo will perform OpenGL actions, and + the backend needs to have OpenGL in a state where it's able to accept them. +-} +class Backend a where + -- | Initialize the state used by the backend. + -- If you don't use any state, make a Unit-like type. + initBackendState :: a + + + -- | Perform any initialization that needs to happen before opening a window + -- The Boolean flag indicates if any debug information should be printed to + -- the terminal + initializeBackend :: IORef a -> Bool -> IO () + + + -- | Perform any deinitialization and close the backend. + exitBackend :: IORef a -> IO () + + + -- | Open a window with the given display mode. + openWindow :: IORef a -> Display -> IO () + + + -- | Dump information about the backend to the terminal. + dumpBackendState :: IORef a -> IO () + + + -- | Install the display callbacks. + installDisplayCallback :: IORef a -> [Callback] -> IO () + + + -- | Install the window close callback. + installWindowCloseCallback :: IORef a -> IO () + + + -- | Install the reshape callbacks. + installReshapeCallback :: IORef a -> [Callback] -> IO () + + + -- | Install the keymouse press callbacks. + installKeyMouseCallback :: IORef a -> [Callback] -> IO () + + + -- | Install the mouse motion callbacks. + installMotionCallback :: IORef a -> [Callback] -> IO () + + + -- | Install the idle callbacks. + installIdleCallback :: IORef a -> [Callback] -> IO () + + + -- | The mainloop of the backend. + runMainLoop :: IORef a -> IO () + + + -- | A function that signals that screen has to be updated. + postRedisplay :: IORef a -> IO () + + + -- | Function that returns (width,height) of the window in pixels. + getWindowDimensions :: IORef a -> IO (Int, Int) + + + -- | Function that returns (width,height) of a fullscreen window in pixels. + getScreenSize :: IORef a -> IO (Int, Int) + + + -- | Function that reports the time elapsed since the application started. + -- (in seconds) + elapsedTime :: IORef a -> IO Double + + + -- | Function that puts the current thread to sleep for 'n' seconds. + sleep :: IORef a -> Double -> IO () + + +-- The callbacks should work for all backends. We pass a reference to the +-- backend state so that the callbacks have access to the class dictionary and +-- can thus call the appropriate backend functions. + +-- | Display callback has no arguments. +type DisplayCallback = + forall a. (Backend a) => IORef a -> IO () + + +-- | Arguments: KeyType, Key Up \/ Down, Ctrl \/ Alt \/ Shift pressed, latest mouse location. +type KeyboardMouseCallback = + forall a. (Backend a) => IORef a -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO () + + +-- | Arguments: (PosX,PosY) in pixels. +type MotionCallback = + forall a. (Backend a) => IORef a -> (Int, Int) -> IO () + + +-- | No arguments. +type IdleCallback = + forall a. (Backend a) => IORef a -> IO () + + +-- | Arguments: (Width,Height) in pixels. +type ReshapeCallback = + forall a. (Backend a) => IORef a -> (Int, Int) -> IO () + + +------------------------------------------------------------------------------- +data Callback + = Display DisplayCallback + | KeyMouse KeyboardMouseCallback + | Idle IdleCallback + | Motion MotionCallback + | Reshape ReshapeCallback + + +-- | Check if this is an `Idle` callback. +isIdleCallback :: Callback -> Bool +isIdleCallback cc = + case cc of + Idle _ -> True + _ -> False + + +------------------------------------------------------------------------------- +-- This is Brillo's view of mouse and keyboard events. +-- The actual events provided by the backends are converted to this form +-- by the backend module. + +data Key + = Char Char + | SpecialKey SpecialKey + | MouseButton MouseButton + deriving (Show, Eq, Ord) + + +data MouseButton + = LeftButton + | MiddleButton + | RightButton + | WheelUp + | WheelDown + | AdditionalButton Int + deriving (Show, Eq, Ord) + + +data KeyState + = Down + | Up + deriving (Show, Eq, Ord) + + +data SpecialKey + = KeyUnknown + | KeySpace + | KeyEsc + | KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyF13 + | KeyF14 + | KeyF15 + | KeyF16 + | KeyF17 + | KeyF18 + | KeyF19 + | KeyF20 + | KeyF21 + | KeyF22 + | KeyF23 + | KeyF24 + | KeyF25 + | KeyUp + | KeyDown + | KeyLeft + | KeyRight + | KeyTab + | KeyEnter + | KeyBackspace + | KeyInsert + | KeyNumLock + | KeyBegin + | KeyDelete + | KeyPageUp + | KeyPageDown + | KeyHome + | KeyEnd + | KeyShiftL + | KeyShiftR + | KeyCtrlL + | KeyCtrlR + | KeyAltL + | KeyAltR + | KeyPad0 + | KeyPad1 + | KeyPad2 + | KeyPad3 + | KeyPad4 + | KeyPad5 + | KeyPad6 + | KeyPad7 + | KeyPad8 + | KeyPad9 + | KeyPadDivide + | KeyPadMultiply + | KeyPadSubtract + | KeyPadAdd + | KeyPadDecimal + | KeyPadEqual + | KeyPadEnter + deriving (Show, Eq, Ord) + + +data Modifiers + = Modifiers + { shift :: KeyState + , ctrl :: KeyState + , alt :: KeyState + } + deriving (Show, Eq, Ord) diff --git a/Brillo/Internals/Interface/Callback.hs b/Brillo/Internals/Interface/Callback.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Callback.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Re-export event callbacks. +module Brillo.Internals.Interface.Callback ( + Callback (..), + DisplayCallback, + KeyboardMouseCallback, + MotionCallback, + IdleCallback, + ReshapeCallback, +) +where + +import Brillo.Internals.Interface.Backend.Types + diff --git a/Brillo/Internals/Interface/Common/Exit.hs b/Brillo/Internals/Interface/Common/Exit.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Common/Exit.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Callback for exiting the program. +module Brillo.Internals.Interface.Common.Exit (callback_exit) +where + +import Brillo.Internals.Interface.Backend.Types + + +callback_exit :: a -> Callback +callback_exit stateRef = + KeyMouse (keyMouse_exit stateRef) + + +keyMouse_exit :: a -> KeyboardMouseCallback +keyMouse_exit + _ + backend + key + keyState + _ + _ + | key == SpecialKey KeyEsc + , keyState == Down = + exitBackend backend + | otherwise = + return () diff --git a/Brillo/Internals/Interface/Debug.hs b/Brillo/Internals/Interface/Debug.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Debug.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-| Implements functions to dump portions of the OpenGL state to stdout. + Used for debugging. +-} +module Brillo.Internals.Interface.Debug ( + dumpFramebufferState, + dumpFragmentState, +) +where + +import Graphics.Rendering.OpenGL (get) +import Graphics.Rendering.OpenGL.GL qualified as GL + + +-- | Dump internal state of the OpenGL framebuffer +dumpFramebufferState :: IO () +dumpFramebufferState = + do + auxBuffers <- get GL.auxBuffers + doubleBuffer <- get GL.doubleBuffer + drawBuffer <- get GL.drawBuffer + + rgbaBits <- get GL.rgbaBits + stencilBits <- get GL.stencilBits + depthBits <- get GL.depthBits + accumBits <- get GL.accumBits + + clearColor <- get GL.clearColor + clearStencil <- get GL.clearStencil + clearDepth <- get GL.clearDepth + clearAccum <- get GL.clearAccum + + colorMask <- get GL.colorMask + stencilMask <- get GL.stencilMask + depthMask <- get GL.depthMask + + putStr $ + "* dumpFramebufferState\n" + ++ " auxBuffers = " + ++ show auxBuffers + ++ "\n" + ++ " doubleBuffer = " + ++ show doubleBuffer + ++ "\n" + ++ " drawBuffer = " + ++ show drawBuffer + ++ "\n" + ++ "\n" + ++ " bits rgba = " + ++ show rgbaBits + ++ "\n" + ++ " stencil = " + ++ show stencilBits + ++ "\n" + ++ " depth = " + ++ show depthBits + ++ "\n" + ++ " accum = " + ++ show accumBits + ++ "\n" + ++ "\n" + ++ " clear color = " + ++ show clearColor + ++ "\n" + ++ " stencil = " + ++ show clearStencil + ++ "\n" + ++ " depth = " + ++ show clearDepth + ++ "\n" + ++ " accum = " + ++ show clearAccum + ++ "\n" + ++ "\n" + ++ " mask color = " + ++ show colorMask + ++ "\n" + ++ " stencil = " + ++ show stencilMask + ++ "\n" + ++ " depth = " + ++ show depthMask + ++ "\n" + ++ "\n" + + +-- | Dump internal state of the fragment renderer. +dumpFragmentState :: IO () +dumpFragmentState = + do + blend <- get GL.blend + blendEquation <- get GL.blendEquation + blendFunc <- get GL.blendFunc + + putStr $ + "* dumpFragmentState\n" + ++ " blend = " + ++ show blend + ++ "\n" + ++ " blend equation = " + ++ show blendEquation + ++ "\n" + ++ " blend func = " + ++ show blendFunc + ++ "\n" + ++ "\n" diff --git a/Brillo/Internals/Interface/Display.hs b/Brillo/Internals/Interface/Display.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Display.hs @@ -0,0 +1,88 @@ +module Brillo.Internals.Interface.Display (displayWithBackend) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Callback qualified as Callback +import Brillo.Internals.Interface.Common.Exit +import Brillo.Internals.Interface.ViewState.KeyMouse +import Brillo.Internals.Interface.ViewState.Motion +import Brillo.Internals.Interface.ViewState.Reshape +import Brillo.Internals.Interface.Window +import Brillo.Rendering +import Data.IORef +import System.Mem + + +displayWithBackend + :: (Backend a) + => a + -- ^ Initial state of the backend. + -> Display + -- ^ Display config. + -> Color + -- ^ Background color. + -> IO Picture + -- ^ Make the picture to draw. + -> (Controller -> IO ()) + -- ^ Eat the controller + -> IO () +displayWithBackend + backend + displayMode + background + makePicture + eatController = + do + viewSR <- newIORef viewStateInit + renderS <- initState + renderSR <- newIORef renderS + + let renderFun backendRef = do + port <- viewStateViewPort <$> readIORef viewSR + options <- readIORef renderSR + windowSize <- getWindowDimensions backendRef + picture <- makePicture + + displayPicture + windowSize + background + options + (viewPortScale port) + (applyViewPortToPicture port picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks = + [ Callback.Display renderFun + , -- Escape exits the program + callback_exit () + , -- Viewport control with mouse + callback_viewState_keyMouse viewSR + , callback_viewState_motion viewSR + , callback_viewState_reshape + ] + + -- When we create the window we can pass a function to get a + -- reference to the backend state. Using this we make a controller + -- so the client can control the window asynchronously. + createWindow backend displayMode background callbacks $ + \backendRef -> + eatController $ + Controller + { controllerSetRedraw = + do postRedisplay backendRef + , controllerModifyViewPort = + \modViewPort -> + do + viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState{viewStateViewPort = port'} + writeIORef viewSR viewState' + postRedisplay backendRef + } diff --git a/Brillo/Internals/Interface/Event.hs b/Brillo/Internals/Interface/Event.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Event.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE RankNTypes #-} + +module Brillo.Internals.Interface.Event ( + Event (..), + keyMouseEvent, + motionEvent, +) +where + +import Brillo.Internals.Interface.Backend +import Data.IORef + + +-- | Possible input events. +data Event + = EventKey Key KeyState Modifiers (Float, Float) + | EventMotion (Float, Float) + | EventResize (Int, Int) + deriving (Eq, Show) + + +keyMouseEvent + :: forall a + . (Backend a) + => IORef a + -> Key + -> KeyState + -> Modifiers + -> (Int, Int) + -> IO Event +keyMouseEvent backendRef key keyState modifiers pos = + EventKey key keyState modifiers <$> convertPoint backendRef pos + + +motionEvent + :: forall a + . (Backend a) + => IORef a + -> (Int, Int) + -> IO Event +motionEvent backendRef pos = + EventMotion <$> convertPoint backendRef pos + + +convertPoint + :: forall a + . (Backend a) + => IORef a + -> (Int, Int) + -> IO (Float, Float) +convertPoint backendRef pos = + do + (sizeX_, sizeY_) <- getWindowDimensions backendRef + let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) + + let (px_, py_) = pos + let px = fromIntegral px_ + let py = sizeY - fromIntegral py_ + + let px' = px - sizeX / 2 + let py' = py - sizeY / 2 + let pos' = (px', py') + return pos' diff --git a/Brillo/Internals/Interface/Game.hs b/Brillo/Internals/Interface/Game.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Game.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RankNTypes #-} + +module Brillo.Internals.Interface.Game ( + playWithBackendIO, + Event (..), +) +where + +import Brillo.Data.Color +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Internals.Interface.Animate.State qualified as AN +import Brillo.Internals.Interface.Animate.Timing +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Callback qualified as Callback +import Brillo.Internals.Interface.Common.Exit +import Brillo.Internals.Interface.Event +import Brillo.Internals.Interface.Simulate.Idle +import Brillo.Internals.Interface.Simulate.State qualified as SM +import Brillo.Internals.Interface.ViewState.Reshape +import Brillo.Internals.Interface.Window +import Brillo.Rendering +import Data.IORef +import System.Mem + + +playWithBackendIO + :: forall world a + . (Backend a) + => a + -- ^ Initial state of the backend + -> Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> world + -- ^ The initial world. + -> (world -> IO Picture) + -- ^ A function to convert the world to a picture. + -> (Event -> world -> IO world) + -- ^ A function to handle input events. + -> (Float -> world -> IO world) + -- ^ A function to step the world one iteration. + -- It is passed the period of time (in seconds) needing to be advanced. + -> Bool + -- ^ Whether to use the callback_exit or not. + -> IO () +playWithBackendIO + backend + display + backgroundColor + simResolution + worldStart + worldToPicture + worldHandleEvent + worldAdvance + withCallbackExit = + do + let singleStepTime = 1 + + -- make the simulation state + stateSR <- newIORef $ SM.stateInit simResolution + + -- make a reference to the initial world + worldSR <- newIORef worldStart + + -- make the initial GL view and render states + viewSR <- newIORef viewPortInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ + + let displayFun backendRef = + do + -- convert the world to a picture + world <- readIORef worldSR + picture <- worldToPicture world + + -- display the picture in the current view + renderS <- readIORef renderSR + viewPort <- readIORef viewSR + + windowSize <- getWindowDimensions backendRef + + -- render the frame + displayPicture + windowSize + backgroundColor + renderS + (viewPortScale viewPort) + (applyViewPortToPicture viewPort picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks = + [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle + ( callback_simulate_idle + stateSR + animateSR + (readIORef viewSR) + worldSR + (\_ -> worldAdvance) + singleStepTime + ) + , callback_keyMouse worldSR viewSR worldHandleEvent + , callback_motion worldSR worldHandleEvent + , callback_reshape worldSR worldHandleEvent + ] + + let exitCallback = + if withCallbackExit then [callback_exit ()] else [] + + createWindow + backend + display + backgroundColor + (callbacks ++ exitCallback) + (\_ -> return ()) + + +-- | Callback for KeyMouse events. +callback_keyMouse + :: IORef world + -- ^ ref to world state + -> IORef ViewPort + -> (Event -> world -> IO world) + -- ^ fn to handle input events + -> Callback +callback_keyMouse worldRef viewRef eventFn = + KeyMouse (handle_keyMouse worldRef viewRef eventFn) + + +handle_keyMouse + :: IORef a + -> t + -> (Event -> a -> IO a) + -> KeyboardMouseCallback +handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos = + do + ev <- keyMouseEvent backendRef key keyState keyMods pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + + +-- | Callback for Motion events. +callback_motion + :: IORef world + -- ^ ref to world state + -> (Event -> world -> IO world) + -- ^ fn to handle input events + -> Callback +callback_motion worldRef eventFn = + Motion (handle_motion worldRef eventFn) + + +handle_motion + :: IORef a + -> (Event -> a -> IO a) + -> MotionCallback +handle_motion worldRef eventFn backendRef pos = + do + ev <- motionEvent backendRef pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + + +-- | Callback for Handle reshape event. +callback_reshape + :: IORef world + -> (Event -> world -> IO world) + -> Callback +callback_reshape worldRef eventFN = + Reshape (handle_reshape worldRef eventFN) + + +handle_reshape + :: IORef world + -> (Event -> world -> IO world) + -> ReshapeCallback +handle_reshape worldRef eventFn stateRef (width, height) = + do + world <- readIORef worldRef + world' <- eventFn (EventResize (width, height)) world + writeIORef worldRef world' + viewState_reshape stateRef (width, height) diff --git a/Brillo/Internals/Interface/Interact.hs b/Brillo/Internals/Interface/Interact.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Interact.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE RankNTypes #-} + +module Brillo.Internals.Interface.Interact (interactWithBackend) +where + +import Brillo.Data.Color +import Brillo.Data.Controller +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Callback qualified as Callback +import Brillo.Internals.Interface.Event +import Brillo.Internals.Interface.ViewState.Reshape +import Brillo.Internals.Interface.Window +import Brillo.Rendering +import Data.IORef +import System.Mem + + +interactWithBackend + :: (Backend a) + => a + -- ^ Initial state of the backend. + -> Display + -- ^ Display config. + -> Color + -- ^ Background color. + -> world + -- ^ The initial world. + -> (world -> IO Picture) + -- ^ A function to produce the current picture. + -> (Event -> world -> IO world) + -- ^ A function to handle input events. + -> (Controller -> IO ()) + -- ^ Eat the controller + -> IO () +interactWithBackend + backend + displayMode + background + worldStart + worldToPicture + worldHandleEvent + eatController = + do + viewSR <- newIORef viewStateInit + worldSR <- newIORef worldStart + renderS <- initState + renderSR <- newIORef renderS + + let displayFun backendRef = do + world <- readIORef worldSR + picture <- worldToPicture world + + renderS' <- readIORef renderSR + viewState <- readIORef viewSR + let viewPort = viewStateViewPort viewState + + windowSize <- getWindowDimensions backendRef + + displayPicture + windowSize + background + renderS' + (viewPortScale viewPort) + (applyViewPortToPicture viewPort picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks = + [ Callback.Display displayFun + , -- Viewport control with mouse + callback_keyMouse worldSR viewSR worldHandleEvent + , callback_motion worldSR worldHandleEvent + , callback_reshape worldSR worldHandleEvent + ] + + -- When we create the window we can pass a function to get a + -- reference to the backend state. Using this we make a controller + -- so the client can control the window asynchronously. + createWindow backend displayMode background callbacks $ + \backendRef -> + eatController $ + Controller + { controllerSetRedraw = + do postRedisplay backendRef + , controllerModifyViewPort = + \modViewPort -> + do + viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState{viewStateViewPort = port'} + writeIORef viewSR viewState' + postRedisplay backendRef + } + + +-- | Callback for KeyMouse events. +callback_keyMouse + :: IORef world + -- ^ ref to world state + -> IORef ViewState + -> (Event -> world -> IO world) + -- ^ fn to handle input events + -> Callback +callback_keyMouse worldRef viewRef eventFn = + KeyMouse (handle_keyMouse worldRef viewRef eventFn) + + +handle_keyMouse + :: IORef a + -> t + -> (Event -> a -> IO a) + -> KeyboardMouseCallback +handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos = + do + ev <- keyMouseEvent backendRef key keyState keyMods pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + postRedisplay backendRef + + +-- | Callback for Motion events. +callback_motion + :: IORef world + -- ^ ref to world state + -> (Event -> world -> IO world) + -- ^ fn to handle input events + -> Callback +callback_motion worldRef eventFn = + Motion (handle_motion worldRef eventFn) + + +handle_motion + :: IORef a + -> (Event -> a -> IO a) + -> MotionCallback +handle_motion worldRef eventFn backendRef pos = + do + ev <- motionEvent backendRef pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + postRedisplay backendRef + + +-- | Callback for Handle reshape event. +callback_reshape + :: IORef world + -> (Event -> world -> IO world) + -> Callback +callback_reshape worldRef eventFN = + Reshape (handle_reshape worldRef eventFN) + + +handle_reshape + :: IORef world + -> (Event -> world -> IO world) + -> ReshapeCallback +handle_reshape worldRef eventFn backendRef (width, height) = + do + world <- readIORef worldRef + world' <- eventFn (EventResize (width, height)) world + writeIORef worldRef world' + viewState_reshape backendRef (width, height) + postRedisplay backendRef diff --git a/Brillo/Internals/Interface/Simulate.hs b/Brillo/Internals/Interface/Simulate.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Simulate.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RankNTypes #-} + +module Brillo.Internals.Interface.Simulate (simulateWithBackendIO) +where + +import Brillo.Data.Color +import Brillo.Data.Display +import Brillo.Data.Picture +import Brillo.Data.ViewPort +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Animate.State qualified as AN +import Brillo.Internals.Interface.Animate.Timing +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Callback qualified as Callback +import Brillo.Internals.Interface.Common.Exit +import Brillo.Internals.Interface.Simulate.Idle +import Brillo.Internals.Interface.Simulate.State qualified as SM +import Brillo.Internals.Interface.ViewState.KeyMouse +import Brillo.Internals.Interface.ViewState.Motion +import Brillo.Internals.Interface.ViewState.Reshape +import Brillo.Internals.Interface.Window +import Brillo.Rendering +import Data.IORef +import System.Mem + + +simulateWithBackendIO + :: forall model a + . (Backend a) + => a + -- ^ Initial state of the backend + -> Display + -- ^ Display mode. + -> Color + -- ^ Background color. + -> Int + -- ^ Number of simulation steps to take for each second of real time. + -> model + -- ^ The initial model. + -> (model -> IO Picture) + -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> IO model) + -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). + -> IO () +simulateWithBackendIO + backend + display + backgroundColor + simResolution + worldStart + worldToPicture + worldAdvance = + do + let singleStepTime = 1 + + -- make the simulation state + stateSR <- newIORef $ SM.stateInit simResolution + + -- make a reference to the initial world + worldSR <- newIORef worldStart + + -- make the initial GL view and render states + viewSR <- newIORef viewStateInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ + + let displayFun backendRef = + do + -- convert the world to a picture + world <- readIORef worldSR + port <- viewStateViewPort <$> readIORef viewSR + picture <- worldToPicture world + + -- display the picture in the current view + renderS <- readIORef renderSR + + windowSize <- getWindowDimensions backendRef + + -- render the frame + displayPicture + windowSize + backgroundColor + renderS + (viewPortScale port) + (applyViewPortToPicture port picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks = + [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle + ( callback_simulate_idle + stateSR + animateSR + (viewStateViewPort <$> readIORef viewSR) + worldSR + worldAdvance + singleStepTime + ) + , callback_exit () + , callback_viewState_keyMouse viewSR + , callback_viewState_motion viewSR + , callback_viewState_reshape + ] + + createWindow + backend + display + backgroundColor + callbacks + (const (return ())) diff --git a/Brillo/Internals/Interface/Simulate/Idle.hs b/Brillo/Internals/Interface/Simulate/Idle.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Simulate/Idle.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.Simulate.Idle (callback_simulate_idle) +where + +import Brillo.Data.ViewPort +import Brillo.Internals.Interface.Animate.State qualified as AN +import Brillo.Internals.Interface.Backend qualified as Backend +import Brillo.Internals.Interface.Callback +import Brillo.Internals.Interface.Simulate.State qualified as SM +import Control.Monad +import Data.IORef +import GHC.Float (double2Float) + + +{-| The graphics library calls back on this function when it's finished drawing + and it's time to do some computation. +-} +callback_simulate_idle + :: IORef SM.State + -- ^ the simulation state + -> IORef AN.State + -- ^ the animation statea + -> IO ViewPort + -- ^ action to get the 'ViewPort'. We don't use an 'IORef' + -- directly because sometimes we hold a ref to a 'ViewPort' (in + -- Game) and sometimes a ref to a 'ViewState'. + -> IORef world + -- ^ the current world + -> (ViewPort -> Float -> world -> IO world) + -- ^ fn to advance the world + -> Float + -- ^ how much time to advance world by + -- in single step mode + -> IdleCallback +callback_simulate_idle simSR animateSR viewSA worldSR worldAdvance _singleStepTime backendRef = + {-# SCC "callbackIdle" #-} + do simulate_run simSR animateSR viewSA worldSR worldAdvance backendRef + + +-- take the number of steps specified by controlWarp +simulate_run + :: IORef SM.State + -> IORef AN.State + -> IO ViewPort + -> IORef world + -> (ViewPort -> Float -> world -> IO world) + -> IdleCallback +simulate_run simSR _ viewSA worldSR worldAdvance backendRef = + do + viewS <- viewSA + simS <- readIORef simSR + worldS <- readIORef worldSR + + -- get the elapsed time since the start simulation (wall clock) + elapsedTime <- fmap double2Float $ Backend.elapsedTime backendRef + + -- get how far along the simulation is + simTime <- simSR `getsIORef` SM.stateSimTime + + -- we want to simulate this much extra time to bring the simulation + -- up to the wall clock. + let thisTime = elapsedTime - simTime + + -- work out how many steps of simulation this equals + resolution <- simSR `getsIORef` SM.stateResolution + let timePerStep = 1 / fromIntegral resolution + let thisSteps_ = truncate $ fromIntegral resolution * thisTime + let thisSteps = if thisSteps_ < 0 then 0 else thisSteps_ + + let newSimTime = simTime + fromIntegral thisSteps * timePerStep + + {- putStr $ "elapsed time = " ++ show elapsedTime ++ "\n" + ++ "sim time = " ++ show simTime ++ "\n" + ++ "this time = " ++ show thisTime ++ "\n" + ++ "this steps = " ++ show thisSteps ++ "\n" + ++ "new sim time = " ++ show newSimTime ++ "\n" + ++ "taking = " ++ show thisSteps ++ "\n\n" + -} + -- work out the final step number for this display cycle + let nStart = SM.stateIteration simS + let nFinal = nStart + thisSteps + + -- keep advancing the world until we get to the final iteration number + (_, world') <- + untilM + (\(n, _) -> n >= nFinal) + (\(n, w) -> liftM (\w' -> (n + 1, w')) (worldAdvance viewS timePerStep w)) + (nStart, worldS) + + -- write the world back into its IORef + -- We need to seq on the world to avoid space leaks when the window is not showing. + world' `seq` writeIORef worldSR world' + + -- update the control state + modifyIORef' simSR $ \c -> + c + { SM.stateIteration = nFinal + , SM.stateSimTime = newSimTime + } + + -- tell backend we want to draw the window after returning + Backend.postRedisplay backendRef + + +getsIORef :: IORef a -> (a -> r) -> IO r +getsIORef ref fun = + liftM fun $ readIORef ref + + +untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a +untilM test op i = go i + where + go x + | test x = return x + | otherwise = op x >>= go diff --git a/Brillo/Internals/Interface/Simulate/State.hs b/Brillo/Internals/Interface/Simulate/State.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Simulate/State.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.Simulate.State ( + State (..), + stateInit, +) +where + + +-- | Simulation state +data State + = State + { stateIteration :: !Integer + -- ^ The iteration number we're up to. + , stateResolution :: !Int + -- ^ How many simulation setps to take for each second of real time + , stateSimTime :: !Float + -- ^ How many seconds worth of simulation we've done so far + } + + +-- | Initial control state +stateInit :: Int -> State +stateInit resolution = + State + { stateIteration = 0 + , stateResolution = resolution + , stateSimTime = 0 + } diff --git a/Brillo/Internals/Interface/ViewState/KeyMouse.hs b/Brillo/Internals/Interface/ViewState/KeyMouse.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/ViewState/KeyMouse.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.ViewState.KeyMouse (callback_viewState_keyMouse) +where + +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Event +import Data.IORef + + +{-| Callback to handle keyboard and mouse button events + for controlling the 'ViewState'. +-} +callback_viewState_keyMouse + :: IORef ViewState + -> Callback +callback_viewState_keyMouse viewStateRef = + KeyMouse (viewState_keyMouse viewStateRef) + + +viewState_keyMouse :: IORef ViewState -> KeyboardMouseCallback +viewState_keyMouse viewStateRef stateRef key keyState keyMods pos = + do + viewState <- readIORef viewStateRef + ev <- keyMouseEvent stateRef key keyState keyMods pos + case updateViewStateWithEventMaybe ev viewState of + Nothing -> return () + Just viewState' -> + do + viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Brillo/Internals/Interface/ViewState/Motion.hs b/Brillo/Internals/Interface/ViewState/Motion.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/ViewState/Motion.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.ViewState.Motion (callback_viewState_motion) +where + +import Brillo.Data.ViewState +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Event +import Data.IORef + + +{-| Callback to handle keyboard and mouse button events + for controlling the viewport. +-} +callback_viewState_motion + :: IORef ViewState + -> Callback +callback_viewState_motion portRef = + Motion (viewState_motion portRef) + + +viewState_motion :: IORef ViewState -> MotionCallback +viewState_motion viewStateRef stateRef pos = + do + viewState <- readIORef viewStateRef + ev <- motionEvent stateRef pos + case updateViewStateWithEventMaybe ev viewState of + Nothing -> return () + Just viewState' -> + do + viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Brillo/Internals/Interface/ViewState/Reshape.hs b/Brillo/Internals/Interface/ViewState/Reshape.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/ViewState/Reshape.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Brillo.Internals.Interface.ViewState.Reshape (callback_viewState_reshape, viewState_reshape) +where + +import Brillo.Internals.Interface.Backend +import Graphics.Rendering.OpenGL (($=)) +import Graphics.Rendering.OpenGL.GL qualified as GL + + +{-| Callback to handle keyboard and mouse button events + for controlling the viewport. +-} +callback_viewState_reshape :: Callback +callback_viewState_reshape = + Reshape (viewState_reshape) + + +viewState_reshape :: ReshapeCallback +viewState_reshape stateRef (width, height) = + do + -- Setup the viewport + -- This controls what part of the window openGL renders to. + -- We'll use the whole window. + -- + GL.viewport + $= ( GL.Position 0 0 + , GL.Size (fromIntegral width) (fromIntegral height) + ) + postRedisplay stateRef diff --git a/Brillo/Internals/Interface/Window.hs b/Brillo/Internals/Interface/Window.hs new file mode 100644 --- /dev/null +++ b/Brillo/Internals/Interface/Window.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | The main display function. +module Brillo.Internals.Interface.Window (createWindow) +where + +import Brillo.Data.Color +import Brillo.Internals.Color +import Brillo.Internals.Interface.Backend +import Brillo.Internals.Interface.Debug +import Control.Monad +import Data.IORef (IORef, newIORef) +import Graphics.Rendering.OpenGL (($=)) +import Graphics.Rendering.OpenGL.GL qualified as GL + + +-- | Open a window and use the supplied callbacks to handle window events. +createWindow + :: (Backend a) + => a + -> Display + -> Color + -- ^ Color to use when clearing. + -> [Callback] + -- ^ Callbacks to use. + -> (IORef a -> IO ()) + -- ^ Give the backend back to the caller before + -- entering the main loop. + -> IO () +createWindow + backend + display + clearColor + callbacks + eatBackend = + do + -- Turn this on to spew debugging info to stdout + let debug = False + + -- Initialize backend state + backendStateRef <- newIORef backend + + when debug $ + do putStr $ "* displayInWindow\n" + + -- Intialize backend + initializeBackend backendStateRef debug + + -- Here we go! + when debug $ + do putStr $ "* c window\n\n" + + -- Open window + openWindow backendStateRef display + + -- Setup callbacks + installDisplayCallback backendStateRef callbacks + installWindowCloseCallback backendStateRef + installReshapeCallback backendStateRef callbacks + installKeyMouseCallback backendStateRef callbacks + installMotionCallback backendStateRef callbacks + installIdleCallback backendStateRef callbacks + + -- we don't need the depth buffer for 2d. + GL.depthFunc $= Just GL.Always + + -- always clear the buffer to white + GL.clearColor $= glColor4OfColor clearColor + + -- Dump some debugging info + when debug $ + do + dumpBackendState backendStateRef + dumpFramebufferState + dumpFragmentState + + eatBackend backendStateRef + + when debug $ + do putStr $ "* entering mainloop..\n" + + -- Start the main backend loop + runMainLoop backendStateRef + + when debug $ + putStr $ + "* all done\n" 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.cabal b/brillo.cabal new file mode 100644 --- /dev/null +++ b/brillo.cabal @@ -0,0 +1,87 @@ +cabal-version: 3.0 +name: brillo +version: 1.13.3 +license: MIT +license-file: LICENSE +author: Ben Lippmeier, Adrian Sieber +maintainer: brillo@ad-si.com +build-type: Simple +stability: stable +category: Graphics +homepage: https://github.com/ad-si/Brillo +description: + Brillo hides the pain of drawing simple vector graphics + behind a nice data type and a few display functions. + Brillo uses GLFW and OpenGL under the hood, + but you won't need to worry about any of that. + Get something cool on the screen in under 10 minutes. + +synopsis: + Painless 2D vector graphics, animations, and simulations powered by GLFW + +source-repository head + type: git + location: https://github.com/ad-si/Brillo + +library + default-language: GHC2021 + build-depends: + , base >=4.8 && <5 + , bmp >=1.2 && <1.3 + , brillo-rendering >=1.13.3 && <1.15 + , bytestring >=0.11 && <0.12 + , containers >=0.5 && <0.7 + , ghc-prim + , GLFW-b >=3.3 && <4 + , OpenGL >=2.12 && <3.1 + + ghc-options: -O2 -Wall + exposed-modules: + Brillo + Brillo.Data.Bitmap + Brillo.Data.Color + Brillo.Data.Controller + Brillo.Data.Display + Brillo.Data.Picture + Brillo.Data.Point + Brillo.Data.Point.Arithmetic + Brillo.Data.Vector + Brillo.Data.ViewPort + Brillo.Data.ViewState + Brillo.Geometry.Angle + Brillo.Geometry.Line + Brillo.Interface.Environment + Brillo.Interface.IO.Animate + Brillo.Interface.IO.Display + Brillo.Interface.IO.Game + Brillo.Interface.IO.Interact + Brillo.Interface.IO.Simulate + Brillo.Interface.Pure.Animate + Brillo.Interface.Pure.Display + Brillo.Interface.Pure.Game + Brillo.Interface.Pure.Simulate + + other-modules: + Brillo.Internals.Color + Brillo.Internals.Interface.Animate + Brillo.Internals.Interface.Animate.State + Brillo.Internals.Interface.Animate.Timing + Brillo.Internals.Interface.Backend + Brillo.Internals.Interface.Backend.GLFW + Brillo.Internals.Interface.Backend.Types + Brillo.Internals.Interface.Callback + Brillo.Internals.Interface.Common.Exit + Brillo.Internals.Interface.Debug + Brillo.Internals.Interface.Display + Brillo.Internals.Interface.Event + Brillo.Internals.Interface.Game + Brillo.Internals.Interface.Interact + Brillo.Internals.Interface.Simulate + Brillo.Internals.Interface.Simulate.Idle + Brillo.Internals.Interface.Simulate.State + Brillo.Internals.Interface.ViewState.KeyMouse + Brillo.Internals.Interface.ViewState.Motion + Brillo.Internals.Interface.ViewState.Reshape + Brillo.Internals.Interface.Window + + cpp-options: -DWITHGLFW