packages feed

brillo (empty) → 1.13.3

raw patch · 47 files changed

+4631/−0 lines, 47 filesdep +GLFW-bdep +OpenGLdep +basesetup-changed

Dependencies added: GLFW-b, OpenGL, base, bmp, brillo-rendering, bytestring, containers, ghc-prim

Files

+ Brillo.hs view
@@ -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 <https://github.com/ad-si/Brillo>.+-}+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+
+ Brillo/Data/Bitmap.hs view
@@ -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+
+ Brillo/Data/Color.hs view
@@ -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
+ Brillo/Data/Controller.hs view
@@ -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.+  }
+ Brillo/Data/Display.hs view
@@ -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)
+ Brillo/Data/Picture.hs view
@@ -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
+ Brillo/Data/Point.hs view
@@ -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
+ Brillo/Data/Point/Arithmetic.hs view
@@ -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')
+ Brillo/Data/Vector.hs view
@@ -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 #-}
+ Brillo/Data/ViewPort.hs view
@@ -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 #-}
+ Brillo/Data/ViewState.hs view
@@ -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
+ Brillo/Geometry/Angle.hs view
@@ -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 #-}
+ Brillo/Geometry/Line.hs view
@@ -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
+ Brillo/Interface/Environment.hs view
@@ -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
+ Brillo/Interface/IO/Animate.hs view
@@ -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
+ Brillo/Interface/IO/Display.hs view
@@ -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
+ Brillo/Interface/IO/Game.hs view
@@ -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
+ Brillo/Interface/IO/Interact.hs view
@@ -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
+ Brillo/Interface/IO/Simulate.hs view
@@ -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
+ Brillo/Interface/Pure/Animate.hs view
@@ -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 ()))
+ Brillo/Interface/Pure/Display.hs view
@@ -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 ()))
+ Brillo/Interface/Pure/Game.hs view
@@ -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 ()
+ Brillo/Interface/Pure/Simulate.hs view
@@ -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 ()
+ Brillo/Internals/Color.hs view
@@ -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
+ Brillo/Internals/Interface/Animate.hs view
@@ -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
+ Brillo/Internals/Interface/Animate/State.hs view
@@ -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+    }
+ Brillo/Internals/Interface/Animate/Timing.hs view
@@ -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
+ Brillo/Internals/Interface/Backend.hs view
@@ -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
+ Brillo/Internals/Interface/Backend/GLFW.hs view
@@ -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
+ Brillo/Internals/Interface/Backend/Types.hs view
@@ -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)
+ Brillo/Internals/Interface/Callback.hs view
@@ -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+
+ Brillo/Internals/Interface/Common/Exit.hs view
@@ -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 ()
+ Brillo/Internals/Interface/Debug.hs view
@@ -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"
+ Brillo/Internals/Interface/Display.hs view
@@ -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+              }
+ Brillo/Internals/Interface/Event.hs view
@@ -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'
+ Brillo/Internals/Interface/Game.hs view
@@ -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)
+ Brillo/Internals/Interface/Interact.hs view
@@ -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
+ Brillo/Internals/Interface/Simulate.hs view
@@ -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 ()))
+ Brillo/Internals/Interface/Simulate/Idle.hs view
@@ -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
+ Brillo/Internals/Interface/Simulate/State.hs view
@@ -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+    }
+ Brillo/Internals/Interface/ViewState/KeyMouse.hs view
@@ -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
+ Brillo/Internals/Interface/ViewState/Motion.hs view
@@ -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
+ Brillo/Internals/Interface/ViewState/Reshape.hs view
@@ -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
+ Brillo/Internals/Interface/Window.hs view
@@ -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"
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2010-2024 The Gloss Development Team,+Copyright (c) 2024-2025 The Brillo Development Team++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ brillo.cabal view
@@ -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